scx/scheme/xlib/visual.scm

;; A visual information is an alist with keys of the type
;; visual-info. The corresponding values have the following meaning:
;; screen-number  the screen this visual belongs to
;; depth          the depth of the screen
;; class          the visual-class (see below)
;; red-mask       these masks are used for direct-color and true-color
;; green-mask     to specify which bits of the pixel value specify
;; blue-mask      red, green or blue values.
;; colormap-size  tells how many different pixel value are valid
;; bits-per-rgb   specifies how many bits in each of the red, green 
;;                and blue values in a colorcell are used to drive 
;;                the rgb gun in the screen.
;; visual         this value can be passed to other functions, e.g. 
;;                create-window.
;; visual-id      this value is not normally needed by applications.

(define-enumerated-type visual-info :visual-info
  visual-info?
  visual-infos
  visual-info-name
  visual-info-index
  (visual visual-id screen depth class red-mask green-mask blue-mask 
   colormap-size bits-per-rgp))

(define-syntax make-visual-info-alist
  (syntax-rules 
   ()
   ((make-visual-info-alist (attr arg) rest ...)
    (cons (cons (visual-info attr) arg)
	  (make-visual-info-alist rest ...)))
   ((make-visual-info-alist)
    '())))

(define (get-visual-info display visual-info-alist)
  (let ((res (%get-visual-info (display-Xdisplay display)
			       (visual-info-alist->integer+vector 
				visual-info-alist))))
    (map (lambda (p)
	   (cons (make-visual (car p))
		 (integer+vector->visual-info-alist (cdr p))))
	 (vector->list res))))

(import-lambda-definition %get-visual-info (Xdisplay v)
  "scx_Get_Visual_Info")

;; visual-id returns the id of a given visual.

(define (visual-id visual)
  (%visual-id (visual-Xvisual visual)))

(import-lambda-definition %visual-id (Xvisual)
  "scx_Visual_ID")

;; match-visual-info returns a pair of a visual that matches the given
;; criteria and a visual-info-alist of it.#f is returned if no such
;; visual exists.

(define (match-visual-info display screen-number depth class)
  (let ((res (%match-visual-info (display-Xdisplay display)
				 screen-number
				 depth
				 (visual-class->integer class))))
    (if res
	(cons (make-visual (car res))
	      (visual-info-alist->integer+vector (cdr res)))
	res)))

(import-lambda-definition %match-visual-info (Xdisplay scrnum depth class)
  "scx_Match_Visual_Info")

;; *******************************************************************

(define-enumerated-type visual-class :visual-class
  visual-class? visual-classs visual-class-name visual-class-index
  (static-gray gray-scale static-color pseudo-color true-color direct-color))

(define (integer->visual-class int)
  (vector-ref visual-classs int))

(define (visual-class->integer v)
  (visual-class-index v))

;; A visual information is an alist with keys of the type
;; visual-info. The corresponding values have the following meaning:
;; screen-number  the screen this visual belongs to
;; depth          the depth of the screen
;; class          one of 'direct-color 'gray-scale 'pseudo-color 
;;                'static-color 'static-gray 'true-color
;; red-mask       these masks are used for direct-color and true-color
;; green-mask     to specify which bits of the pixel value specify
;; blue-mask      red, green or blue values.
;; colormap-size  tells how many different pixel value are valid
;; bits-per-rgb   specifies how many bits in each of the red, green 
;;                and blue values in a colorcell are used to drive 
;;                the rgb gun in the screen.
;; visual         this value can be passed to other functions, e.g. 
;;                create-window.
;; visual-id      this value is not normally needed by applications.

(define-enumerated-type visual-info :visual-info
  visual-info? visual-infos visual-info-name visual-info-index
  (visual-id screen depth class red-mask green-mask blue-mask 
   colormap-size bits-per-rgp))

(define visual-info-alist->integer+vector
  (make-enum-alist->integer+vector
   visual-infos visual-info-index
   (lambda (v)
     (cond
      ((eq? v (visual-info class))
       visual-class->integer)
      (else (lambda (x) x))))))

(define integer+vector->visual-info-alist
  (make-integer+vector->enum-alist
   visual-infos visual-info-index
   (lambda (v)
     (cond
      ((eq? v (visual-info class))
       integer->visual-class)
      (else (lambda (x) x))))))