From 2d06f4576b958269fb65ef501649b38e7808a57d Mon Sep 17 00:00:00 2001
From: frese <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
+ ))