scx/scheme/xlib/gcontext.scm

;; an enumerated type corresponding to XGCValues.

(define-enumerated-type gc-value :gc-value
  gc-value?
  gc-values
  gc-value-name
  gc-value-index
  (function plane-mask foreground background line-width line-style cap-style
   join-style fill-style fill-rule tile stipple ts-x-origin ts-y-origin
   font subwindow-mode graphics-exposures clip-x-origin clip-y-origin
   clip-mask dash-offset dash-list arc-mode))

(define gc-value-alist->vector
  (make-enum-alist->vector 
   gc-values gc-value-index
   (lambda (i)
     (case i
       ((1 2 3) pixel-Xpixel)
       ((10 11 19) pixmap-Xpixmap)
       ((14) font-Xfont)
       ((16) (lambda (x) (if x 1 0)))
       (else (lambda (x) x))))))

;; create-gcontext returns a newly create graphic context for the
;; specified drawable (a window or a pixmap). The gc-value-alist has
;; to be an alist mapping a gc-value (defined above) to a
;; corresponding value. See XCreateGC.

(define (create-gcontext drawable gc-value-alist)
  (let ((display (drawable-display drawable))
	(Xobject (drawable-Xobject drawable))
	(values (gc-value-alist->vector gc-value-alist)))
    (let ((Xgcontext (%create-gcontext (display-Xdisplay display)
				       Xobject
				       values)))
      (make-gcontext Xgcontext display #t))))

(import-lambda-definition %create-gcontext (Xdisplay Xdrawable values)
  "scx_Create_Gc")

;; copy-gcontext returns a newly create duplicate of the given
;; gcontext, and assigns it to the specified drawable. See XCopyGC.

(define (copy-gcontext gcontext drawable)
  (let* ((new-gcontext (create-gcontext drawable '()))
	 (new-Xgcontext (gcontext-Xgcontext new-gcontext))
	 (Xgcontext (gcontext-Xgcontext gcontext))
	 (Xdisplay (display-Xdisplay (gcontext-display gcontext))))
    (%copy-gcontext Xdisplay Xgcontext new-Xgcontext)
    new-gcontext))

(import-lambda-definition %copy-gcontext (Xdisplay Xsource Xdest)
  "scx_Copy_Gc")

;; copy-gcontext! copies the specified attributes from gc-from to
;; gc-to. The attributes have to be a list of gc-values as defined
;; above. if no gc-values list is specified, then all attributes are
;; copied. See XCopyGC.

(define (copy-gcontext! gc-from gc-to . maybe-gc-values)
  (let ((gc-values (if (null? maybe-gc-values)
		       'all
		       (map gc-value-name (car maybe-gc-values)))))
    (%copy-gcontext! (display-Xdisplay (gcontext-display gc-from))
		     (gcontext-Xgcontext gc-from)
		     (gcontext-Xgcontext gc-to)
		     gc-values)))

(import-lambda-definition %copy-gcontext! (Xdisplay Xfrom Xto attrs)
  "scx_Copy_Gc_To_Gc")

;; get-gontext-values returns an alist of all attributes for the
;; specified graphic context. See the gc-value and create-gcontext
;; above. See XGetGCValues.

(define (get-gcontext-values gcontext)
  (let* ((Xgcontext (gcontext-Xgcontext gcontext))
	 (display (gcontext-display gcontext))
	 (Xdisplay (display-Xdisplay display)))
    (let ((vals (%get-gcontext-values Xgcontext Xdisplay)))
      (if (not vals)
	  (error "cannot get gcontext values." gcontext)
	  (vector->gc-value-alist vals display)))))

(import-lambda-definition %get-gcontext-values (Xgcontext Xdisplay)
  "scx_Get_Gc_Values")

(define vector->gc-value-alist
  (make-vector->enum-alist
   gc-values
   (lambda (i display)
     (case i
       ((1 2 3) (lambda (Xpixel)
		  (make-pixel Xpixel #f #f)))
       ((11 12 20) (lambda (Xpixmap)
		     (make-pixmap Xpixmap display #f)))
       ((14) (lambda (Xfont)
	       ;; -> see Xlib Programming Manual 5.12
	       (make-font #f Xfont #f display #t)))
       (else (lambda (x) x))))))

(define (make-gcontext-getter name)
  (lambda (gcontext)
    (cdr (assq name (get-gcontext-values gcontext)))))

(define gcontext-function (make-gcontext-getter (gc-value function)))
(define gcontext-plane-mask (make-gcontext-getter (gc-value plane-mask)))
(define gcontext-foreground (make-gcontext-getter (gc-value foreground)))
(define gcontext-background (make-gcontext-getter (gc-value background)))
(define gcontext-line-width (make-gcontext-getter (gc-value line-width)))
(define gcontext-line-style (make-gcontext-getter (gc-value line-style)))
(define gcontext-cap-style (make-gcontext-getter (gc-value cap-style)))
(define gcontext-join-style (make-gcontext-getter (gc-value join-style)))
(define gcontext-fill-style (make-gcontext-getter (gc-value fill-style)))
(define gcontext-fill-rule (make-gcontext-getter (gc-value fill-rule)))
(define gcontext-arc-mode (make-gcontext-getter (gc-value arc-mode)))
(define gcontext-tile (make-gcontext-getter (gc-value tile)))
(define gcontext-stipple (make-gcontext-getter (gc-value stipple)))
(define gcontext-ts-x-origin (make-gcontext-getter (gc-value ts-x-origin)))
(define gcontext-ts-y-origin (make-gcontext-getter (gc-value ts-y-origin)))
;(define gcontext-font (make-gcontext-getter (gc-value font)))
(define gcontext-subwindow-mode 
  (make-gcontext-getter (gc-value subwindow-mode)))
(define gcontext-graphics-exposures 
  (make-gcontext-getter (gc-value graphics-exposures)))
(define gcontext-clip-x-origin (make-gcontext-getter (gc-value clip-x-origin)))
(define gcontext-clip-y-origin (make-gcontext-getter (gc-value clip-y-origin)))
(define gcontext-clip-mask (make-gcontext-getter (gc-value clip-mask)))
(define gcontext-dash-offset (make-gcontext-getter (gc-value dash-offset)))
(define gcontext-dash-list (make-gcontext-getter (gc-value dash-list)))

;; Alternative definition of gcontext-font. See XGcontextFromGC
;
(define (gcontext-font gcontext)
  (let* ((display (gcontext-display gcontext))
	 (Xfontstruct (%gcontext-font 
		       (display-Xdisplay display)
		       (gcontext-Xgcontext gcontext))))
    (make-font #f #f Xfontstruct display #f)))

(import-lambda-definition %gcontext-font (Xdisplay Xgcontext)
  "scx_GContext_Font") ; defined in font.c

;; change-gcontext sets some attributes of the specified graphic
;; context. The format of the arguments is like for
;; create-gcontext. See XChangeGC.

(define (change-gcontext gcontext gc-value-alist)
  (%change-gcontext (gcontext-Xgcontext gcontext)
		    (display-Xdisplay (gcontext-display gcontext))
		    (gc-value-alist->vector gc-value-alist)))

(import-lambda-definition %change-gcontext (Xgcontext Xdisplay args)
  "scx_Change_Gc")

(define (make-gcontext-setter name)
  (lambda (gcontext value)
    (change-gcontext gcontext (list (cons name value)))))

(define set-gcontext-function! 
  (make-gcontext-setter (gc-value function)))
(define set-gcontext-plane-mask! 
  (make-gcontext-setter (gc-value plane-mask)))
(define set-gcontext-foreground! 
  (make-gcontext-setter (gc-value foreground)))
(define set-gcontext-background! 
  (make-gcontext-setter (gc-value background)))
(define set-gcontext-line-width! 
  (make-gcontext-setter (gc-value line-width)))
(define set-gcontext-line-style! 
  (make-gcontext-setter (gc-value line-style)))
(define set-gcontext-cap-style! 
  (make-gcontext-setter (gc-value cap-style)))
(define set-gcontext-join-style! 
  (make-gcontext-setter (gc-value join-style)))
(define set-gcontext-fill-style! 
  (make-gcontext-setter (gc-value fill-style)))
(define set-gcontext-fill-rule! 
  (make-gcontext-setter (gc-value fill-rule)))
(define set-gcontext-arc-mode! (make-gcontext-setter (gc-value arc-mode)))
(define set-gcontext-tile! (make-gcontext-setter (gc-value tile)))
(define set-gcontext-stipple! (make-gcontext-setter (gc-value stipple)))
(define set-gcontext-ts-x-origin! 
  (make-gcontext-setter (gc-value ts-x-origin)))
(define set-gcontext-ts-y-origin! 
  (make-gcontext-setter (gc-value ts-y-origin)))
(define set-gcontext-font! (make-gcontext-setter (gc-value font)))
(define set-gcontext-subwindow-mode! 
  (make-gcontext-setter (gc-value subwindow-mode)))
(define set-gcontext-graphics-exposures! 
  (make-gcontext-setter (gc-value graphics-exposures)))
(define set-gcontext-clip-x-origin! 
  (make-gcontext-setter (gc-value clip-x-origin)))
(define set-gcontext-clip-y-origin! 
  (make-gcontext-setter (gc-value clip-y-origin)))
(define set-gcontext-clip-mask! 
  (make-gcontext-setter (gc-value clip-mask)))
(define set-gcontext-dash-offset! 
  (make-gcontext-setter (gc-value dash-offset)))
(define set-gcontext-dash-list! 
  (make-gcontext-setter (gc-value dash-list)))

;; set-dashlist! is a more complex form of set-dashes!. (set-dashes! N) is 
;; equivalent to (set-dash-list! .. #(N N))

(define (set-gcontext-dashlist! gcontext dash-offset dash-list)
  (%set-dashlist (gcontext-Xgcontext gcontext)
		 (display-Xdisplay (gcontext-display gcontext))
		 dash-offset
		 (list->vector dash-list)))

(import-lambda-definition %set-dashlist (Xgcontext Xdisplay dashoffset dashlist)
  "scx_Set_Gcontext_Dashlist")

;; set-gcontext-clip-rectangles changes the clip-mask in the specified
;; graphic context to the list of rectangles and sets the clip
;; origin. Each rectangle has to be a list (x y height width). The
;; coordinates of the rectangles are interpreted relative to the clip
;; origin specified by x and y. ordering can be one of 'unsorted,
;; 'y-sorted, 'xy-sorted or 'xy-banded. See XSetClipRectangles.

(define (set-gcontext-clip-rectangles! gcontext x y rectangles ordering)
  (%set-gcontext-clip-rectangles! (gcontext-Xgcontext gcontext)
				  (display-Xdisplay (gcontext-display gcontext))
				  x y 
				  (list->vector rectangles)
				  ordering))

(import-lambda-definition %set-gcontext-clip-rectangles! (Xgcontext Xdisplay x 
							  y v ord)
  "scx_Set_Gcontext_Clip_Rectangles")

;; query-best-size/-cursor/-tile/-stipple function returns the best or
;; closest size to the specified size. For 'cursor, this is the
;; largest size that can be fully displayed on the screen specified by
;; which_screen. For 'tile, this is the size that can be tiled
;; fastest. For 'stipple, this is the size that can be stippled
;; fastest. See XQueryBestSize.

(define (query-best-size display width height shape)
  (%query-best-size (display-Xdisplay display)
		    width height shape))

(import-lambda-definition %query-best-size (Xdisplay width height shape)
  "scx_Query_Best_Size")

(define (query-best-cursor display width height)
  (query-best-size display width height 'cursor))

(define (query-best-tile display width height)
  (query-best-size display width height 'tile))

(define (query-best-stipple display width height)
  (query-best-size display width height 'stipple))