major changes and debugging.

2001-07-09 13:49:38 +00:00 · 2001-07-09 13:49:38 +00:00 · 6179ac994a
parent 4c47adaca4
commit 6179ac994a
6 changed files with 205 additions and 44 deletions
--- a/scheme/xlib/color.scm
+++ b/scheme/xlib/color.scm
@ -20,16 +20,20 @@
 		       (pixel-Xpixel pixel)
 		       (display-Xdisplay (colormap-display colormap)))))

-(import-lambda-definiton %query-color (Xcolormap Xpixel Xdisplay)
+(import-lambda-definition %query-color (Xcolormap Xpixel Xdisplay)
  "Query_Color")

 ;; ...

 (define (query-colors colormap pixels)
-  (list->vector
-   (map (lambda (pixel)
-	  (query-color colormap pixel))
-	(vector->list 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")

 ;; ...

@ -44,5 +48,5 @@
 	      (apply create-color (cdr r)))
 	(error "no such color:" color-name))))

-(import-lambda-definiton %lookup-color (Xcolormap Xdisplay)
+(import-lambda-definition %lookup-color (Xcolormap Xdisplay)
  "Lookup_Color")
--- a/scheme/xlib/colormap.scm
+++ b/scheme/xlib/colormap.scm
@ -8,7 +8,7 @@
 	(make-pixel Xpixel)
 	Xpixel)))

-(import-lambda-definiton %alloc-color (Xcolormap Xcolor Xdisplay)
+(import-lambda-definition %alloc-color (Xcolormap Xcolor Xdisplay)
  "Alloc_Color")

 ;; ...
--- a/scheme/xlib/event.scm
+++ b/scheme/xlib/event.scm
@ -0,0 +1,78 @@
+(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")
--- a/scheme/xlib/gcontext.scm
+++ b/scheme/xlib/gcontext.scm
@ -27,8 +27,8 @@
  (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))
+	 (Xdisplay (display-Xdisplay (gcontext-display gcontext))))
+    (%copy-gcontext Xdisplay Xgcontext new-Xgcontext)
    new-gcontext))

 (import-lambda-definition %copy-gcontext (Xdisplay Xsource Xdest)
@ -39,31 +39,30 @@
 (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)
+    (let ((vals (%get-gcontext-values Xgcontext Xdisplay)))
+      (if (not vals)
 	  (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))))
+	      ((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-defintion %get-gcontext-values (Xgcontext Xdisplay)
+(import-lambda-definition %get-gcontext-values (Xgcontext Xdisplay)
  "Get_Gc_Values")

 ;;...
@ -81,6 +80,7 @@
 (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-fill-rule (make-gcontext-getter 'fill-rule))
 (define gcontext-arc-mode (make-gcontext-getter 'arc-mode))
 (define gcontext-tile (make-gcontext-getter 'tile))
 (define gcontext-stipple (make-gcontext-getter 'stipple))
@ -114,7 +114,7 @@
 		      prep-alist)))


-(import-lambda-definiton %change-gcontext (Xgcontext Xdisplay)
+(import-lambda-definition %change-gcontext (Xgcontext Xdisplay)
  "Change_Gc")

 (define (make-gcontext-setter name)
@ -154,12 +154,37 @@
 		 dash-offset
 		 dash-list))

-(import-lambda-definiton %set-dashlist (Xgcontext Xdisplay dashoffset dashlist)
-  "Set_Dashlist")
+(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))
+


--- a/scheme/xlib/graphics.scm
+++ b/scheme/xlib/graphics.scm
@ -147,7 +147,7 @@
   "Draw_Rectangles")


-(define (fill-rectanlges drawable gcontext vector-of-rectangles)
+(define (fill-rectangles drawable gcontext vector-of-rectangles)
  (%fill-rectangles (display-Xdisplay (drawable-display drawable))
 		    (drawable-object drawable)
 		    (gcontext-Xgcontext gcontext)
--- a/scheme/xlib/window.scm
+++ b/scheme/xlib/window.scm
@ -78,11 +78,13 @@
 (define (get-window-attributes window)
  (let ((Xwindow (window-Xwindow window))
 	(Xdisplay (display-Xdisplay (window-display window))))
-    (let ((lst (%get-window-attributes Xdisplay Xwindow)))
-      (if (not lst)
+    (let ((v (%get-window-attributes Xdisplay Xwindow)))
+      (if (not v)
 	  (error "cannot get window attributes." window)
 	  (let*
-	      ((alist (map cons
+	      (;; ... 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 
 			     backing-planes backing-pixel save-under colormap 
@ -91,7 +93,7 @@
 			     override-redirect
 			     ; screen not supported
 			   )
-			   lst))
+			   (vector->list v)))
 	       (mod-alist (map (lambda (name-val)
 				 (case (car name-val)
 				   ;((...-mask))
@ -219,9 +221,8 @@
 (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??
+		       (eq? direction 'lower-highest)))
+		       ; other is: 'raise-lower / exception??

 (import-lambda-definition %circulate-subwindows (Xwindow Xdisplay dir)
  "Circulate_Subwindows")
@ -250,4 +251,57 @@
 	  (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")
+	  
+
+
+