diff --git a/c/xlib/color.c b/c/xlib/color.c index bafd3f2..6976624 100644 --- a/c/xlib/color.c +++ b/c/xlib/color.c @@ -16,9 +16,9 @@ s48_value Int_Extract_RGB_Values(XColor col) { S48_DECLARE_GC_PROTECT(1); S48_GC_PROTECT_1(res); - res = s48_cons( s48_enter_integer(col.red), res ); - res = s48_cons( s48_enter_integer(col.green), res ); res = s48_cons( s48_enter_integer(col.blue), res ); + res = s48_cons( s48_enter_integer(col.green), res ); + res = s48_cons( s48_enter_integer(col.red), res ); S48_GC_UNPROTECT(); return res; diff --git a/c/xlib/type.c b/c/xlib/type.c index 25d861a..0db8cd1 100644 --- a/c/xlib/type.c +++ b/c/xlib/type.c @@ -24,7 +24,7 @@ s48_value s48_enter_symbol(char* name) { and the scheme symbols: */ -s48_value Bits_To_Symbols(unsigned long bits, int mask_flag, SYMDESCR* table) { +s48_value Bits_To_Symbols(unsigned long bits, SYMDESCR* table) { s48_value res = S48_NULL; char* name; int val; @@ -38,32 +38,29 @@ s48_value Bits_To_Symbols(unsigned long bits, int mask_flag, SYMDESCR* table) { val = table[i].val; if ((val & bits) != 0) { - if (mask_flag == 0) { - res = s48_enter_symbol(name); - break; - } else { - res = s48_cons(s48_enter_symbol(name), res); - } + res = s48_cons(s48_enter_symbol(name), res); } i++; } - if ((mask_flag == 0) && S48_NULL_P(res)) - res = s48_enter_integer(bits); // or an exception?? S48_GC_UNPROTECT(); return res; } -unsigned long Symbols_To_Bits(s48_value Syms, int mask_flag, SYMDESCR* table) { +s48_value Bit_To_Symbol(unsigned long bits, SYMDESCR* table) { + s48_value res = Bits_To_Symbols(bits, table); + if (S48_NULL_P(res)) + return s48_enter_integer(bits); + else + return S48_CAR(res); +}} + +unsigned long Symbols_To_Bits(s48_value Syms, SYMDESCR* table) { unsigned long res = 0; s48_value l; - if (mask_flag) { - for (l = Syms; !S48_NULL_P(l); l = S48_CDR(l)) { - res |= Symbol_To_Bit(S48_CAR(l), table); - } - } else { - res |= Symbol_To_Bit(l, table); + for (l = Syms; !S48_NULL_P(l); l = S48_CDR(l)) { + res |= Symbol_To_Bit(S48_CAR(l), table); } return res; diff --git a/c/xlib/window.c b/c/xlib/window.c index 59cb312..89b4588 100644 --- a/c/xlib/window.c +++ b/c/xlib/window.c @@ -28,13 +28,13 @@ unsigned long AList_To_XSetWindowAttributes(s48_value attrAlist, Xattrs->border_pixel = s48_extract_integer(value); mask |= CWBorderPixel; } else if (cname == "bit-gravity") { - Xattrs->bit_gravity = Symbols_To_Bits(value, 0, Bit_Grav_Syms); + Xattrs->bit_gravity = Symbol_To_Bit(value, Bit_Grav_Syms); mask |= CWBitGravity; } else if (cname == "gravity") { - Xattrs->win_gravity = Symbols_To_Bits(value, 0, Grav_Syms); + Xattrs->win_gravity = Symbol_To_Bit(value, Grav_Syms); mask |= CWWinGravity; } else if (cname == "backing-store") { - Xattrs->backing_store = Symbols_To_Bits(value, 0, Backing_Store_Syms); + Xattrs->backing_store = Symbol_To_Bit(value, Backing_Store_Syms); mask |= CWBackingStore; } else if (cname == "backing-planes") { Xattrs->backing_planes = s48_extract_integer(value); @@ -46,10 +46,10 @@ unsigned long AList_To_XSetWindowAttributes(s48_value attrAlist, Xattrs->save_under = !S48_FALSE_P(value); mask |= CWSaveUnder; } else if (cname == "event-mask") { - Xattrs->event_mask = Symbols_To_Bits(value, 1, Event_Syms); + Xattrs->event_mask = Symbols_To_Bits(value, Event_Syms); mask |= CWEventMask; } else if (cname == "do-not-propagate-mask") { - Xattrs->do_not_propagate_mask = Symbols_To_Bits(value, 1, Event_Syms); + Xattrs->do_not_propagate_mask = Symbols_To_Bits(value, Event_Syms); mask |= CWDontPropagate; } else if (cname == "override-redirect") { Xattrs->override_redirect = !S48_FALSE_P(value); @@ -142,24 +142,36 @@ s48_value Get_Window_Attributes(s48_value Xdisplay, s48_value Xwindow) { s48_value res = S48_NULL; S48_GC_PROTECT_1(res); - XGetWindowAttributes(dpy, win, &WA); + if (!XGetWindowAttributes(dpy, win, &WA)) + res = S48_FALSE; + else { - // ... usw. - res = s48_cons( s48_enter_integer(WA.backing_planes), res); - res = s48_cons( Bits_To_Symbols(WA.backing_store, 1, Backing_Store_Syms), - res); - res = s48_cons( Bits_To_Symbols(WA.win_gravity, 1, Grav_Syms), - res); - res = s48_cons( Bits_To_Symbols(WA.bit_gravity, 1, Bit_Grav_Syms), res); - res = s48_cons( Bits_To_Symbols(WA.class, 1, Class_Syms), res); - res = s48_cons( s48_enter_integer(WA.root), res); // a Window ! - res = s48_cons( s48_enter_integer((long)WA.visual), res); // a Visual* ! - res = s48_cons( s48_enter_integer(WA.depth), res); - res = s48_cons( s48_enter_integer(WA.border_width), res); - res = s48_cons( s48_enter_integer(WA.height), res); - res = s48_cons( s48_enter_integer(WA.width), res); - res = s48_cons( s48_enter_integer(WA.y), res); - res = s48_cons( s48_enter_integer(WA.x), res); + // WA.screen - ignored in Elk + res = s48_cons( WA.overide_redirect ? S48_TRUE : S48_FALSE, res); + res = s48_cons( ENTER_MASK( WA.do_not_propagate_mask ), res); + res = s48_cons( ENTER_MASK( WA.your_event_mask ), res); + res = s48_cons( ENTER_MASK( WA.all_event_mask ), res); + res = s48_cons( Bit_To_Symbol( WA.map_state, Map_State_Syms), res); + res = s48_cons( WA.map_installed ? S48_TRUE : S48_FALSE, res); + res = s48_cons( ENTER_COLORMAP( WA.colormap ), res); + res = s48_cons( WA.save_under ? S48_TRUE : s48_FALSE ); + res = s48_cons( ENTER_PIXEL(WA.backing_pixel), res); + res = s48_cons( s48_enter_integer(WA.backing_planes), res); + res = s48_cons( Bit_To_Symbol(WA.backing_store, Backing_Store_Syms), + res); + res = s48_cons( Bit_To_Symbol(WA.win_gravity, Grav_Syms), + res); + res = s48_cons( Bit_To_Symbol(WA.bit_gravity, Bit_Grav_Syms), res); + res = s48_cons( Bit_To_Symbol(WA.class, Class_Syms), res); + res = s48_cons( ENTER_WINDOW(WA.root), res); + res = s48_cons( ENTER_VISUAL(WA.visual), res); + res = s48_cons( s48_enter_integer(WA.depth), res); + res = s48_cons( s48_enter_integer(WA.border_width), res); + res = s48_cons( s48_enter_integer(WA.height), res); + res = s48_cons( s48_enter_integer(WA.width), res); + res = s48_cons( s48_enter_integer(WA.y), res); + res = s48_cons( s48_enter_integer(WA.x), res); + } S48_GC_UNPROTECT(); return res; diff --git a/scheme/xlib/display.scm b/scheme/xlib/display.scm index e7c2135..36873b9 100644 --- a/scheme/xlib/display.scm +++ b/scheme/xlib/display.scm @@ -23,7 +23,7 @@ (define (display-default-root-window display) (let* ((Xdisplay (display-Xdisplay display)) (Xwindow (%default-root-window Xdisplay))) - (make-window 0 Xwindow (make-display Xdisplay)))) + (make-window Xwindow (make-display Xdisplay)))) (define display-root-window display-default-root-window) diff --git a/scheme/xlib/drawable.scm b/scheme/xlib/drawable.scm new file mode 100644 index 0000000..1b907d0 --- /dev/null +++ b/scheme/xlib/drawable.scm @@ -0,0 +1,22 @@ +;(define (drawable-abstraction pixmap-fun window-fun) +; (lambda (drawable) +; (cond +; ((pixmap? drawable) (pixmap-fun drawable)) +; ((window? drawable) (window-fun drawable)) +; (else (error "expected a drawable object" drawable))))) + +;(define drawable-display (drawable-abstraction pixmap-display window-display)) +;(define drawable-Xobject (drawable-abstraction pixmap-Xpixmap window-Xwindow)) + +;; not so sure with pixmap-root, not found in Elk. +(define drawable-root (drawable-abstraction (lambda (pixm) + (display-default-root-window + (pixmap-display pixm))) + window-root)) +(define drawable-x (drawable-abstraction pixmap-x window-x)) +(define drawable-y (drawable-abstraction pixmap-y window-y)) +(define drawable-width (drawable-abstraction pixmap-width window-width)) +(define drawable-height (drawable-abstraction pixmap-height window-height)) +(define drawable-border-width (drawable-abstraction pixmap-border-width + window-border-width)) +(define drawable-depth (drawable-abstraction pixmap-depth window-depth)) diff --git a/scheme/xlib/gcontext.scm b/scheme/xlib/gcontext.scm new file mode 100644 index 0000000..0fd9c34 --- /dev/null +++ b/scheme/xlib/gcontext.scm @@ -0,0 +1,165 @@ +;; ... + +(define (create-gcontext . args) + (let ((alist (named-args->alist args))) + (receive (drawable rest) (alist-split '((drawable . #f))) + (let* ((rest (map cons + (map car rest) + (map (lambda (obj) + (cond + ((pixel? obj) (pixel-Xpixel obj)) + ((font? obj) (font-Xfont obj)) + ((pixmap? obj) (pixmap-Xpixmap obj)) + (else obj))) + (map cdr rest)))) + (display (drawable-display drawable)) + (Xdisplay (display-Xdisplay display)) + (Xobject (drawable-Xobject drawable))) + (let ((Xgcontext (%create-gcontext Xdisplay Xobject rest))) + (make-gcontext Xgcontext display)))))) + +(import-lambda-definition %create-gcontext (Xdisplay Xdrawable alist) + "Create_Gc") + +;; ... + +(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) + "Copy_Gc") + +;; ... + +(define (get-gcontext-values gcontext) + (let ((Xgcontext (gcontext-Xgcontext gcontext)) + (Xdisplay (display-Xdisplay (gcontext-display gcontext)))) + (let ((lst (%get-gcontext-values Xgcontext Xdisplay))) + (if (not lst) + (error "cannot get gcontext values." gcontext) + (let* + ((alist (map cons + '(function plane-mask foreground background + line-width line-style cap-style join-style + fill-style arc-mode tile stipple ts-x ts-y font + subwindow-mode exposures clip-x clip-y clip-mask + dash-offset dashes) + lst)) + (mod-alist (map (lambda (name-val) + (case (car name-val) + ((plane-mask foreground background) + (cons (car name-val) + (make-pixel (cdr name-val)))) + ;((tile stipple clip-mask) + ;(cons (car name-val) + ; (make-pixmap (cdr name-val) dyp??))) + ;((font) (cons (make-font ...??))) + (else name-val))) + alist)))) + mod-alist)))) + +(import-lambda-defintion %get-gcontext-values (Xgcontext Xdisplay) + "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-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)) + +;; ... + +(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-definiton %change-gcontext (Xgcontext Xdisplay) + "Change_Gc") + +(define (make-gcontext-setter name) + (lambda (gcontext value) + (change-gcontext gcontext (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 + dash-list)) + +(import-lambda-definiton %set-dashlist (Xgcontext Xdisplay dashoffset dashlist) + "Set_Dashlist") + +;; ... + +(define (set-gcontext-clip-rectangles! gcontext x y rectangles ordering) + ...) + + diff --git a/scheme/xlib/stuff.scm b/scheme/xlib/stuff.scm index dee8ec9..8867270 100644 --- a/scheme/xlib/stuff.scm +++ b/scheme/xlib/stuff.scm @@ -16,4 +16,27 @@ (cddr args))))))) -(define-exported-binding "string->symbol" string->symbol) \ No newline at end of file +(define-exported-binding "string->symbol" string->symbol) + + +;; alist-split returns multiple values. the first values are all associations +;; of the keys. and additionaly the "rest" of the alist as one value. + +(define (alist-split alist key-def-list) + (let ((keys (map car key-def-list))) + (let ((vals (map (lambda (key) + (let ((v (assq key alist))) + (if v v (assq key key-def-list)))) + keys)) + (rest (fold-right (lambda (this rest) + (if (memq (car this) keys) + rest + (cons this rest))) + '() + alist))) + (apply values (append vals (list rest)))))) + +;; according to the XLib constant "Null" which is defined as "0L" + +(define null-resource? zero?) +(define null-resource 0) \ No newline at end of file diff --git a/scheme/xlib/window.scm b/scheme/xlib/window.scm index 14790e5..8061e9c 100644 --- a/scheme/xlib/window.scm +++ b/scheme/xlib/window.scm @@ -4,26 +4,9 @@ (define (create-window . args) (let ((alist (named-args->alist args))) - ;; filter attributes - (let* ((x 0) - (y 0) - (width #f) - (height #f) - (border-width 2) - (parent #f) - (change-win-attr-list '())) - (for-each (lambda (name-val) - (let ((val (cdr name-val))) - (case (car name-val) - ((x) (set! x val)) - ((y) (set! y val)) - ((width) (set! width val)) - ((height) (set! height val)) - ((parent) (set! parent val)) - ((border-width) (set! border-width val)) - (else (set! change-win-attr-list - (cons name-val change-win-attr-list)))))) - alist) + (receive (x y width height border-width parent change-win-attr-list) + (alist-split alist '((x . 0) (y . 0) (width . #f) (height . #f) + (border-width . 2) (parent . #f))) (let* ((display (window-display parent)) (Xwindow (%create-window (display-Xdisplay display) (window-Xwindow parent) @@ -31,7 +14,7 @@ change-win-attr-list))) (if (= Xwindow 0) (error "cannot create window") - (make-window #f Xwindow display)))))) + (make-window Xwindow display)))))) (import-lambda-definition %create-window (Xdisplay Xparent x y width height border-width attrAlist) @@ -95,20 +78,34 @@ (define (get-window-attributes window) (let ((Xwindow (window-Xwindow window)) (Xdisplay (display-Xdisplay (window-display window)))) - (let* ((lst (%get-window-attributes Xdisplay Xwindow)) - (alist (map cons - '(x y width height border-width depth visual root class - bit-gravity win-gravity backing-store backing-planes - backing-pixel save-under colormap map-installed - map-state all-event-masks your-event-mask - do-not-propagate-mask override-redirect screen) - lst)) - (mod-alist (map (lambda (name-val) - (case (car name-val) - ;((root) (make-window ... - (else name-val))) - alist))) - mod-alist))) + (let ((lst (%get-window-attributes Xdisplay Xwindow))) + (if (not lst) + (error "cannot get window attributes." window) + (let* + ((alist (map cons + '(x y width height border-width depth visual root + class bit-gravity win-gravity backing-store + backing-planes backing-pixel save-under colormap + map-installed map-state all-event-masks + your-event-mask do-not-propagate-mask + override-redirect + ; screen not supported + ) + lst)) + (mod-alist (map (lambda (name-val) + (case (car name-val) + ;((...-mask)) + ;((font) ...) + ((backing-pixel) + (cons 'backing-pixel + (make-pixel (cdr name-val)))) + ;((root) + ; (cons 'root + ; (make-window (cdr name-val) dpy??))) + ;((visual) ??) + (else name-val))) + alist))) + mod-alist))))) (import-lambda-definition %get-window-attributes (Xdisplay Xwindow) "Get_Window_Attributes") diff --git a/scheme/xlib/xlib-interfaces.scm b/scheme/xlib/xlib-interfaces.scm index c5b7e9c..f300223 100644 --- a/scheme/xlib/xlib-interfaces.scm +++ b/scheme/xlib/xlib-interfaces.scm @@ -16,6 +16,9 @@ window-set-tag! window-Xwindow window-display + drawable-abstraction + drawable-display + drawable-Xobject make-color color? @@ -34,6 +37,13 @@ pixel? pixel-Xpixel pixel-tag + + make-gcontext + gcontext? + gcontext-display + free-gcontext + gcontext-Xgcontext + gcontext-tag )) @@ -49,7 +59,8 @@ type/window-type type/color-type type/colormap-type - type/pixel-type)) + type/pixel-type + type/gcontext-type)) ;;; Basic package @@ -190,12 +201,31 @@ (open scsh scheme external-calls + receiving xlib-types xlib-basic -; xlib-graphics ;; for clear-window + xlib-graphics ;; for clear-window ) (files window)) +;;; the display-interface + +(define-interface xlib-drawable-interface + (export drawable? + drawable-root + drawable-x + drawable-y + drawable-width + drawable-height + drawable-border-width + drawable-depth)) + +(define-structure xlib-drawable xlib-drawable-interface + (open scsh + scheme + xlib-types) + (files drawable)) + ;;; the color-interface (define-interface xlib-color-interface @@ -251,3 +281,77 @@ black-pixel white-pixel )) + +;;; the gcontext-interface + +(define-interface xlib-gcontext-interface + (open scsh + scheme + external-calls + receiving + xlib-types + xlib-basic) + (files gcontext)) + +(define-structure xlib-gcontext xlib-gcontext-interface + (export gcontext? + gcontext-display + create-gcontext + copy-gcontext + free-gcontext + + query-best-size + query-best-cursor + query-best-title + query-best-stipple + + gcontext-function + gcontext-plane-mask + gcontext-foreground + gcontext-background + gcontext-line-width + gcontext-line-style + gcontext-cap-style + gcontext-join-style + gcontext-fill-style + gcontext-fill-rule + gcontext-arc-mode + gcontext-tile + gcontext-stipple + gcontext-ts-x + gcontext-ts-y + gcontext-font + gcontext-subwindow-mode + gcontext-exposures + gcontext-clip-x + gcontext-clip-y + gcontext-clip-mask + gcontext-dash-offset + gcontext-dashes + + set-gcontext-function! + set-gcontext-plane-mask! + set-gcontext-foreground! + set-gcontext-background! + set-gcontext-line-width! + set-gcontext-line-style! + set-gcontext-cap-style! + set-gcontext-join-style! + set-gcontext-fill-style! + set-gcontext-fill-rule! + set-gcontext-arc-mode! + set-gcontext-tile! + set-gcontext-stipple! + set-gcontext-ts-x! + set-gcontext-ts-y! + set-gcontext-font! + set-gcontext-subwindow-mode! + set-gcontext-exposures! + set-gcontext-clip-x! + set-gcontext-clip-y! + set-gcontext-clip-mask! + set-gcontext-dash-offset! + + set-gcontext-clip-rectangles! + set-gcontext-dashlist! + )) \ No newline at end of file