From 2d06f4576b958269fb65ef501649b38e7808a57d Mon Sep 17 00:00:00 2001 From: frese Date: Mon, 11 Jun 2001 15:28:32 +0000 Subject: [PATCH] Major changes. First window showed up! --- scheme/xlib/color.scm | 48 ++++++ scheme/xlib/colormap.scm | 25 +++ scheme/xlib/display.scm | 82 ++------- scheme/xlib/pixel.scm | 13 ++ scheme/xlib/stuff.scm | 19 +++ scheme/xlib/type/color-type.scm | 73 ++++++++ scheme/xlib/type/colormap-type.scm | 59 +++++++ scheme/xlib/type/display-type.scm | 61 +++++++ scheme/xlib/type/pixel-type.scm | 43 +++++ scheme/xlib/type/window-type.scm | 64 ++++++++ scheme/xlib/window.scm | 256 +++++++++++++++++++++++++++++ scheme/xlib/xlib-interfaces.scm | 212 +++++++++++++++++++++++- 12 files changed, 879 insertions(+), 76 deletions(-) create mode 100644 scheme/xlib/color.scm create mode 100644 scheme/xlib/colormap.scm create mode 100644 scheme/xlib/pixel.scm create mode 100644 scheme/xlib/stuff.scm create mode 100644 scheme/xlib/type/color-type.scm create mode 100644 scheme/xlib/type/colormap-type.scm create mode 100644 scheme/xlib/type/display-type.scm create mode 100644 scheme/xlib/type/pixel-type.scm create mode 100644 scheme/xlib/type/window-type.scm create mode 100644 scheme/xlib/window.scm diff --git a/scheme/xlib/color.scm b/scheme/xlib/color.scm new file mode 100644 index 0000000..9caaeca --- /dev/null +++ b/scheme/xlib/color.scm @@ -0,0 +1,48 @@ +;; Author: David Frese + +;; r,g,b should be values between 0.0 to 1.0 inclusive. + +(define (make-color r g b) + (create-color (floor (* r 65535)) + (floor (* g 65535)) + (floor (* b 65535)))) + +(define (color-rgb-values color) + (map (lambda (x) + (/ x 65535)) ;; exact<->inexact? + (extract-rgb-values color))) + +;; ... + +(define (query-color colormap pixel) + (apply create-color + (%query-color (colormap-Xcolormap colormap) + (pixel-Xpixel pixel) + (display-Xdisplay (colormap-display colormap))))) + +(import-lambda-definiton %query-color (Xcolormap Xpixel Xdisplay) + "Query_Color") + +;; ... + +(define (query-colors colormap pixels) + (list->vector + (map (lambda (pixel) + (query-color colormap pixel)) + (vector->list pixels)))) + +;; ... + +(define (lookup-color colormap color-name) + (let ((r (%lookup-color (colormap-Xcolormap colormap) + (display-Xdisplay (colormap-display colormap)) + (if (symbol? color-name) + (symbol->string color-name) + color-name)))) + (if r + (cons (apply create-color (car r)) + (apply create-color (cdr r))) + (error "no such color:" color-name)))) + +(import-lambda-definiton %lookup-color (Xcolormap Xdisplay) + "Lookup_Color") diff --git a/scheme/xlib/colormap.scm b/scheme/xlib/colormap.scm new file mode 100644 index 0000000..fb72c98 --- /dev/null +++ b/scheme/xlib/colormap.scm @@ -0,0 +1,25 @@ +;; Author: David Frese + +(define (alloc-color colormap color) + (let ((Xpixel (%alloc-color (colormap-Xcolormap colormap) + (color-Xcolor color) + (display-Xdisplay (colormap-display colormap))))) + (if Xpixel + (make-pixel Xpixel) + Xpixel))) + +(import-lambda-definiton %alloc-color (Xcolormap Xcolor Xdisplay) + "Alloc_Color") + +;; ... + +(define (alloc-named-color colormap color-name) + (let ((Xres (%alloc-named-color (colormap-Xcolormap colormap) + (if (symbol? color-name) + (symbol->string color-name) + color-name)))) + (if Xres + (list (make-pixel (car Xres)) + (apply make-color (cadr Xres)) + (apply make-color (caddr Xres))) + Xres))) diff --git a/scheme/xlib/display.scm b/scheme/xlib/display.scm index b9ef216..e7c2135 100644 --- a/scheme/xlib/display.scm +++ b/scheme/xlib/display.scm @@ -1,26 +1,5 @@ ;; Author: David Frese -(define-record-type display :display - (really-make-display after-function Xdisplay) - display? - (after-function display-after-function display-set-after-function!) - (Xdisplay display-Xdisplay display-set-Xdisplay!)) - -;; for compatibility with elk: -(define set-after-function! display-set-after-function!) -(define after-function display-after-function) - -(define (make-display Xdisplay) - (let ((maybe-display (display-list-find Xdisplay))) - (if maybe-display - maybe-display - (let ((display (really-make-display #f Xdisplay))) - (add-finalizer! display finalize-display) - (display-list-set! Xdisplay display) - display)))) - -(define-exported-binding "display-record-type" :display) - (define (open-display . args) (let ((display-name (if (null? args) #f @@ -35,54 +14,16 @@ (import-lambda-definition %open-display (name) "Open_Display") -;; finalize-display is called, when the garbage collector removes the last -;; reference to display from the heap. Then we can savely close the display -;; and remove the weak-pointer from out list. - -(define (finalize-display display) - (let ((Xdisplay (display-Xdisplay display))) - (close-display display) - (display-list-delete! Xdisplay))) - -;; close-display closes the corresponding Xlib-display struct, by calling a -;; c-function and marks the scheme-record to be invalid (with the -;; 'already-closed symbol). Calling close-display more than once has no -;; effects. - -(define (close-display display) - (let ((Xdisplay (display-Xdisplay display))) - (if (integer? Xdisplay) - (begin - ((display-after-function display) display) - (%close-display Xdisplay) - (display-set-Xdisplay display 'already-closed))))) - -(import-lambda-definition %close-display (Xdisplay) "Close_Display") - -;; All display records need to be saved in a weak-list, to have only one record -;; for the same Xlib display-structure in the heap. - -(define *weak-display-list* (make-integer-table)) - -(define (display-list-find Xdisplay) - (let ((r (table-ref *weak-display-list* Xdisplay))) - (if r - (weak-pointer-ref r) - r))) - -(define (display-list-set! Xdisplay display) - (let ((p (make-weak-pointer display))) - (table-set! *weak-display-list* Xdisplay p))) - -(define (display-list-delete! Xdisplay) - (display-list-set! Xdisplay #f)) +;; for compatibility with elk: +(define set-after-function! display-set-after-function!) +(define after-function display-after-function) ;; ... (define (display-default-root-window display) (let* ((Xdisplay (display-Xdisplay display)) (Xwindow (%default-root-window Xdisplay))) - (make-window 0 Xdisplay Xwindow))) + (make-window 0 Xwindow (make-display Xdisplay)))) (define display-root-window display-default-root-window) @@ -94,7 +35,8 @@ (define (display-default-colormap display) (let* ((Xdisplay (display-Xdisplay display)) (Xcolormap (%default-colormap Xdisplay))) - (make-colormap 0 Xdisplay Xcolormap))) +;** (make-colormap 0 Xdisplay Xcolormap))) + #f)) (define display-colormap display-default-colormap) @@ -106,8 +48,8 @@ (define (display-default-gcontext display) (let* ((Xdisplay (display-Xdisplay display)) (Xgcontext (%default-gcontext Xdisplay))) - (make-gcontext 0 Xdisplay Xgcontext))) - +;** (make-gcontext 0 Xdisplay Xgcontext))) + #f)) (import-lambda-definition %default-gcontext (Xdisplay) "Display_Default_Gcontext") @@ -117,7 +59,7 @@ (let ((Xdisplay (display-Xdisplay display))) (%default-depth Xdisplay))) -(import-lambda-defintion %default-depth (Xdisplay) +(import-lambda-definition %default-depth (Xdisplay) "Display_Default_Depth") ;; ... @@ -166,7 +108,7 @@ (define (display-vendor display) (%display-vendor (display-Xdisplay display))) -(import-lambda-defintion %display-vendor (Xdisplay) +(import-lambda-definition %display-vendor (Xdisplay) "Display_Vendor") ;; Display-protocol-version return a pair of major and minor version numbers of @@ -273,7 +215,7 @@ (define (display-flush-output display) (%display-flush-output (display-Xdisplay display))) -(import-lambda-definiton %display-flush-output (Xdisplay) +(import-lambda-definition %display-flush-output (Xdisplay) "Display_Flush_Output") ;; ... the result is unspecific @@ -312,6 +254,8 @@ (define (display-list-pixmap-formats display) (%display-list-pixmap-formats (display-Xdisplay display))) +(define list-pixmap-formats display-list-pixmap-formats) ;; compat./Elk + (import-lambda-definition %display-list-pixmap-formats (Xdisplay) "List_Pixmap_Formats") diff --git a/scheme/xlib/pixel.scm b/scheme/xlib/pixel.scm new file mode 100644 index 0000000..98b7935 --- /dev/null +++ b/scheme/xlib/pixel.scm @@ -0,0 +1,13 @@ +(define pixel-value pixel-Xpixel) + +(define (black-pixel display) + (make-pixel (%black-pixel (display-Xdisplay display)))) + +(import-lambda-definition %black-pixel (Xdisplay) + "Black_Pixel") + +(define (white-pixel display) + (make-pixel (%white-pixel (display-Xdisplay display)))) + +(import-lambda-definition %white-pixel (Xdisplay) + "White_Pixel") \ No newline at end of file diff --git a/scheme/xlib/stuff.scm b/scheme/xlib/stuff.scm new file mode 100644 index 0000000..dee8ec9 --- /dev/null +++ b/scheme/xlib/stuff.scm @@ -0,0 +1,19 @@ +;; named-args->alist does this: +;; '(a 5 b 6 ((c . 10) (d . 5))) -> '((a . 5) (b . 6) (c . 10) (d . 5)) +;; '(e 3) -> '((e . 3)) +;; '((f . 0)) -> '((f . 0)) +;; (hard to explain :-) + +(define (named-args->alist args) + (let loop ((alist '()) + (args args)) + (cond + ((null? args) (reverse alist)) + ((null? (cdr args)) (loop (append (car args) alist) '())) + (else (let ((sym (car args)) + (val (cadr args))) + (loop (cons (cons sym val) alist) + (cddr args))))))) + + +(define-exported-binding "string->symbol" string->symbol) \ No newline at end of file diff --git a/scheme/xlib/type/color-type.scm b/scheme/xlib/type/color-type.scm new file mode 100644 index 0000000..2faf61b --- /dev/null +++ b/scheme/xlib/type/color-type.scm @@ -0,0 +1,73 @@ +;; the color-datatype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-record-type color :color + (really-make-color tag Xcolor) + color? + (tag color-tag color-set-tag!) + (Xcolor color-Xcolor color-set-Xcolor!)) + +(define (internal-make-color Xcolor) + (let ((maybe-color (color-list-find Xcolor))) + (if maybe-color + maybe-color + (let ((color (really-make-color #f Xcolor))) + (add-finalizer! color finalize-color) + (color-list-set! Xcolor color) + color)))) + +;; r, g, b should be integers from 0 to 65535 +(define (make-color r g b) + (let ((maybe-color (color-list-find* r g b))) + (if maybe-color + maybe-color + (internal-make-color (%create-color r g b))))) + +(import-lambda-definition %create-color (r g b) + "Create_Color") + +(define-exported-binding "color-record-type" :color) + +;; returns a list of r,g,b as integers +(define (extract-rgb-values color) + (%extract-rgb-values (color-Xcolor))) + +(import-lambda-definition %extract-rgb-values (XColor) + "Extract_RGB_Values") + +;; finalize-color is called, when the garbage collector removes the last +;; reference to the color from the heap. Then we can savely close the color +;; and remove the weak-pointer from our list. + +(define (finalize-color color) + (let ((Xcolor (color-Xcolor color))) + ;;(destroy-color color) + (color-set-Xcolor! color 'already-destroyed) + (color-list-delete! Xcolor))) + +;; All color records need to be saved in a weak-list, to have only one record +;; for the same r,g,b value in the heap. + +(define *weak-color-list* (make-integer-table)) + +(define (color-list-find Xcolor) + (let ((r (table-ref *weak-color-list* Xcolor))) + (if r + (weak-pointer-ref r) + r))) + +(define (color-list-find* r g b) ;; r,g,b as integers + (call/cc (lambda (return) + (table-walk (lambda (key value) + (let ((color (weak-pointer-ref value))) + (if (equal? (list r g b) + (extract-rgb-values color)) + (return key)))) + *weak-color-list*) + #f))) + +(define (color-list-set! Xcolor color) + (let ((p (make-weak-pointer color))) + (table-set! *weak-color-list* Xcolor p))) + +(define (color-list-delete! Xcolor) + (table-set! *weak-color-list* Xcolor #f)) diff --git a/scheme/xlib/type/colormap-type.scm b/scheme/xlib/type/colormap-type.scm new file mode 100644 index 0000000..8c3e766 --- /dev/null +++ b/scheme/xlib/type/colormap-type.scm @@ -0,0 +1,59 @@ +;; the colormap-datatype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-record-type colormap :colormap + (really-make-colormap tag Xcolormap display) + colormap? + (tag colormap-tag colormap-set-tag!) + (Xcolormap colormap-Xcolormap colormap-set-Xcolormap!) + (display colormap-display colormap-set-display!)) + +(define (make-colormap Xcolormap display) + (let ((maybe-colormap (colormap-list-find Xcolormap))) + (if maybe-colormap + maybe-colormap + (let ((colormap (really-make-colormap #f Xcolormap display))) + (add-finalizer! colormap finalize-colormap) + (colormap-list-set! Xcolormap colormap) + colormap)))) + +(define-exported-binding "colormap-record-type" :colormap) + +;; finalize-colormap is called, when the garbage collector removes the last +;; reference to the colormap from the heap. Then we can savely close the +;; colormap and remove the weak-pointer from our list. + +(define (finalize-colormap colormap) + (let ((Xcolormap (colormap-Xcolormap colormap))) + (free-colormap colormap) + (colormap-set-Xcolormap! colormap 'already-destroyed) + (colormap-list-delete! Xcolormap))) + +(define (free-colormap colormap) + (let ((Xcolormap (colormap-Xcolormap))) + (if (integer? Xcolormap) + (begin + (%free-colormap Xcolormap + (display-Xdisplay (colormap-display colormap))) + (colormap-set-Xcolormap! colormap 'already-freed))))) + +(import-lambda-definition %free-colormap (Xcolormap Xdisplay) + "Free_Colormap") + +;; All colormap records need to be saved in a weak-list, to have only one record +;; for the same XLib colormap + +(define *weak-colormap-list* (make-integer-table)) + +(define (colormap-list-find Xcolormap) + (let ((r (table-ref *weak-colormap-list* Xcolormap))) + (if r + (weak-pointer-ref r) + r))) + +(define (colormap-list-set! Xcolormap colormap) + (let ((p (make-weak-pointer colormap))) + (table-set! *weak-colormap-list* Xcolormap p))) + +(define (colormap-list-delete! Xcolormap) + (table-set! *weak-colormap-list* Xcolormap #f)) + diff --git a/scheme/xlib/type/display-type.scm b/scheme/xlib/type/display-type.scm new file mode 100644 index 0000000..de9fa01 --- /dev/null +++ b/scheme/xlib/type/display-type.scm @@ -0,0 +1,61 @@ +;; the display-datatype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-record-type display :display + (really-make-display after-function Xdisplay) + display? + (after-function display-after-function display-set-after-function!) + (Xdisplay display-Xdisplay display-set-Xdisplay!)) + +(define (make-display Xdisplay) + (let ((maybe-display (display-list-find Xdisplay))) + (if maybe-display + maybe-display + (let ((display (really-make-display #f Xdisplay))) + (add-finalizer! display finalize-display) + (display-list-set! Xdisplay display) + display)))) + +(define-exported-binding "display-record-type" :display) + +;; finalize-display is called, when the garbage collector removes the last +;; reference to the display from the heap. Then we can savely close the display +;; and remove the weak-pointer from our list. + +(define (finalize-display display) + (let ((Xdisplay (display-Xdisplay display))) + (close-display display) + (display-list-delete! Xdisplay))) + +;; close-display closes the corresponding Xlib-display struct, by calling a +;; c-function and marks the scheme-record to be invalid (with the +;; 'already-closed symbol). Calling close-display more than once has no +;; effects. + +(define (close-display display) + (let ((Xdisplay (display-Xdisplay display))) + (if (integer? Xdisplay) + (begin + ((display-after-function display) display) + (%close-display Xdisplay) + (display-set-Xdisplay display 'already-closed))))) + +(import-lambda-definition %close-display (Xdisplay) "Close_Display") + +;; All display records need to be saved in a weak-list, to have only one record +;; for the same Xlib display-structure in the heap. + +(define *weak-display-list* (make-integer-table)) + +(define (display-list-find Xdisplay) + (let ((r (table-ref *weak-display-list* Xdisplay))) + (if r + (weak-pointer-ref r) + r))) + +(define (display-list-set! Xdisplay display) + (let ((p (make-weak-pointer display))) + (table-set! *weak-display-list* Xdisplay p))) + +(define (display-list-delete! Xdisplay) + (table-set! *weak-display-list* Xdisplay #f)) + diff --git a/scheme/xlib/type/pixel-type.scm b/scheme/xlib/type/pixel-type.scm new file mode 100644 index 0000000..7795745 --- /dev/null +++ b/scheme/xlib/type/pixel-type.scm @@ -0,0 +1,43 @@ +(define-record-type pixel :pixel + (really-make-pixel tag Xpixel) + pixel? + (tag pixel-tag pixel-set-tag!) + (Xpixel pixel-Xpixel pixel-set-Xpixel!)) + +(define (make-pixel Xpixel display) + (let ((maybe-pixel (pixel-list-find Xpixel))) + (if maybe-pixel + maybe-pixel + (let ((pixel (really-make-pixel #f Xpixel display))) + (add-finalizer! pixel finalize-pixel) + (pixel-list-set! Xpixel pixel) + pixel)))) + +(define-exported-binding "pixel-record-type" :pixel) + +;; finalize-pixel is called, when the garbage collector removes the last +;; reference to the pixel from the heap. Then we can savely close the +;; pixel and remove the weak-pointer from our list. + +(define (finalize-pixel pixel) + (let ((Xpixel (pixel-Xpixel pixel))) + (pixel-set-Xpixel! pixel 'already-destroyed) + (pixel-list-delete! Xpixel))) + +;; All pixel records need to be saved in a weak-list, to have only one record +;; for the same XLib pixel + +(define *weak-pixel-list* (make-integer-table)) + +(define (pixel-list-find Xpixel) + (let ((r (table-ref *weak-pixel-list* Xpixel))) + (if r + (weak-pointer-ref r) + r))) + +(define (pixel-list-set! Xpixel pixel) + (let ((p (make-weak-pointer pixel))) + (table-set! *weak-pixel-list* Xpixel p))) + +(define (pixel-list-delete! Xpixel) + (table-set! *weak-pixel-list* Xpixel #f)) \ No newline at end of file diff --git a/scheme/xlib/type/window-type.scm b/scheme/xlib/type/window-type.scm new file mode 100644 index 0000000..65ce496 --- /dev/null +++ b/scheme/xlib/type/window-type.scm @@ -0,0 +1,64 @@ +;; the window-datatype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-record-type window :window + (really-make-window tag Xwindow display) + window? + (tag window-tag window-set-tag!) + (Xwindow window-Xwindow window-set-Xwindow!) + (display window-display window-set-display!)) + +(define (make-window tag Xwindow display) + (let ((maybe-window (window-list-find Xwindow))) + (if maybe-window + maybe-window + (let ((window (really-make-window tag Xwindow display))) + (add-finalizer! window finalize-window) + (window-list-set! Xwindow window) + window)))) + +(define-exported-binding "window-record-type" :window) + +(define (drawable? object) + (or (window? object) + (pixmap? object))) + +;; finalize-window is called, when the garbage collector removes the last +;; reference to the window from the heap. Then we can savely close the window +;; and remove the weak-pointer from our list. + +(define (finalize-window window) + (let ((Xwindow (window-Xwindow window))) + (destroy-window window) + (window-list-delete! Xwindow))) + +;; ... + +(define (destroy-window window) + (let ((Xdisplay (display-Xdisplay (window-display window))) + (Xwindow (window-Xwindow window))) + (if (integer? Xwindow) + (begin + (%destroy-window Xdisplay Xwindow) + (window-set-Xwindow! window 'already-destroyed))))) + +(import-lambda-definition %destroy-window (Xdisplay Xwindow) + "Destroy_Window") + +;; All window records need to be saved in a weak-list, to have only one record +;; for the same Xlib window-structure in the heap. + +(define *weak-window-list* (make-integer-table)) + +(define (window-list-find Xwindow) + (let ((r (table-ref *weak-window-list* Xwindow))) + (if r + (weak-pointer-ref r) + r))) + +(define (window-list-set! Xwindow window) + (let ((p (make-weak-pointer window))) + (table-set! *weak-window-list* Xwindow p))) + +(define (window-list-delete! Xwindow) + (table-set! *weak-window-list* Xwindow #f)) + diff --git a/scheme/xlib/window.scm b/scheme/xlib/window.scm new file mode 100644 index 0000000..14790e5 --- /dev/null +++ b/scheme/xlib/window.scm @@ -0,0 +1,256 @@ +;; Author: David Frese + +; ... + +(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) + (let* ((display (window-display parent)) + (Xwindow (%create-window (display-Xdisplay display) + (window-Xwindow parent) + x y width height border-width + change-win-attr-list))) + (if (= Xwindow 0) + (error "cannot create window") + (make-window #f Xwindow display)))))) + +(import-lambda-definition %create-window (Xdisplay Xparent x y width height + border-width attrAlist) + "Create_Window") + + + +;; change-window-attributes takes an alist of names and values... +;; names can be: background-pixmap, background-pixel, border-pixmap, +;; border-pixel, bit-gravity, gravity, backing-store, backing-planes, +;; backing-pixel, save-under, event-mask, do-not-propagate-mask, +;; override-redirect, colormap, cursor. + +(define (change-window-attributes window . attrs) + (let* ((alist (named-args->alist attrs)) + (prep-alist + (map cons + (map car alist) + (map (lambda (value) + (cond + ;; Abstractions ?? : + ((pixmap? value) (pixmap-Xpixmap value)) + ((pixel? value) (pixel-Xpixel value)) + ((colormap? value) (colormap-Xcolormap value)) + ((cursor? value) (cursor-Xcursor value)) + (else value))) + (map cdr alist))))) + (%change-window-attributes (window-Xwindow window) + (display-Xdisplay (window-display window)) + prep-alist))) + +(import-lambda-definition %change-window-attributes (Xwindow Xdisplay alist) + "Change_Window_Attributes") + +;; single functions that use change-window-attributes: + +(define (make-win-attr-setter name) + (lambda (window value) + (change-window-attributes window (cons name value)))) + +(define set-window-background-pixmap! (make-win-attr-setter 'background-pixmap)) +(define set-window-background-pixel! (make-win-attr-setter 'background-pixel)) +(define set-window-border-pixmap! (make-win-attr-setter 'border-pixmap)) +(define set-window-border-pixel! (make-win-attr-setter 'border-pixel)) +(define set-window-bit-gravity! (make-win-attr-setter 'bit-gravity)) +(define set-window-gravity! (make-win-attr-setter 'gravity)) +(define set-window-backing-store! (make-win-attr-setter 'backing-store)) +(define set-window-backing-planes! (make-win-attr-setter 'backing-planes)) +(define set-window-backing-pixel! (make-win-attr-setter 'backing-pixel)) +(define set-window-save-under! (make-win-attr-setter 'save-under)) +(define set-window-event-mask! (make-win-attr-setter 'event-mask)) +(define set-window-do-not-propagate-mask! + (make-win-attr-setter 'do-not-propagate-mask)) +(define set-window-override-redirect! (make-win-attr-setter 'override-redirect)) +(define set-window-colormap! (make-win-attr-setter 'colormap)) +(define set-window-cursor! (make-win-attr-setter 'cursor)) + +;; get-window-attributes gives back the same attributes that +;; set-window-attributes sets and some more ... + +(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))) + +(import-lambda-definition %get-window-attributes (Xdisplay Xwindow) + "Get_Window_Attributes") + +(define (make-win-attr-getter name) + (lambda (window) + (cdr (assq name (get-window-attributes window))))) + +(define window-x (make-win-attr-getter 'x)) +(define window-y (make-win-attr-getter 'y)) +(define window-width (make-win-attr-getter 'width)) +(define window-height (make-win-attr-getter 'height)) +(define window-border-width (make-win-attr-getter 'border-width)) +(define window-depth (make-win-attr-getter 'depth)) +(define window-visual (make-win-attr-getter 'visual)) +(define window-root (make-win-attr-getter 'root)) +(define window-class (make-win-attr-getter 'class)) +(define window-bit-gravity (make-win-attr-getter 'bit-gravity)) +(define window-backing-store (make-win-attr-getter 'backing-store)) +(define window-backing-planes (make-win-attr-getter 'backing-planes)) +(define window-backing-pixel (make-win-attr-getter 'backing-pixel)) +(define window-save-under (make-win-attr-getter 'save-under)) +(define window-colormap (make-win-attr-getter 'colormap)) +(define window-map-installed (make-win-attr-getter 'map-installed)) +(define window-map-state (make-win-attr-getter 'map-state)) +(define window-all-event-masks (make-win-attr-getter 'all-event-masks)) +(define window-your-event-mask (make-win-attr-getter 'your-event-mask)) +(define window-do-not-propagate-mask + (make-win-attr-getter 'do-not-propagate-mask)) +(define window-override-redirect (make-win-attr-getter 'override-redirect)) + +;; ... + +(define (configure-window window . args) + (let* ((args (named-args->alist args)) + (prep-alist (map cons + (map car args) + (map (lambda (val) + (if (window? val) + (window-Xwindow val) + val)) + (map cdr args))))) + (%configure-window (window-Xwindow window) + (display-Xdisplay (window-display)) + prep-alist))) + +(import-lambda-definition %configure-window (Xwindow Xdisplay alist) + "Configure_Window") + +;; the following mutators are based on configure-window + +(define (make-win-configurer name) + (lambda (window value) + (configure-window window name value))) + +(define set-window-x! (make-win-configurer 'x)) +(define set-window-y! (make-win-configurer 'y)) +(define set-window-width! (make-win-configurer 'width)) +(define set-window-height! (make-win-configurer 'height)) +(define set-window-border-width! (make-win-configurer 'border-width)) +(define set-window-sibling! (make-win-configurer 'sibling)) +(define set-window-stack-mode! (make-win-configurer 'stack-mode)) + +;; ... + +(define (map-window window) + (%map-window (window-Xwindow window) + (display-Xdisplay (window-display window)))) + +(import-lambda-definition %map-window (Xwindow Xdisplay) + "Map_Window") + +;; ... + +(define (unmap-window window) + (%unmap-window (window-Xwindow window) + (display-Xdisplay (window-display window)))) + +(import-lambda-definition %unmap-window (Xwindow Xdisplay) + "Unmap_Window") + +;; ... + +(define (destroy-subwindows window) + (%destroy-subwindows (window-Xwindow window) + (display-Xdisplay (window-display window)))) + +(import-lambda-definition %destroy-subwindows (Xwindow Xdisplay) + "Destroy_Subwindows") + +;; ... + +(define (map-subwindows window) + (%map-subwindows (window-Xwindow window) + (display-Xdisplay (window-display window)))) + +(import-lambda-definition %map-subwindows (Xwindow Xdisplay) + "Map_Subwindows") + +;; ... + +(define (unmap-subwindows window) + (%unmap-subwindows (window-Xwindow window) + (display-Xdisplay (window-display window)))) + +(import-lambda-definition %unmap-subwindows (Xwindow Xdisplay) + "Unmap_Subwindows") + +;; ... + +(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?? + +(import-lambda-definition %circulate-subwindows (Xwindow Xdisplay dir) + "Circulate_Subwindows") + +;; ... + +(define (clear-window window) + (clear-area window 0 0 0 0 #f)) + +;; ... + +(define (raise-window window) + (set-window-stack-mode! window 'above)) + +(define (lower-window window) + (set-window-stack-mode! window 'below)) + +;; ... + +(define (restack-windows window-list) + (let loop ((w (car window-list)) + (t (cdr window-list))) + (if (not (null? t)) + (let ((n (car t))) + (set-window-sibling! n w) + (set-window-stack-mode! n 'below) + (loop n (cdr t)))))) + +;; ... \ No newline at end of file diff --git a/scheme/xlib/xlib-interfaces.scm b/scheme/xlib/xlib-interfaces.scm index e4b9b9f..c5b7e9c 100644 --- a/scheme/xlib/xlib-interfaces.scm +++ b/scheme/xlib/xlib-interfaces.scm @@ -1,3 +1,68 @@ +;;; A "header" package with all new datatypes + +(define-interface xlib-types-interface + (export make-display + display? + display-Xdisplay + display-after-function + display-set-after-function! + close-display + + make-window + destroy-window + window? + drawable? + window-tag + window-set-tag! + window-Xwindow + window-display + + make-color + color? + color-Xcolor + color-tag + color-set-tag! + + make-colormap + colormap? + free-colormap + colormap-display + colormap-Xcolormap + colormap-tag + + make-pixel + pixel? + pixel-Xpixel + pixel-tag + + )) + +(define-structure xlib-types xlib-types-interface + (open scsh + scheme + weak + general-tables + primitives + define-record-types + external-calls) + (files type/display-type + type/window-type + type/color-type + type/colormap-type + type/pixel-type)) + +;;; Basic package + +(define-interface xlib-basic-interface + (export named-args->alist)) + +(define-structure xlib-basic xlib-basic-interface + (open scsh + scheme + external-calls) + (files stuff)) + + ;;; The display structure (define-interface xlib-display-interface @@ -45,11 +110,144 @@ (define-structure xlib-display xlib-display-interface (open scsh scheme - define-record-types - weak - general-tables -; xlib-window - primitives) - (files "display.scm")) + external-calls + xlib-types + xlib-basic) + (files display)) -;;; ... \ No newline at end of file +(define-interface xlib-window-interface + (export window? + drawable? + window-display + create-window + destroy-window + change-window-attributes + get-window-attributes + map-window + unmap-window + + set-window-background-pixmap! + set-window-background-pixel! + set-window-border-pixmap! + set-window-border-pixel! + set-window-bit-gravity! + set-window-gravity! + set-window-backing-store! + set-window-backing-planes! + set-window-backing-pixel! + set-window-save-under! + set-window-event-mask! + set-window-do-not-propagate-mask! + set-window-override-redirect! + set-window-colormap! + set-window-cursor! + + set-window-x! + set-window-y! + set-window-width! + set-window-height! + set-window-border-width! + set-window-sibling! + set-window-stack-mode! + + window-x + window-y + window-width + window-height + window-border-width + window-depth + window-visual + window-root + window-class + window-bit-gravity + window-backing-store + window-backing-planes + window-backing-pixel + window-save-under + window-colormap + window-map-installed + window-map-state + window-all-event-masks + window-your-event-mask + window-do-not-propagate-mask + window-override-redirect + + destroy-subwindows + map-subwindows + unmap-subwindows + circulate-subwindows + + clear-window + raise-window + lower-window + restack-windows + query-tree + translate-coordinates + query-pointer + )) + +(define-structure xlib-window xlib-window-interface + (open scsh + scheme + external-calls + xlib-types + xlib-basic +; xlib-graphics ;; for clear-window + ) + (files window)) + +;;; the color-interface + +(define-interface xlib-color-interface + (export make-color + color? + color-rgb-values + color-tag ;;?? + color-set-tag!;;?? + query-color + query-colors + lookup-color)) + +(define-structure xlib-color xlib-color-interface + (open scsh + scheme + external-calls + xlib-types + xlib-basic) + (files color)) + +;;; the colormap-interface + +(define-interface xlib-colormap-interface + (export make-colormap + colormap? + free-colormap + colormap-display + alloc-color + alloc-named-color + )) + +(define-structure xlib-colormap xlib-colormap-interface + (open scsh + scheme + external-calls + xlib-types + xlib-basic) + (files colormap)) + +;;; the pixel-interface + +(define-interface xlib-pixel-interface + (open scsh + scheme + external-calls + xlib-types + xlib-basic) + (files pixel)) + +(define-structure xlib-pixel xlib-pixel-interface + (export pixel? + pixel-value + black-pixel + white-pixel + ))