Update of /cvsroot/scsh/scx/scheme/xlib
In directory usw-pr-cvs1:/tmp/cvs-serv3515/scheme/xlib
Modified Files:
colormap.scm display.scm window.scm xlib-interfaces.scm
xlib-packages.scm xlib-type-package.scm
Added Files:
visual-type.scm visual.scm
Log Message:
+ Added support for visuals.
+ Implemented some missing routines for color control:
create-colormap, alloc-color-cells, set-color-cell.
--- NEW FILE ---
(define-record-type visual :visual
(really-make-visual tag Xvisual)
visual?
(tag visual-tag visual-set-tag!)
(Xvisual visual-Xvisual visual-set-Xvisual!))
(define (make-visual Xvisual)
(let ((maybe-visual (visual-list-find Xvisual)))
(if maybe-visual
maybe-visual
(let ((visual (really-make-visual #f Xvisual)))
(add-finalizer! visual visual-list-delete!)
(visual-list-set! Xvisual visual)
visual))))
;; All visual records need to be saved in a weak-list, to have only one
;; record for the same XLib visual
(define *weak-visual-list* (make-integer-table))
(define (visual-list-find Xvisual)
(let ((r (table-ref *weak-visual-list* Xvisual)))
(if r
(weak-pointer-ref r)
r)))
(define (visual-list-set! Xvisual visual)
(let ((p (make-weak-pointer visual)))
(table-set! *weak-visual-list* Xvisual p)))
(define (visual-list-delete! visual)
(table-set! *weak-visual-list*
(visual-Xvisual visual) #f))
--- NEW FILE ---
;; 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")
Index: colormap.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/colormap.scm,v
retrieving revision 1.7
retrieving revision 1.8
diff -C2 -r1.7 -r1.8
*** colormap.scm 2001/08/29 14:43:49 1.7
--- colormap.scm 2001/09/20 14:41:01 1.8
***************
*** 47,49 ****
(import-lambda-definition %parse-color (Xdisplay Xcolormap string)
! "scx_Parse_Color")
\ No newline at end of file
--- 47,106 ----
(import-lambda-definition %parse-color (Xdisplay Xcolormap string)
! "scx_Parse_Color")
!
! ;; The create-colormap function creates a colormap of the specified
! ;; visual type for the screen on which the specified window resides.
! ;; alloc can be 'none or 'all. See XCreateColormap.
!
! (define (create-colormap window visual alloc)
! (let ((Xcolormap (%create-colormap (display-Xdisplay (window-display
window))
! (window-Xwindow window)
! (visual-Xvisual visual)
! (if (eq? alloc 'none)
! #f
! #t) ; 'all
! )))
! (make-colormap Xcolormap (window-display window) #t)))
!
! (import-lambda-definition %create-colormap (Xdisplay Xwindow Xvisual alloc)
! "scx_Create_Colormap")
!
! ;; The alloc-color-cells function allocates read/write color cells.
! ;; The number of colors must be positive and the number of planes
! ;; nonnegative, or a BadValue error results. See XAllocColorCells.
! ;; The return value is a pair who's car is the list of the planes
! ;; (integers), and who's cdr is a list of the pixels.
!
! (define (alloc-color-cells colormap contigous nplanes npixels)
! (let ((res (%alloc-color-cells (display-Xdisplay (colormap-display
colormap))
! (colormap-Xcolormap colormap)
! contigous
! nplanes npixels)))
! (if res
! (cons (vector->list (car res))
! (map make-pixel
! (vector->list (cdr res))))
! res)))
!
! (import-lambda-definition %alloc-color-cells (Xdisplay Xcolormap contig
! nplanes npixels)
! "scx_Alloc_Color_Cells")
!
! ;; The set-color-cell function uses XStoreColor(s) to set the content
! ;; of the color cell specified by pixel (a pixel is an index to a
! ;; colormap) to color. An optional parameter is a list of the symbols
! ;; 'do-red 'do-gree and 'do-blue, that specify which components of the
! ;; color should be used. It defaults to '(do-red do-green
! ;; do-blue). See XStoreColors.
!
! (define (set-color-cell colormap pixel color . flags)
! (%set-color-cell (display-Xdisplay (colormap-display colormap))
! (colormap-Xcolormap colormap)
! (pixel-Xpixel pixel) (color-Xcolor color)
! (if (null? flags)
! '(do-red do-green do-blue)
! (car flags))))
!
! (import-lambda-definition %set-color-cells (Xdisplay Xcolormap Xpixel Xcolor
! flags)
! "scx_Set_Color_Cell")
Index: display.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/display.scm,v
retrieving revision 1.7
retrieving revision 1.8
diff -C2 -r1.7 -r1.8
*** display.scm 2001/07/31 14:54:53 1.7
--- display.scm 2001/09/20 14:41:01 1.8
***************
*** 84,87 ****
--- 84,103 ----
"scx_Display_Default_Screen_Number")
+ ;; display-default-visual returns the default visual of the given
+ ;; display. If no screen-number is specified the default screen is
+ ;; used. See DisplayVisual.
+
+ (define (display-default-visual display . screen-number)
+ (make-visual
+ (%default-visual (display-Xdisplay display)
+ (if (null? screen-number)
+ (display-default-screen-number display)
+ (begin
+ (check-screen-number display (car screen-number))
+ (car screen-number))))))
+
+ (import-lambda-definition %default-visual (Xdisplay scr-num)
+ "scx_Display_Default_Visual")
+
;; internal function
(define (check-screen-number display screen-number)
Index: window.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/window.scm,v
retrieving revision 1.10
retrieving revision 1.11
diff -C2 -r1.10 -r1.11
*** window.scm 2001/08/29 14:47:03 1.10
--- window.scm 2001/09/20 14:41:01 1.11
***************
*** 9,14 ****
(define (create-window parent width height . args)
(let ((alist (named-args->alist args)))
! (receive (x y border-width change-win-attr-list)
! (alist-split alist '((x . 0) (y . 0) (border-width . 2)))
(let* ((change-win-attr-list
(map cons
--- 9,15 ----
(define (create-window parent width height . args)
(let ((alist (named-args->alist args)))
! (receive (x y border-width visual change-win-attr-list)
! (alist-split alist '((x . 0) (y . 0) (border-width . 2)
! (visual . #f)))
(let* ((change-win-attr-list
(map cons
***************
*** 26,29 ****
--- 27,33 ----
(window-Xwindow parent)
x y width height border-width
+ (if visual
+ (visual-Xvisual visual)
+ #f)
change-win-attr-list)))
(if (= Xwindow 0)
***************
*** 32,36 ****
(import-lambda-definition %create-window (Xdisplay Xparent x y width height
! border-width attrAlist)
"scx_Create_Window")
--- 36,40 ----
(import-lambda-definition %create-window (Xdisplay Xparent x y width height
! border-width visual
attrAlist)
"scx_Create_Window")
***************
*** 106,110 ****
(window-display window)
#f)))
! ;; font, visual ??
v))
(alist (map cons
--- 110,114 ----
(window-display window)
#f)))
! (comp 6 make-visual) ;; visual
v))
(alist (map cons
Index: xlib-interfaces.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/xlib-interfaces.scm,v
retrieving revision 1.7
retrieving revision 1.8
diff -C2 -r1.7 -r1.8
*** xlib-interfaces.scm 2001/08/29 14:49:31 1.7
--- xlib-interfaces.scm 2001/09/20 14:41:01 1.8
***************
*** 15,18 ****
--- 15,19 ----
display-default-depth
display-default-screen-number
+ display-default-visual
display-cells
display-planes
***************
*** 139,145 ****
free-colormap
colormap-display
! alloc-color
alloc-named-color
parse-color
))
--- 140,149 ----
free-colormap
colormap-display
! alloc-color!
alloc-named-color
parse-color
+ alloc-color-cells
+ set-color-cell
+ create-colormap
))
***************
*** 430,433 ****
--- 434,444 ----
;; syntax: with-server-grabbed
))
+
+ (define-interface xlib-visual-interface
+ (export visual?
+ get-visual-info
+ visual-id
+ match-visual-info
+ ))
;; all together
***************
*** 455,457 ****
--- 466,469 ----
xlib-utility-interface
xlib-grab-interface
+ xlib-visual-interface
))
Index: xlib-packages.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/xlib-packages.scm,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -r1.4 -r1.5
*** xlib-packages.scm 2001/08/29 14:49:31 1.4
--- xlib-packages.scm 2001/09/20 14:41:01 1.5
***************
*** 151,154 ****
--- 151,160 ----
(files grab))
+ (define-structure xlib-visual xlib-visual-interface
+ (open scheme
+ external-calls
+ xlib-types)
+ (files visual))
+
;; all together
***************
*** 175,178 ****
--- 181,185 ----
xlib-utility
xlib-grab
+ xlib-visual
)
(optimize auto-integrate))
Index: xlib-type-package.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/xlib-type-package.scm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -r1.2 -r1.3
*** xlib-type-package.scm 2001/08/21 15:15:34 1.2
--- xlib-type-package.scm 2001/09/20 14:41:01 1.3
***************
*** 29,31 ****
font-type
atom-type
! cursor-type))
\ No newline at end of file
--- 29,32 ----
font-type
atom-type
! cursor-type
! visual-type))
\ No newline at end of file
|