diff --git a/scheme/xlib/color.scm b/scheme/xlib/color.scm index 9caaeca..720a3c6 100644 --- a/scheme/xlib/color.scm +++ b/scheme/xlib/color.scm @@ -20,16 +20,20 @@ (pixel-Xpixel pixel) (display-Xdisplay (colormap-display colormap))))) -(import-lambda-definiton %query-color (Xcolormap Xpixel Xdisplay) +(import-lambda-definition %query-color (Xcolormap Xpixel Xdisplay) "Query_Color") ;; ... (define (query-colors colormap pixels) - (list->vector - (map (lambda (pixel) - (query-color colormap pixel)) - (vector->list pixels)))) + (let ((res (%query-colors (colormap-Xcolormap colormap) + (vector-map! pixel-Xpixel pixels)))) + (vector-map! (lambda (r-g-b) + (apply make-color r-g-b)) + res))) + +(import-lambda-definition %query-colors (Xcolormap Xpixels Xdisplay) + "Query_Colors") ;; ... @@ -44,5 +48,5 @@ (apply create-color (cdr r))) (error "no such color:" color-name)))) -(import-lambda-definiton %lookup-color (Xcolormap Xdisplay) +(import-lambda-definition %lookup-color (Xcolormap Xdisplay) "Lookup_Color") diff --git a/scheme/xlib/colormap.scm b/scheme/xlib/colormap.scm index fb72c98..d3b8012 100644 --- a/scheme/xlib/colormap.scm +++ b/scheme/xlib/colormap.scm @@ -8,7 +8,7 @@ (make-pixel Xpixel) Xpixel))) -(import-lambda-definiton %alloc-color (Xcolormap Xcolor Xdisplay) +(import-lambda-definition %alloc-color (Xcolormap Xcolor Xdisplay) "Alloc_Color") ;; ... diff --git a/scheme/xlib/event.scm b/scheme/xlib/event.scm new file mode 100644 index 0000000..40f6e51 --- /dev/null +++ b/scheme/xlib/event.scm @@ -0,0 +1,78 @@ +(define (event-ready? display) + (char-ready? (display-message-inport display))) + +(define (complete-event event) + (let* ((type (event-type event)) + (args (event-args event)) + (comp (lambda (idx func) + (vector-set! args idx + (func (vector-ref args idx)))))) + ;; for all types + (comp 2 make-display) ;; Display the event was read from + (comp 3 (lambda (Xwin);; event-window it is reported relative to + (make-window Xwin (vector-ref args 2)))) + (let* ((display (vector-ref args 2)) + (window (vector-ref args 3)) + (make-window* (lambda (Xwindow) + (make-window Xwindow display)))) + ;; special entries + (case type + ((key-press key-release button-press button-release motion-notify) + ;; root window that the event occured on + (comp (+ sidx 0) make-window*) + ;; child window + (comp (+ sidx 1) make-window*)) + ;; time in milliseconds ?? ... + ((enter-notify leave-notify) + (comp (+ sidx 0) make-window*) ;; root window + (comp (+ sidx 1) make-window*));; subwindow + ;; time?? + ((create-notify destroy-notify unmap-notify map-notify map-request + gravity-notify circulate-request) + (comp (+ sidx 0) make-window*)) + ((reparent-notify configure-request) + (comp (+ sidx 0) make-window*) + (comp (+ sidx 1) make-window*)) + ((property-notify selection-clear) + (comp (+ sidx 0) make-atom)) ;;?? + ;; time?? + ((selection-request) + (comp (+ sidx 0) make-window*) + (comp (+ sidx 1) make-atom) ;;?? + (comp (+ sidx 2) make-atom) + (comp (+ sidx 3) make-atom)) + ((selection-notify) + (comp (+ sidx 0) make-atom) + (comp (+ sidx 1) make-atom) + (comp (+ sidx 2) make-atom)) + ((colormap-notify) + (comp (+ sidx 0) make-colormap)) ;;?? + ((client-message) + (comp (+ sidx 0) make-atom)) ;;?? + ) ;; case end + + event))) + +(define (next-event display) + (let ((r (%next-event (display-Xdisplay display)))) + (complete-event (make-event (car r) + (cdr r))))) + +(import-lambda-definition %next-event (Xdisplay) + "Next_Event") + +(define (peek-event display) + (let ((r (%peek-event (display-Xdisplay display)))) + (complete-event (make-event (car r) + (cdr r))))) + +(import-lambda-definition %peek-event (Xdisplay) + "Peek_Event") + +(define (events-pending display) + (if (event-ready? display) + (%events-pending (display-Xdisplay display)) + 0)) + +(import-lambda-definition %events-pending (Xdisplay) + "Events_Pending") \ No newline at end of file diff --git a/scheme/xlib/gcontext.scm b/scheme/xlib/gcontext.scm index 0fd9c34..f33b15d 100644 --- a/scheme/xlib/gcontext.scm +++ b/scheme/xlib/gcontext.scm @@ -27,8 +27,8 @@ (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)) + (Xdisplay (display-Xdisplay (gcontext-display gcontext)))) + (%copy-gcontext Xdisplay Xgcontext new-Xgcontext) new-gcontext)) (import-lambda-definition %copy-gcontext (Xdisplay Xsource Xdest) @@ -39,31 +39,30 @@ (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) + (let ((vals (%get-gcontext-values Xgcontext Xdisplay))) + (if (not vals) (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)))) + ((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 ...?? + 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-defintion %get-gcontext-values (Xgcontext Xdisplay) +(import-lambda-definition %get-gcontext-values (Xgcontext Xdisplay) "Get_Gc_Values") ;;... @@ -81,6 +80,7 @@ (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)) @@ -114,7 +114,7 @@ prep-alist))) -(import-lambda-definiton %change-gcontext (Xgcontext Xdisplay) +(import-lambda-definition %change-gcontext (Xgcontext Xdisplay) "Change_Gc") (define (make-gcontext-setter name) @@ -154,12 +154,37 @@ dash-offset dash-list)) -(import-lambda-definiton %set-dashlist (Xgcontext Xdisplay dashoffset dashlist) - "Set_Dashlist") +(import-lambda-definition %set-dashlist (Xgcontext Xdisplay dashoffset dashlist) + "Set_Gcontext_Dashlist") ;; ... (define (set-gcontext-clip-rectangles! gcontext x y rectangles ordering) - ...) + (%set-gcontext-clip-rectangles! (gcontext-Xgcontext gcontext) + (display-Xdisplay (gcontext-display gcontext)) + x y rectangles ordering)) + +(import-lambda-definition %set-gcontext-clip-rectangles! (Xgcontext Xdisplay x + y v ord) + "Set_Gcontext_Clip_Rectangles") + +;; ... + +(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) + "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)) + diff --git a/scheme/xlib/graphics.scm b/scheme/xlib/graphics.scm index 3a25405..1dcd298 100644 --- a/scheme/xlib/graphics.scm +++ b/scheme/xlib/graphics.scm @@ -147,7 +147,7 @@ "Draw_Rectangles") -(define (fill-rectanlges drawable gcontext vector-of-rectangles) +(define (fill-rectangles drawable gcontext vector-of-rectangles) (%fill-rectangles (display-Xdisplay (drawable-display drawable)) (drawable-object drawable) (gcontext-Xgcontext gcontext) diff --git a/scheme/xlib/window.scm b/scheme/xlib/window.scm index 8061e9c..7f3c208 100644 --- a/scheme/xlib/window.scm +++ b/scheme/xlib/window.scm @@ -78,11 +78,13 @@ (define (get-window-attributes window) (let ((Xwindow (window-Xwindow window)) (Xdisplay (display-Xdisplay (window-display window)))) - (let ((lst (%get-window-attributes Xdisplay Xwindow))) - (if (not lst) + (let ((v (%get-window-attributes Xdisplay Xwindow))) + (if (not v) (error "cannot get window attributes." window) (let* - ((alist (map cons + (;; ... modify as a vector not as a list... ?? + + (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 @@ -91,7 +93,7 @@ override-redirect ; screen not supported ) - lst)) + (vector->list v))) (mod-alist (map (lambda (name-val) (case (car name-val) ;((...-mask)) @@ -219,9 +221,8 @@ (define (circulate-subwindows window direction) (%destroy-subwindows (window-Xwindow window) (display-Xdisplay (window-display window)) - (case direction - ((raise-lowest) 0) - ((lower-highest) 1)))) ; else exception?? + (eq? direction 'lower-highest))) + ; other is: 'raise-lower / exception?? (import-lambda-definition %circulate-subwindows (Xwindow Xdisplay dir) "Circulate_Subwindows") @@ -250,4 +251,57 @@ (set-window-stack-mode! n 'below) (loop n (cdr t)))))) -;; ... \ No newline at end of file +;; ... + +(define (query-tree window) + (let* ((display (window-display window)) + (res (%query-tree (window-Xwindow window) + (display-Xdisplay display)))) + (list (make-window (first res) display) + (make-window (second res) display) + (vector-map! (lambda (Xwindow) + (make-window Xwindow display)) + (third res))))) + +(import-lambda-definition %query-tree (Xwindow Xdisplay) + "Query_Tree") + +;; ... + +(define (translate-coordinates scr-window x y dst-window) + (let* ((display (window-display src-window)) + (res (%translate-coordinates + (display-Xdisplay display) + (window-Xwindow src-window) + x y + (window-Xwindow dst-window)))) + (list (first res) + (second res) + (make-window (third res) display)))) + +(import-lambda-definition %translate-coordinates (Xdisplay srcXwindow x y + srcXwindow) + "Translate_Coordinates") + + +;; + +(define (query-pointer window) + (let* ((display (window-display window)) + (res (%query-pointer (display-Xdisplay display) + (window-Xwindow window)))) + (list (first res) + (second res) + (third res) + (make-window (fourth res) display) + (fifth res) + (sixth res) + (make-window (seventh res) display) + (eighth res)))) + +(import-lambda-definition %query-pointer (Xdisplay Xwindow) + "Query_Pointer") + + + +