76 lines
2.7 KiB
Scheme
76 lines
2.7 KiB
Scheme
|
;; A visual information is an alist with the following keys:
|
||
|
|
;; '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.
|
||
|
|
|
||
|
|
;; returns a list of visual informations that match the template given
|
||
|
|
;; by args. args can consist of the same fields as a visual
|
||
|
|
;; information (see above) except 'visual that may not be
|
||
|
|
;; specified. But usually only the fields 'screen 'depth and 'class
|
||
|
|
;; make sense. See create-window for the syntax of args.
|
||
|
|
|
||
|
|
(define (get-visual-info display . args)
|
||
|
|
(let* ((alist (named-args->alist args))
|
||
|
|
(vector (pack-visual-info alist)))
|
||
|
|
(let ((res (%get-visual-info (display-Xdisplay display)
|
||
|
|
vector)))
|
||
|
|
(map unpack-visual-info
|
||
|
|
(vector->list res)))))
|
||
|
|
|
||
|
|
(import-lambda-definition %get-visual-info (Xdisplay v)
|
||
|
|
"scx_Get_Visual_Info")
|
||
|
|
|
||
|
|
(define (pack-visual-info vi)
|
||
|
|
(let ((mapping (map cons
|
||
|
|
'(visual visual-id screen-number depth class
|
||
|
|
red-mask green-mask blue-mask colormap-size
|
||
|
|
bits-per-rgb)
|
||
|
|
'(0 1 2 3 4 5 6 7 8 9)))
|
||
|
|
(r (make-vector 10 #f)))
|
||
|
|
(for-each (lambda (p)
|
||
|
|
(vector-set! r (cdr (assq (car p) mapping))
|
||
|
|
(cdr p)))
|
||
|
|
vi)
|
||
|
|
r))
|
||
|
|
|
||
|
|
(define (unpack-visual-info v)
|
||
|
|
(vector-set! v 0 (make-visual (vector-ref v 0)))
|
||
|
|
(map cons
|
||
|
|
'(visual visual-id screen-number depth class red-mask green-mask
|
||
|
|
blue-mask colormap-size bits-per-rgb)
|
||
|
|
(vector->list v)))
|
||
|
|
|
||
|
|
;; 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 info on a matching visual or #f if none
|
||
|
|
;; exists.
|
||
|
|
|
||
|
|
(define (match-visual-info display screen-number depth class)
|
||
|
|
(let ((res (%match-visual-info (display-Xdisplay display)
|
||
|
|
screen-number
|
||
|
|
depth
|
||
|
|
class)))
|
||
|
|
(if res
|
||
|
|
(unpack-visual-info res)
|
||
|
|
res)))
|
||
|
|
|
||
|
|
(import-lambda-definition %match-visual-info (Xdisplay scrnum depth class)
|
||
|
|
"scx_Match_Visual_Info")
|