From fefeb73ccf27f01d8a639531fd0d641473c0d493 Mon Sep 17 00:00:00 2001 From: frese Date: Tue, 9 Oct 2001 15:43:55 +0000 Subject: [PATCH] - completed get-gcontext-values and change/get-window-attributes to pack/unpack all values correctly. - added copy-gcontext! and copy-gcontext - added comments. --- c/xlib/gcontext.c | 11 +++++ scheme/xlib/gcontext.scm | 96 +++++++++++++++++++++++++++++++--------- scheme/xlib/window.scm | 5 ++- 3 files changed, 89 insertions(+), 23 deletions(-) diff --git a/c/xlib/gcontext.c b/c/xlib/gcontext.c index d6f0d74..95028c8 100644 --- a/c/xlib/gcontext.c +++ b/c/xlib/gcontext.c @@ -106,6 +106,16 @@ s48_value scx_Copy_Gc(s48_value Xdisplay, s48_value Xsource, s48_value Xdest) { return S48_UNSPECIFIC; } +s48_value scx_Copy_Gc_To_Gc(s48_value Xdisplay, s48_value Xfrom, s48_value Xto, + s48_value attrs) { + unsigned long mask = 0; + mask = S48_SYMBOL_P(attrs) ? Symbol_To_Bit(attrs, Gcontext_Values_Syms) : + Symbols_To_Bits(attrs, Gcontext_Values_Syms); + XCopyGC(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_GCONTEXT(Xfrom), + mask, SCX_EXTRACT_GCONTEXT(Xto)); + return S48_UNSPECIFIC; +} + s48_value scx_Free_Gc(s48_value Xgcontext, s48_value Xdisplay) { XFreeGC(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_GCONTEXT(Xgcontext)); return S48_UNSPECIFIC; @@ -241,6 +251,7 @@ void scx_init_gcontext(void) { S48_EXPORT_FUNCTION(scx_Create_Gc); S48_EXPORT_FUNCTION(scx_Free_Gc); S48_EXPORT_FUNCTION(scx_Copy_Gc); + S48_EXPORT_FUNCTION(scx_Copy_Gc_To_Gc); S48_EXPORT_FUNCTION(scx_Get_Gc_Values); S48_EXPORT_FUNCTION(scx_Change_Gc); S48_EXPORT_FUNCTION(scx_Set_Gcontext_Dashlist); diff --git a/scheme/xlib/gcontext.scm b/scheme/xlib/gcontext.scm index e01b6e6..9c357e0 100644 --- a/scheme/xlib/gcontext.scm +++ b/scheme/xlib/gcontext.scm @@ -1,4 +1,8 @@ -;; ... +;; 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))) @@ -20,7 +24,8 @@ (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)) @@ -33,23 +38,53 @@ (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)) - (Xdisplay (display-Xdisplay (gcontext-display 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* - ((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 ...?? + ((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 @@ -64,8 +99,6 @@ (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))))) @@ -94,7 +127,21 @@ (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)) @@ -157,7 +204,12 @@ (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) @@ -170,7 +222,12 @@ 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) @@ -187,6 +244,3 @@ (define (query-best-stipple display width height) (query-best-size display width height 'stipple)) - - - diff --git a/scheme/xlib/window.scm b/scheme/xlib/window.scm index 30a1d74..bc70d60 100644 --- a/scheme/xlib/window.scm +++ b/scheme/xlib/window.scm @@ -19,7 +19,7 @@ ((pixel? obj) (pixel-Xpixel obj)) ((pixmap? obj) (pixmap-Xpixmap obj)) ((colormap? obj) (colormap-Xcolormap obj)) - ;; cursor...?? + ((cursor? obj) (cursor-Xcursor obj)) (else obj))) (map cdr change-win-attr-list)))) (display (window-display parent)) @@ -101,7 +101,8 @@ (let* ((comp (lambda (i f) (vector-set! v i (f (vector-ref v i))))) (mod-v (begin - (comp 13 make-pixel) ;; backing-pixel + (comp 13 (lambda (Xpixel) ;; backing-pixel + (make-pixel Xpixel #f #f))) (comp 7 (lambda (Xwin) ;; root (make-window Xwin (window-display window) #f)))