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