scx/scheme/xlib/gcontext.scm

;; 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->integer+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")

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

(define-enumerated-type gc-function :gc-function
  gc-function? gc-functions gc-function-name gc-function-index
  (clear and and-reverse copy and-inverted no-op xor or nor equiv
   invert or-reverse copy-inverted or-inverted nand set))

(define (integer->gc-function int)
  (vector-ref gc-functions int))

(define (gc-function->integer v)
  (gc-function-index v))

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

(define-enumerated-type line-style :line-style
  line-style? line-styles line-style-name line-style-index
  (solid on-off-dash double-dash))

(define (integer->line-style int)
  (vector-ref line-styles int))

(define (line-style->integer v)
  (line-style-index v))

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

(define-enumerated-type cap-style :cap-style
  cap-style? cap-styles cap-style-name cap-style-index
  (not-last butt round projecting))

(define (integer->cap-style int)
  (vector-ref cap-styles int))

(define (cap-style->integer v)
  (cap-style-index v))

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

(define-enumerated-type join-style :join-style
  join-style? join-styles join-style-name join-style-index
  (miter round bevel))

(define (integer->join-style int)
  (vector-ref join-styles int))

(define (join-style->integer v)
  (join-style-index v))

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

(define-enumerated-type fill-style :fill-style
  fill-style? fill-styles fill-style-name fill-style-index
  (solid tiled strippled opaque-strippled))

(define (integer->fill-style int)
  (vector-ref fill-styles int))

(define (fill-style->integer v)
  (fill-style-index v))

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

(define-enumerated-type subwindow-mode :subwindow-mode
  subwindow-mode? subwindow-modes subwindow-mode-name subwindow-mode-index
  (clip-by-children include-inferiors))

(define (integer->subwindow-mode int)
  (vector-ref subwindow-modes int))

(define (subwindow-mode->integer v)
  (subwindow-mode-index v))

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

(define-enumerated-type arc-mode :arc-mode
  arc-mode? arc-modes arc-mode-name arc-mode-index
  (chord pie-slice))

(define (integer->arc-mode int)
  (vector-ref arc-modes int))

(define (arc-mode->integer v)
  (arc-mode-index v))

;; *******************************************************************
;; 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-syntax make-gc-value-alist
  (syntax-rules 
   ()
   ((make-gc-value-alist (attr arg) rest ...)
    (cons (cons (gc-value attr) arg)
	  (make-gc-value-alist rest ...)))
   ((make-gc-value-alist)
    '())))

(define-enum-set-type gc-value-set :gc-value-set
  gc-value-set? make-gc-value-set
  gc-value gc-value? gc-values gc-value-index)

(define integer->gc-value-set
  (make-integer->enum-set gc-values gc-value-index make-gc-value-set))

(define gc-value-set->integer
  (make-enum-set->integer gc-value-index))

(define gc-value-alist->integer+vector
  (make-enum-alist->integer+vector
   gc-values
   gc-value-index
   (lambda (attr)
     (cond
      ((eq? attr (gc-value function))
       gc-function->integer)
      ((or (eq? attr (gc-value plane-mask))
	   (eq? attr (gc-value foreground))
	   (eq? attr (gc-value background)))
       pixel-Xpixel)
      ((eq? attr (gc-value line-width))
       (lambda (x) x))
      ((eq? attr (gc-value line-style))
       line-style->integer)
      ((eq? attr (gc-value cap-style))
       cap-style->integer)
      ((eq? attr (gc-value join-style))
       join-style->integer)
      ((eq? attr (gc-value fill-style))
       fill-style->integer)
      ((eq? attr (gc-value fill-rule))
       fill-rule->integer)
      ((or (eq? attr (gc-value tile))
	   (eq? attr (gc-value stipple))
	   (eq? attr (gc-value clip-mask)))
       pixmap-Xpixmap)
      ((or (eq? attr (gc-value ts-x-origin))
	   (eq? attr (gc-value ts-y-origin)))
       (lambda (x) x))
      ((eq? attr (gc-value font))
       font-Xfont)
      ((eq? attr (gc-value subwindow-mode))
       subwindow-mode->integer)
      ((eq? attr (gc-value graphics-exposures))
       (lambda (x) x))
      ((or (eq? attr (gc-value clip-x-origin))
	   (eq? attr (gc-value clip-y-origin)))
       (lambda (x) x))
      ((or (eq? attr (gc-value dash-offset))
	   (eq? attr (gc-value dash-list)))
       (lambda (x) x))
      ((eq? attr (gc-value arc-mode))
       arc-mode->integer)))))

(define (integer+vector->gc-value-alist display)
  (make-integer+vector->enum-alist
   gc-values gc-value-index
   (lambda (v)
     (cond
      ((eq? v (gc-value function))
       integer->gc-function)
      ((or (eq? v (gc-value plane-mask))
	   (eq? v (gc-value foreground))
	   (eq? v (gc-value background)))
       (lambda (Xpixel)
	 (make-pixel Xpixel #f #f)))
      ((eq? v (gc-value line-width))
       (lambda (x) x))
      ((eq? v (gc-value line-style))
       integer->line-style)
      ((eq? v (gc-value cap-style))
       integer->cap-style)
      ((eq? v (gc-value join-style))
       integer->join-style)
      ((eq? v (gc-value fill-style))
       integer->fill-style)
      ((eq? v (gc-value fill-rule))
       integer->fill-rule)
      ((or (eq? v (gc-value tile))
	   (eq? v (gc-value stipple))
	   (eq? v (gc-value clip-mask)))
       (lambda (Xpixmap)
	 (make-pixmap Xpixmap display #f)))
      ((or (eq? v (gc-value ts-x-origin))
	   (eq? v (gc-value ts-y-origin))
	   (eq? v (gc-value clip-x-origin))
	   (eq? v (gc-value clip-y-origin)))
       (lambda (x) x))
      ((eq? v (gc-value font))
       (lambda (Xfont)
	 ;; -> see Xlib Programming Manual 5.12
	 (make-font #f Xfont #f display #f)))
      ((eq? v (gc-value subwindow-mode))
       integer->subwindow-mode)
      ((eq? v (gc-value graphics-exposures))
       (lambda (x) x))
      ((or (eq? v (gc-value dash-offset))
	   (eq? v (gc-value dash-list)))
       (lambda (x) x))
      ((eq? v (gc-value arc-mode))
       integer->arc-mode)))))

;; 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 enum-set of gc-value. It can be
;; created with the function make-gc-value-set or the macro
;; gc-value-set. if no gc-value-set 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)
		       -1
		       (gc-value-set->integer (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)
	  ((integer+vector->gc-value-alist display) vals)))))

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

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

(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->integer+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. possible values for ordering are
;; defined below. If none is specified (rectangle-ordering unsorted)
;; is used. See XSetClipRectangles.

(define-enumerated-type rectangle-ordering :rectangle-ordering
  rectangle-ordering? rectangle-orderings
  rectangle-ordering-name rectangle-ordering-index
  (unsorted y-sorted xy-sorted xy-banded))

(define (rectangle-ordering->integer v)
  (rectangle-ordering-index v))

(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)
   (rectangle-ordering->integer (if (null? ordering)
				    (rectangle-ordering unsorted)
				    (car 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) ;; not exported
  (%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 0))

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

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