247 lines
10 KiB
Scheme
247 lines
10 KiB
Scheme
;; create-gcontext returns a newly create graphic context for the
|
|
;; specified drawable (a window or a pixmap). Optional arguments are
|
|
;; all attributes that can be set by the set-gcontext-xyz! functions
|
|
;; below. They can be specified by name: 'function 'xor. Or the last
|
|
;; argument can be an alist of such mappings. See XCreateGC.
|
|
|
|
(define (create-gcontext drawable . args)
|
|
(let ((alist (named-args->alist args)))
|
|
(let* ((rest (map cons
|
|
(map car alist)
|
|
(map (lambda (obj)
|
|
(cond
|
|
((pixel? obj) (pixel-Xpixel obj))
|
|
((font? obj) (font-Xfont obj))
|
|
((pixmap? obj) (pixmap-Xpixmap obj))
|
|
(else obj)))
|
|
(map cdr alist))))
|
|
(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")
|
|
|
|
;; 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 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 the names in the
|
|
;; set-gcontext-*! functions. If that argument is not specified, then
|
|
;; all atributes are copied. See XCopyGC.
|
|
|
|
(define (copy-gcontext! gc-from gc-to . attributes)
|
|
(let ((attributes (if (null? attributes)
|
|
'all
|
|
(car attributes))))
|
|
(%copy-gcontext! (display-Xdisplay (gcontext-display gc-from))
|
|
(gcontext-Xgcontext gc-from)
|
|
(gcontext-Xgcontext gc-to)
|
|
attributes)))
|
|
|
|
(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 gcontext-xyz functions
|
|
;; below. 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)
|
|
(let*
|
|
((pack (lambda (i fun)
|
|
(vector-set! vals i (fun (vector-ref vals i)))))
|
|
(make-pixmap* (lambda (Xpixmap)
|
|
(make-pixmap Xpixmap display #f)))
|
|
(make-font* (lambda (Xfont)
|
|
; this might not work properly, see Xlib Programming
|
|
; Manual chapter 5.12
|
|
(make-font #f Xfont #f display #t)))
|
|
(make-pixel* (lambda (Xpixel)
|
|
(make-pixel Xpixel #f #f)))
|
|
(mod-vals (begin
|
|
(pack 1 make-pixel*) ;; plane-mask
|
|
(pack 2 make-pixel*) ;; foreground
|
|
(pack 3 make-pixel*) ;; background
|
|
(pack 11 make-pixmap*) ;; tile
|
|
(pack 12 make-pixmap*) ;; stipple
|
|
(pack 15 make-font*) ;; font
|
|
(pack 20 make-pixmap*) ;; clip-mask
|
|
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))
|
|
|
|
;; 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 . 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
|
|
(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))
|