Update of /cvsroot/scsh/scx/scheme/xlib
In directory usw-pr-cvs1:/tmp/cvs-serv18409
Modified Files:
color.scm colormap.scm gcontext.scm graphics.scm window.scm
Added Files:
event.scm
Log Message:
major changes and debugging.
--- NEW FILE ---
(define (event-ready? display)
(char-ready? (display-message-inport display)))
(define (complete-event event)
(let* ((type (event-type event))
(args (event-args event))
(comp (lambda (idx func)
(vector-set! args idx
(func (vector-ref args idx))))))
;; for all types
(comp 2 make-display) ;; Display the event was read from
(comp 3 (lambda (Xwin);; event-window it is reported relative to
(make-window Xwin (vector-ref args 2))))
(let* ((display (vector-ref args 2))
(window (vector-ref args 3))
(make-window* (lambda (Xwindow)
(make-window Xwindow display))))
;; special entries
(case type
((key-press key-release button-press button-release motion-notify)
;; root window that the event occured on
(comp (+ sidx 0) make-window*)
;; child window
(comp (+ sidx 1) make-window*))
;; time in milliseconds ?? ...
((enter-notify leave-notify)
(comp (+ sidx 0) make-window*) ;; root window
(comp (+ sidx 1) make-window*));; subwindow
;; time??
((create-notify destroy-notify unmap-notify map-notify map-request
gravity-notify circulate-request)
(comp (+ sidx 0) make-window*))
((reparent-notify configure-request)
(comp (+ sidx 0) make-window*)
(comp (+ sidx 1) make-window*))
((property-notify selection-clear)
(comp (+ sidx 0) make-atom)) ;;??
;; time??
((selection-request)
(comp (+ sidx 0) make-window*)
(comp (+ sidx 1) make-atom) ;;??
(comp (+ sidx 2) make-atom)
(comp (+ sidx 3) make-atom))
((selection-notify)
(comp (+ sidx 0) make-atom)
(comp (+ sidx 1) make-atom)
(comp (+ sidx 2) make-atom))
((colormap-notify)
(comp (+ sidx 0) make-colormap)) ;;??
((client-message)
(comp (+ sidx 0) make-atom)) ;;??
) ;; case end
event)))
(define (next-event display)
(let ((r (%next-event (display-Xdisplay display))))
(complete-event (make-event (car r)
(cdr r)))))
(import-lambda-definition %next-event (Xdisplay)
"Next_Event")
(define (peek-event display)
(let ((r (%peek-event (display-Xdisplay display))))
(complete-event (make-event (car r)
(cdr r)))))
(import-lambda-definition %peek-event (Xdisplay)
"Peek_Event")
(define (events-pending display)
(if (event-ready? display)
(%events-pending (display-Xdisplay display))
0))
(import-lambda-definition %events-pending (Xdisplay)
"Events_Pending")
Index: color.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/color.scm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -r1.1 -r1.2
*** color.scm 2001/06/11 15:28:32 1.1
--- color.scm 2001/07/09 13:49:38 1.2
***************
*** 21,25 ****
(display-Xdisplay (colormap-display colormap)))))
! (import-lambda-definiton %query-color (Xcolormap Xpixel Xdisplay)
"Query_Color")
--- 21,25 ----
(display-Xdisplay (colormap-display colormap)))))
! (import-lambda-definition %query-color (Xcolormap Xpixel Xdisplay)
"Query_Color")
***************
*** 27,35 ****
(define (query-colors colormap pixels)
! (list->vector
! (map (lambda (pixel)
! (query-color colormap pixel))
! (vector->list pixels))))
;; ...
--- 27,39 ----
(define (query-colors colormap pixels)
! (let ((res (%query-colors (colormap-Xcolormap colormap)
! (vector-map! pixel-Xpixel pixels))))
! (vector-map! (lambda (r-g-b)
! (apply make-color r-g-b))
! res)))
+ (import-lambda-definition %query-colors (Xcolormap Xpixels Xdisplay)
+ "Query_Colors")
+
;; ...
***************
*** 45,48 ****
(error "no such color:" color-name))))
! (import-lambda-definiton %lookup-color (Xcolormap Xdisplay)
"Lookup_Color")
--- 49,52 ----
(error "no such color:" color-name))))
! (import-lambda-definition %lookup-color (Xcolormap Xdisplay)
"Lookup_Color")
Index: colormap.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/colormap.scm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -r1.1 -r1.2
*** colormap.scm 2001/06/11 15:28:32 1.1
--- colormap.scm 2001/07/09 13:49:38 1.2
***************
*** 9,13 ****
Xpixel)))
! (import-lambda-definiton %alloc-color (Xcolormap Xcolor Xdisplay)
"Alloc_Color")
--- 9,13 ----
Xpixel)))
! (import-lambda-definition %alloc-color (Xcolormap Xcolor Xdisplay)
"Alloc_Color")
Index: gcontext.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/gcontext.scm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -r1.1 -r1.2
*** gcontext.scm 2001/06/25 11:43:11 1.1
--- gcontext.scm 2001/07/09 13:49:38 1.2
***************
*** 28,33 ****
(new-Xgcontext (gcontext-Xgcontext new-gcontext))
(Xgcontext (gcontext-Xgcontext gcontext))
! (Xdisplay (display-Xdisplay (gcontext-display gcontext)))
! (%copy-gcontext Xdisplay Xgcontext new-Xgcontext))
new-gcontext))
--- 28,33 ----
(new-Xgcontext (gcontext-Xgcontext new-gcontext))
(Xgcontext (gcontext-Xgcontext gcontext))
! (Xdisplay (display-Xdisplay (gcontext-display gcontext))))
! (%copy-gcontext Xdisplay Xgcontext new-Xgcontext)
new-gcontext))
***************
*** 40,68 ****
(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")
--- 40,67 ----
(let ((Xgcontext (gcontext-Xgcontext gcontext))
(Xdisplay (display-Xdisplay (gcontext-display gcontext))))
! (let ((vals (%get-gcontext-values Xgcontext Xdisplay)))
! (if (not vals)
(error "cannot get gcontext values." gcontext)
(let*
! ((mod-vals (begin
! (vector-set! vals 1 ;; plane-mask
! (make-pixel (vector-ref vals 1)))
! (vector-set! vals 2 ;; foreground
! (make-pixel (vector-ref vals 2)))
! (vector-set! vals 3 ;; background
! (make-pixel (vector-ref vals 3)))
! ;; TODO: tile, stipple, font ...??
! vals))
! (alist
! (map cons
! '(function plane-mask foreground background
! line-width line-style cap-style join-style
! fill-style fill-rule arc-mode tile stipple ts-x ts-y
! font subwindow-mode exposures clip-x clip-y
! clip-mask dash-offset dashes)
! (vector->list mod-vals))))
! alist)))))
! (import-lambda-definition %get-gcontext-values (Xgcontext Xdisplay)
"Get_Gc_Values")
***************
*** 82,85 ****
--- 81,85 ----
(define gcontext-join-style (make-gcontext-getter 'join-style))
(define gcontext-fill-style (make-gcontext-getter 'fill-style))
+ (define gcontext-fill-rule (make-gcontext-getter 'fill-rule))
(define gcontext-arc-mode (make-gcontext-getter 'arc-mode))
(define gcontext-tile (make-gcontext-getter 'tile))
***************
*** 115,119 ****
! (import-lambda-definiton %change-gcontext (Xgcontext Xdisplay)
"Change_Gc")
--- 115,119 ----
! (import-lambda-definition %change-gcontext (Xgcontext Xdisplay)
"Change_Gc")
***************
*** 155,165 ****
dash-list))
! (import-lambda-definiton %set-dashlist (Xgcontext Xdisplay dashoffset
dashlist)
! "Set_Dashlist")
;; ...
(define (set-gcontext-clip-rectangles! gcontext x y rectangles ordering)
! ...)
--- 155,190 ----
dash-list))
! (import-lambda-definition %set-dashlist (Xgcontext Xdisplay dashoffset
dashlist)
! "Set_Gcontext_Dashlist")
;; ...
(define (set-gcontext-clip-rectangles! gcontext x y rectangles ordering)
! (%set-gcontext-clip-rectangles! (gcontext-Xgcontext gcontext)
! (display-Xdisplay (gcontext-display gcontext))
! x y rectangles ordering))
!
! (import-lambda-definition %set-gcontext-clip-rectangles! (Xgcontext Xdisplay
x
! y v ord)
! "Set_Gcontext_Clip_Rectangles")
!
! ;; ...
!
! (define (query-best-size display width height shape)
! (%query-best-size (display-Xdisplay display)
! width height shape))
!
! (import-lambda-definition %query-best-size (Xdisplay width height shape)
! "Query_Best_Size")
!
! (define (query-best-cursor display width height)
! (query-best-size display width height 'cursor))
!
! (define (query-best-tile display width height)
! (query-best-size display width height 'tile))
!
! (define (query-best-stipple display width height)
! (query-best-size display width height 'stipple))
!
Index: graphics.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/graphics.scm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -r1.1 -r1.2
*** graphics.scm 2001/07/04 14:19:38 1.1
--- graphics.scm 2001/07/09 13:49:38 1.2
***************
*** 148,152 ****
! (define (fill-rectanlges drawable gcontext vector-of-rectangles)
(%fill-rectangles (display-Xdisplay (drawable-display drawable))
(drawable-object drawable)
--- 148,152 ----
! (define (fill-rectangles drawable gcontext vector-of-rectangles)
(%fill-rectangles (display-Xdisplay (drawable-display drawable))
(drawable-object drawable)
Index: window.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/window.scm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -r1.2 -r1.3
*** window.scm 2001/06/25 11:43:11 1.2
--- window.scm 2001/07/09 13:49:38 1.3
***************
*** 79,87 ****
(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
--- 79,89 ----
(let ((Xwindow (window-Xwindow window))
(Xdisplay (display-Xdisplay (window-display window))))
! (let ((v (%get-window-attributes Xdisplay Xwindow)))
! (if (not v)
(error "cannot get window attributes." window)
(let*
! (;; ... modify as a vector not as a list... ??
!
! (alist (map cons
'(x y width height border-width depth visual root
class bit-gravity win-gravity backing-store
***************
*** 92,96 ****
; screen not supported
)
! lst))
(mod-alist (map (lambda (name-val)
(case (car name-val)
--- 94,98 ----
; screen not supported
)
! (vector->list v)))
(mod-alist (map (lambda (name-val)
(case (car name-val)
***************
*** 220,226 ****
(%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)
--- 222,227 ----
(%destroy-subwindows (window-Xwindow window)
(display-Xdisplay (window-display window))
! (eq? direction 'lower-highest)))
! ; other is: 'raise-lower / exception??
(import-lambda-definition %circulate-subwindows (Xwindow Xdisplay dir)
***************
*** 250,253 ****
(set-window-stack-mode! n 'below)
(loop n (cdr t))))))
- ;; ...
\ No newline at end of file
--- 251,307 ----
(set-window-stack-mode! n 'below)
(loop n (cdr t))))))
+
+ ;; ...
+
+ (define (query-tree window)
+ (let* ((display (window-display window))
+ (res (%query-tree (window-Xwindow window)
+ (display-Xdisplay display))))
+ (list (make-window (first res) display)
+ (make-window (second res) display)
+ (vector-map! (lambda (Xwindow)
+ (make-window Xwindow display))
+ (third res)))))
+
+ (import-lambda-definition %query-tree (Xwindow Xdisplay)
+ "Query_Tree")
+
+ ;; ...
+
+ (define (translate-coordinates scr-window x y dst-window)
+ (let* ((display (window-display src-window))
+ (res (%translate-coordinates
+ (display-Xdisplay display)
+ (window-Xwindow src-window)
+ x y
+ (window-Xwindow dst-window))))
+ (list (first res)
+ (second res)
+ (make-window (third res) display))))
+
+ (import-lambda-definition %translate-coordinates (Xdisplay srcXwindow x y
+ srcXwindow)
+ "Translate_Coordinates")
+
+
+ ;;
+
+ (define (query-pointer window)
+ (let* ((display (window-display window))
+ (res (%query-pointer (display-Xdisplay display)
+ (window-Xwindow window))))
+ (list (first res)
+ (second res)
+ (third res)
+ (make-window (fourth res) display)
+ (fifth res)
+ (sixth res)
+ (make-window (seventh res) display)
+ (eighth res))))
+
+ (import-lambda-definition %query-pointer (Xdisplay Xwindow)
+ "Query_Pointer")
+
+
+
|