442 lines
16 KiB
Scheme
442 lines
16 KiB
Scheme
;; 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 #t)))
|
|
((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)
|
|
(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->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))
|