Update of /cvsroot/scsh/scx/scheme/xlib
In directory usw-pr-cvs1:/tmp/cvs-serv27777
Modified Files:
display.scm stuff.scm window.scm xlib-interfaces.scm
Added Files:
drawable.scm gcontext.scm
Log Message:
Only some small changes.
--- NEW FILE ---
;(define (drawable-abstraction pixmap-fun window-fun)
; (lambda (drawable)
; (cond
; ((pixmap? drawable) (pixmap-fun drawable))
; ((window? drawable) (window-fun drawable))
; (else (error "expected a drawable object" drawable)))))
;(define drawable-display (drawable-abstraction pixmap-display window-display))
;(define drawable-Xobject (drawable-abstraction pixmap-Xpixmap window-Xwindow))
;; not so sure with pixmap-root, not found in Elk.
(define drawable-root (drawable-abstraction (lambda (pixm)
(display-default-root-window
(pixmap-display pixm)))
window-root))
(define drawable-x (drawable-abstraction pixmap-x window-x))
(define drawable-y (drawable-abstraction pixmap-y window-y))
(define drawable-width (drawable-abstraction pixmap-width window-width))
(define drawable-height (drawable-abstraction pixmap-height window-height))
(define drawable-border-width (drawable-abstraction pixmap-border-width
window-border-width))
(define drawable-depth (drawable-abstraction pixmap-depth window-depth))
--- NEW FILE ---
;; ...
(define (create-gcontext . args)
(let ((alist (named-args->alist args)))
(receive (drawable rest) (alist-split '((drawable . #f)))
(let* ((rest (map cons
(map car rest)
(map (lambda (obj)
(cond
((pixel? obj) (pixel-Xpixel obj))
((font? obj) (font-Xfont obj))
((pixmap? obj) (pixmap-Xpixmap obj))
(else obj)))
(map cdr rest))))
(display (drawable-display drawable))
(Xdisplay (display-Xdisplay display))
(Xobject (drawable-Xobject drawable)))
(let ((Xgcontext (%create-gcontext Xdisplay Xobject rest)))
(make-gcontext Xgcontext display))))))
(import-lambda-definition %create-gcontext (Xdisplay Xdrawable alist)
"Create_Gc")
;; ...
(define (copy-gcontext gcontext drawable)
(let* ((new-gcontext (create-gcontext 'drawable drawable))
(new-Xgcontext (gcontext-Xgcontext new-gcontext))
(Xgcontext (gcontext-Xgcontext gcontext))
(Xdisplay (display-Xdisplay (gcontext-display gcontext)))
(%copy-gcontext Xdisplay Xgcontext new-Xgcontext))
new-gcontext))
(import-lambda-definition %copy-gcontext (Xdisplay Xsource Xdest)
"Copy_Gc")
;; ...
(define (get-gcontext-values gcontext)
(let ((Xgcontext (gcontext-Xgcontext gcontext))
(Xdisplay (display-Xdisplay (gcontext-display gcontext))))
(let ((lst (%get-gcontext-values Xgcontext Xdisplay)))
(if (not lst)
(error "cannot get gcontext values." gcontext)
(let*
((alist (map cons
'(function plane-mask foreground background
line-width line-style cap-style join-style
fill-style arc-mode tile stipple ts-x ts-y font
subwindow-mode exposures clip-x clip-y clip-mask
dash-offset dashes)
lst))
(mod-alist (map (lambda (name-val)
(case (car name-val)
((plane-mask foreground background)
(cons (car name-val)
(make-pixel (cdr name-val))))
;((tile stipple clip-mask)
;(cons (car name-val)
; (make-pixmap (cdr name-val) dyp??)))
;((font) (cons (make-font ...??)))
(else name-val)))
alist))))
mod-alist))))
(import-lambda-defintion %get-gcontext-values (Xgcontext Xdisplay)
"Get_Gc_Values")
;;...
(define (make-gcontext-getter name)
(lambda (gcontext)
(cdr (assq name (get-gcontext-values gcontext)))))
(define gcontext-function (make-gcontext-getter 'function))
(define gcontext-plane-mask (make-gcontext-getter 'plane-mask))
(define gcontext-foreground (make-gcontext-getter 'foreground))
(define gcontext-background (make-gcontext-getter 'background))
(define gcontext-line-width (make-gcontext-getter 'line-width))
(define gcontext-line-style (make-gcontext-getter 'line-style))
(define gcontext-cap-style (make-gcontext-getter 'cap-style))
(define gcontext-join-style (make-gcontext-getter 'join-style))
(define gcontext-fill-style (make-gcontext-getter 'fill-style))
(define gcontext-arc-mode (make-gcontext-getter 'arc-mode))
(define gcontext-tile (make-gcontext-getter 'tile))
(define gcontext-stipple (make-gcontext-getter 'stipple))
(define gcontext-ts-x (make-gcontext-getter 'ts-x))
(define gcontext-ts-y (make-gcontext-getter 'ts-y))
(define gcontext-font (make-gcontext-getter 'font))
(define gcontext-subwindow-mode (make-gcontext-getter 'subwindow-mode))
(define gcontext-exposures (make-gcontext-getter 'exposures))
(define gcontext-clip-x (make-gcontext-getter 'clip-x))
(define gcontext-clip-y (make-gcontext-getter 'clip-y))
(define gcontext-clip-mask (make-gcontext-getter 'clip-mask))
(define gcontext-dash-offset (make-gcontext-getter 'dash-offset))
(define gcontext-dashes (make-gcontext-getter 'dashes))
;; ...
(define (change-gcontext gcontext . attrs)
(let* ((alist (named-args->alist attrs))
(prep-alist
(map cons
(map car alist)
(map (lambda (value)
(cond
((pixmap? value) (pixmap-Xpixmap value))
((font? value) (font-Xfont value)) ;;??
((pixel? value) (pixel-Xpixel value))
(else value)))
(map cdr alist)))))
(%change-gcontext (gcontext-Xgcontext gcontext)
(display-Xdisplay (gcontext-display gcontext))
prep-alist)))
(import-lambda-definiton %change-gcontext (Xgcontext Xdisplay)
"Change_Gc")
(define (make-gcontext-setter name)
(lambda (gcontext value)
(change-gcontext gcontext (cons name value))))
(define set-gcontext-function! (make-gcontext-setter 'function))
(define set-gcontext-plane-mask! (make-gcontext-setter 'plane-mask))
(define set-gcontext-foreground! (make-gcontext-setter 'foreground))
(define set-gcontext-background! (make-gcontext-setter 'background))
(define set-gcontext-line-width! (make-gcontext-setter 'line-width))
(define set-gcontext-line-style! (make-gcontext-setter 'line-style))
(define set-gcontext-cap-style! (make-gcontext-setter 'cap-style))
(define set-gcontext-join-style! (make-gcontext-setter 'join-style))
(define set-gcontext-fill-style! (make-gcontext-setter 'fill-style))
(define set-gcontext-fill-rule! (make-gcontext-setter 'fill-rule))
(define set-gcontext-arc-mode! (make-gcontext-setter 'arc-mode))
(define set-gcontext-tile! (make-gcontext-setter 'tile))
(define set-gcontext-stipple! (make-gcontext-setter 'stipple))
(define set-gcontext-ts-x! (make-gcontext-setter 'ts-x))
(define set-gcontext-ts-y! (make-gcontext-setter 'ts-y))
(define set-gcontext-font! (make-gcontext-setter 'font))
(define set-gcontext-subwindow-mode! (make-gcontext-setter 'subwindow-mode))
(define set-gcontext-exposures! (make-gcontext-setter 'exposures))
(define set-gcontext-clip-x! (make-gcontext-setter 'clip-x))
(define set-gcontext-clip-y! (make-gcontext-setter 'clip-y))
(define set-gcontext-clip-mask! (make-gcontext-setter 'clip-mask))
(define set-gcontext-dash-offset! (make-gcontext-setter 'dash-offset))
(define set-gcontext-dashes! (make-gcontext-setter 'dashes))
;; set-dashlist! is a more complex form of set-dashes!. (set-dashes! N) is
;; equivalent to (set-dash-list! .. #(N N))
(define (set-gcontext-dashlist! gcontext dash-offset dash-list)
(%set-dashlist (gcontext-Xgcontext gcontext)
(display-Xdisplay (gcontext-display gcontext))
dash-offset
dash-list))
(import-lambda-definiton %set-dashlist (Xgcontext Xdisplay dashoffset dashlist)
"Set_Dashlist")
;; ...
(define (set-gcontext-clip-rectangles! gcontext x y rectangles ordering)
...)
Index: display.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/display.scm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -r1.2 -r1.3
*** display.scm 2001/06/11 15:28:32 1.2
--- display.scm 2001/06/25 11:43:11 1.3
***************
*** 24,28 ****
(let* ((Xdisplay (display-Xdisplay display))
(Xwindow (%default-root-window Xdisplay)))
! (make-window 0 Xwindow (make-display Xdisplay))))
(define display-root-window display-default-root-window)
--- 24,28 ----
(let* ((Xdisplay (display-Xdisplay display))
(Xwindow (%default-root-window Xdisplay)))
! (make-window Xwindow (make-display Xdisplay))))
(define display-root-window display-default-root-window)
Index: stuff.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/stuff.scm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -r1.1 -r1.2
*** stuff.scm 2001/06/11 15:28:32 1.1
--- stuff.scm 2001/06/25 11:43:11 1.2
***************
*** 17,19 ****
! (define-exported-binding "string->symbol" string->symbol)
\ No newline at end of file
--- 17,42 ----
! (define-exported-binding "string->symbol" string->symbol)
!
!
! ;; alist-split returns multiple values. the first values are all associations
! ;; of the keys. and additionaly the "rest" of the alist as one value.
!
! (define (alist-split alist key-def-list)
! (let ((keys (map car key-def-list)))
! (let ((vals (map (lambda (key)
! (let ((v (assq key alist)))
! (if v v (assq key key-def-list))))
! keys))
! (rest (fold-right (lambda (this rest)
! (if (memq (car this) keys)
! rest
! (cons this rest)))
! '()
! alist)))
! (apply values (append vals (list rest))))))
!
! ;; according to the XLib constant "Null" which is defined as "0L"
!
! (define null-resource? zero?)
! (define null-resource 0)
\ No newline at end of file
Index: window.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/window.scm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -r1.1 -r1.2
*** window.scm 2001/06/11 15:28:32 1.1
--- window.scm 2001/06/25 11:43:11 1.2
***************
*** 5,28 ****
(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)
--- 5,11 ----
(define (create-window . args)
(let ((alist (named-args->alist args)))
! (receive (x y width height border-width parent change-win-attr-list)
! (alist-split alist '((x . 0) (y . 0) (width . #f) (height . #f)
! (border-width . 2) (parent . #f)))
(let* ((display (window-display parent))
(Xwindow (%create-window (display-Xdisplay display)
***************
*** 32,36 ****
(if (= Xwindow 0)
(error "cannot create window")
! (make-window #f Xwindow display))))))
(import-lambda-definition %create-window (Xdisplay Xparent x y width height
--- 15,19 ----
(if (= Xwindow 0)
(error "cannot create window")
! (make-window Xwindow display))))))
(import-lambda-definition %create-window (Xdisplay Xparent x y width height
***************
*** 96,113 ****
(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)
--- 79,110 ----
(let ((Xwindow (window-Xwindow window))
(Xdisplay (display-Xdisplay (window-display window))))
! (let ((lst (%get-window-attributes Xdisplay Xwindow)))
! (if (not lst)
! (error "cannot get window attributes." window)
! (let*
! ((alist (map cons
! '(x y width height border-width depth visual root
! class bit-gravity win-gravity backing-store
! backing-planes backing-pixel save-under colormap
! map-installed map-state all-event-masks
! your-event-mask do-not-propagate-mask
! override-redirect
! ; screen not supported
! )
! lst))
! (mod-alist (map (lambda (name-val)
! (case (car name-val)
! ;((...-mask))
! ;((font) ...)
! ((backing-pixel)
! (cons 'backing-pixel
! (make-pixel (cdr name-val))))
! ;((root)
! ; (cons 'root
! ; (make-window (cdr name-val) dpy??)))
! ;((visual) ??)
! (else name-val)))
! alist)))
! mod-alist)))))
(import-lambda-definition %get-window-attributes (Xdisplay Xwindow)
Index: xlib-interfaces.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/xlib-interfaces.scm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -r1.2 -r1.3
*** xlib-interfaces.scm 2001/06/11 15:28:32 1.2
--- xlib-interfaces.scm 2001/06/25 11:43:11 1.3
***************
*** 17,20 ****
--- 17,23 ----
window-Xwindow
window-display
+ drawable-abstraction
+ drawable-display
+ drawable-Xobject
make-color
***************
*** 35,38 ****
--- 38,48 ----
pixel-Xpixel
pixel-tag
+
+ make-gcontext
+ gcontext?
+ gcontext-display
+ free-gcontext
+ gcontext-Xgcontext
+ gcontext-tag
))
***************
*** 50,54 ****
type/color-type
type/colormap-type
! type/pixel-type))
;;; Basic package
--- 60,65 ----
type/color-type
type/colormap-type
! type/pixel-type
! type/gcontext-type))
;;; Basic package
***************
*** 191,200 ****
scheme
external-calls
xlib-types
xlib-basic
! ; xlib-graphics ;; for clear-window
)
(files window))
;;; the color-interface
--- 202,230 ----
scheme
external-calls
+ receiving
xlib-types
xlib-basic
! xlib-graphics ;; for clear-window
)
(files window))
+ ;;; the display-interface
+
+ (define-interface xlib-drawable-interface
+ (export drawable?
+ drawable-root
+ drawable-x
+ drawable-y
+ drawable-width
+ drawable-height
+ drawable-border-width
+ drawable-depth))
+
+ (define-structure xlib-drawable xlib-drawable-interface
+ (open scsh
+ scheme
+ xlib-types)
+ (files drawable))
+
;;; the color-interface
***************
*** 252,253 ****
--- 282,357 ----
white-pixel
))
+
+ ;;; the gcontext-interface
+
+ (define-interface xlib-gcontext-interface
+ (open scsh
+ scheme
+ external-calls
+ receiving
+ xlib-types
+ xlib-basic)
+ (files gcontext))
+
+ (define-structure xlib-gcontext xlib-gcontext-interface
+ (export gcontext?
+ gcontext-display
+ create-gcontext
+ copy-gcontext
+ free-gcontext
+
+ query-best-size
+ query-best-cursor
+ query-best-title
+ query-best-stipple
+
+ gcontext-function
+ gcontext-plane-mask
+ gcontext-foreground
+ gcontext-background
+ gcontext-line-width
+ gcontext-line-style
+ gcontext-cap-style
+ gcontext-join-style
+ gcontext-fill-style
+ gcontext-fill-rule
+ gcontext-arc-mode
+ gcontext-tile
+ gcontext-stipple
+ gcontext-ts-x
+ gcontext-ts-y
+ gcontext-font
+ gcontext-subwindow-mode
+ gcontext-exposures
+ gcontext-clip-x
+ gcontext-clip-y
+ gcontext-clip-mask
+ gcontext-dash-offset
+ gcontext-dashes
+
+ set-gcontext-function!
+ set-gcontext-plane-mask!
+ set-gcontext-foreground!
+ set-gcontext-background!
+ set-gcontext-line-width!
+ set-gcontext-line-style!
+ set-gcontext-cap-style!
+ set-gcontext-join-style!
+ set-gcontext-fill-style!
+ set-gcontext-fill-rule!
+ set-gcontext-arc-mode!
+ set-gcontext-tile!
+ set-gcontext-stipple!
+ set-gcontext-ts-x!
+ set-gcontext-ts-y!
+ set-gcontext-font!
+ set-gcontext-subwindow-mode!
+ set-gcontext-exposures!
+ set-gcontext-clip-x!
+ set-gcontext-clip-y!
+ set-gcontext-clip-mask!
+ set-gcontext-dash-offset!
+
+ set-gcontext-clip-rectangles!
+ set-gcontext-dashlist!
+ ))
\ No newline at end of file
|