scx/scheme/xlib/gcontext.scm

;; ...

(define (create-gcontext . args)
  (let ((alist (named-args->alist args)))
    (receive (drawable rest) (alist-split alist '((drawable . #f)))
      (let* ((rest (map cons
			(map car rest)
			(map (lambda (obj)
			       (cond
				((pixel? obj) (pixel-Xpixel obj))
				((font? obj) (font-Xfont obj))
				((pixmap? obj) (pixmap-Xpixmap obj))
				(else obj)))
			     (map cdr rest))))
	     (display (drawable-display drawable))
	     (Xdisplay (display-Xdisplay display))
	     (Xobject (drawable-Xobject drawable)))
	(let ((Xgcontext (%create-gcontext Xdisplay Xobject rest)))
	  (make-gcontext Xgcontext display #t))))))

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

;; ...

(define (copy-gcontext gcontext drawable)
  (let* ((new-gcontext (create-gcontext 'drawable 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")

;; ...

(define (get-gcontext-values gcontext)
  (let ((Xgcontext (gcontext-Xgcontext gcontext))
	(Xdisplay (display-Xdisplay (gcontext-display gcontext))))
    (let ((vals (%get-gcontext-values Xgcontext Xdisplay)))
      (if (not vals)
	  (error "cannot get gcontext values." gcontext)
	  (let*
	      ((mod-vals (begin
			   (vector-set! vals 1 ;; plane-mask
					(make-pixel (vector-ref vals 1)))
			   (vector-set! vals 2 ;; foreground
					(make-pixel (vector-ref vals 2)))
			   (vector-set! vals 3 ;; background
					(make-pixel (vector-ref vals 3)))
			   ;; TODO: tile, stipple, font ...??
			   vals))
	       (alist 
		(map cons
		     '(function plane-mask foreground background 
		       line-width line-style cap-style join-style 
		       fill-style fill-rule arc-mode tile stipple ts-x ts-y 
		       font subwindow-mode exposures clip-x clip-y 
		       clip-mask dash-offset dashes)
		     (vector->list mod-vals))))
	  alist)))))

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

;;...

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

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

;; ...

(define (change-gcontext gcontext . attrs)
  (let* ((alist (named-args->alist attrs))
	 (prep-alist 
	  (map cons
	       (map car alist)
	       (map (lambda (value)
		      (cond
		       ((pixmap? value) (pixmap-Xpixmap value))
		       ((font? value) (font-Xfont value)) ;;??
		       ((pixel? value) (pixel-Xpixel value))
		       ;; ??...
		       (else value)))
		    (map cdr alist)))))
    (%change-gcontext (gcontext-Xgcontext gcontext)
		      (display-Xdisplay (gcontext-display gcontext))
		      prep-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 'function))
(define set-gcontext-plane-mask! (make-gcontext-setter 'plane-mask))
(define set-gcontext-foreground! (make-gcontext-setter 'foreground))
(define set-gcontext-background! (make-gcontext-setter 'background))
(define set-gcontext-line-width! (make-gcontext-setter 'line-width))
(define set-gcontext-line-style! (make-gcontext-setter 'line-style))
(define set-gcontext-cap-style! (make-gcontext-setter 'cap-style))
(define set-gcontext-join-style! (make-gcontext-setter 'join-style))
(define set-gcontext-fill-style! (make-gcontext-setter 'fill-style))
(define set-gcontext-fill-rule! (make-gcontext-setter 'fill-rule))
(define set-gcontext-arc-mode! (make-gcontext-setter 'arc-mode))
(define set-gcontext-tile! (make-gcontext-setter 'tile))
(define set-gcontext-stipple! (make-gcontext-setter 'stipple))
(define set-gcontext-ts-x! (make-gcontext-setter 'ts-x))
(define set-gcontext-ts-y! (make-gcontext-setter 'ts-y))
(define set-gcontext-font! (make-gcontext-setter 'font))
(define set-gcontext-subwindow-mode! (make-gcontext-setter 'subwindow-mode))
(define set-gcontext-exposures! (make-gcontext-setter 'exposures))
(define set-gcontext-clip-x! (make-gcontext-setter 'clip-x))
(define set-gcontext-clip-y! (make-gcontext-setter 'clip-y))
(define set-gcontext-clip-mask! (make-gcontext-setter 'clip-mask))
(define set-gcontext-dash-offset! (make-gcontext-setter 'dash-offset))
(define set-gcontext-dashes! (make-gcontext-setter 'dashes))

;; 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
		 dash-list))

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

;; ...

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

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

;; ...

(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))