scsh-conservatory
/
scx
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Major changes. First window showed up!

This commit is contained in:
frese 2001-06-11 15:28:32 +00:00
parent 36f9d36db5
commit 2d06f4576b
12 changed files with 879 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
scheme/xlib/color.scm Normal file
View File

@ -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")

25
scheme/xlib/colormap.scm Normal file
View File

@ -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)))

82
scheme/xlib/display.scm
View File

@ -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")

13
scheme/xlib/pixel.scm Normal file
View File

@ -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")

19
scheme/xlib/stuff.scm Normal file
View File

@ -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)

73
scheme/xlib/type/color-type.scm Normal file
View File

@ -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))

59
scheme/xlib/type/colormap-type.scm Normal file
View File

@ -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))

61
scheme/xlib/type/display-type.scm Normal file
View File

@ -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))

43
scheme/xlib/type/pixel-type.scm Normal file
View File

@ -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))

64
scheme/xlib/type/window-type.scm Normal file
View File

@ -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))

256
scheme/xlib/window.scm Normal file
View File

@ -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))))))
;; ...

212
scheme/xlib/xlib-interfaces.scm
View File

@ -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))
;;; ...
(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
))