From 2298e207a04603250c504624d5926c18ce47d764 Mon Sep 17 00:00:00 2001
From: frese <frese>
Date: Thu, 8 Jan 2004 19:08:50 +0000
Subject: [PATCH] updated for current interface

---
 scheme/examples/hello-xft.scm |  12 +---
 scheme/examples/hello.scm     |  12 +---
 scheme/examples/picture.scm   |  68 +++++++++---------
 scheme/examples/regions.scm   | 127 ++++++++++++++++------------------
 scheme/examples/scxev.scm     |  50 ++++++-------
 5 files changed, 123 insertions(+), 146 deletions(-)

diff --git a/scheme/examples/hello-xft.scm b/scheme/examples/hello-xft.scm
index fa125f6..c252b10 100755
--- a/scheme/examples/hello-xft.scm
+++ b/scheme/examples/hello-xft.scm
@@ -1,10 +1,6 @@
 #!/bin/sh
-
-../../scx <<EOF
-
-,batch on
-
-,open srfi-1 signals xlib xft xrender rendezvous-channels threads
+exec scsh -ll sunterlib-0.5/sunterlib.scm -lel scx/load.scm -o xlib -o rendezvous-channels -o threads -o srfi-1 -o signals -o xft -o xrender -s "$0" "$@"
+!#
 
 (define *font-size* 36.0)
 
@@ -114,7 +110,3 @@
       (close-display dpy))))
 
 (font-demo)
-
-,exit
-
-EOF
diff --git a/scheme/examples/hello.scm b/scheme/examples/hello.scm
index b0a3c9b..beb1444 100755
--- a/scheme/examples/hello.scm
+++ b/scheme/examples/hello.scm
@@ -1,10 +1,6 @@
 #!/bin/sh
-
-../../scx <<EOF
-
-,batch on
-
-,open xlib rendezvous-channels threads
+exec scsh -ll sunterlib-0.5/sunterlib.scm -lel scx/load.scm -o xlib -o rendezvous-channels -o threads -s "$0" "$@"
+!#
 
 (define (hello text)
   (let* ((dpy (open-display))
@@ -65,7 +61,3 @@
       (close-display dpy))))
 
 (hello "Hello World!")
-
-,exit
-
-EOF
diff --git a/scheme/examples/picture.scm b/scheme/examples/picture.scm
index c8886b0..66ca24f 100755
--- a/scheme/examples/picture.scm
+++ b/scheme/examples/picture.scm
@@ -1,10 +1,6 @@
 #!/bin/sh
-
-../../scx <<EOF
-
-,batch on
-,open xlib
-,batch off
+exec scsh -ll sunterlib-0.5/sunterlib.scm -lel scx/load.scm -o xlib -o rendezvous-channels -o threads -s "$0" "$@"
+!#
 
 (define (picture point-count)
   (let* ((dpy (open-display))
@@ -12,43 +8,43 @@
 	 (height 400)
 	 (black (black-pixel dpy))
 	 (white (white-pixel dpy))
-	 (root (display-root-window dpy))
-	 (win (create-window root width height 
-			     'background-pixel white
-			     'event-mask '(exposure button-press)))
-	 (gc (create-gcontext win
-			      'background white 'foreground black)))
-    (map-window win)
-    (let event-loop ()
-      (let ((e (next-event dpy)))
-	(if
-	 (case (event-type e)
-	   ((expose) (begin
-		       (clear-window win)
-		       (draw-points win gc point-count 0 0 
-				    (/ width 2) (/ height 2))
-		       (draw-poly-text win gc 10 10 "Click a button to exit"
-				       '1-byte)
-		       #f))
-	   (else #t))
-	 #t
-	 (event-loop))))
+	 (root (default-root-window dpy))
+	 (win (create-simple-window dpy root 0 0 width height 1 black white))
+	 (gc (create-gc dpy win
+			(make-gc-value-alist (background white)
+					     (foreground black)))))
+    (init-sync-x-events dpy)
+    (map-window dpy win)
+
+    (call-with-event-channel
+     dpy win (event-mask exposure button-press)
+     (lambda (channel)
+       (let loop ()
+	 (if
+	  (let ((e (receive channel)))
+	    (cond
+	     ((expose-event? e)
+	      (clear-window dpy win)
+	      (draw-points dpy win gc point-count 0 0 
+			   (/ width 2) (/ height 2))
+	      (draw-image-string dpy win gc 10 10 "Click a button to exit"))
+	     
+	     (else #f)))
+	  (loop)))))
     (close-display dpy)))
 
-(define (draw-points win gc count x y hw hh)
+(define (draw-points dpy win gc count x y hw hh)
   (if (zero? (modulo count 100))
-      (display-flush-output (window-display win)))
+      (display-flush dpy))
   (if (not (zero? count))
       (let ((xf (floor (* (+ 1.2 x) hw ))) ; These lines center the picture
 	    (yf (floor (* (+ 0.5 y) hh ))))
-	(draw-point win gc (cons (inexact->exact xf) (inexact->exact yf)))
-	(draw-points win gc (- count 1)
-		     (- (* y (+ 1 (sin (* 0.7 x)))) (* 1.2 (sqrt (abs x))))
+	(draw-point dpy win gc (inexact->exact xf) (inexact->exact yf))
+	(draw-points dpy win gc
+		     (- count 1)
+		     (- (* y (+ 1 (sin (* 0.7 x))))
+			(* 1.2 (sqrt (abs x))))
 		     (- 0.21 x)
 		     hw hh))))
 
 (picture 1000)
-
-,exit
-y
-EOF
diff --git a/scheme/examples/regions.scm b/scheme/examples/regions.scm
index 20042c1..f3a2cc9 100755
--- a/scheme/examples/regions.scm
+++ b/scheme/examples/regions.scm
@@ -1,73 +1,68 @@
-../../scx <<EOF
-
-,batch on
-,open xlib
-,batch off
+#!/bin/sh
+exec scsh -ll sunterlib-0.5/sunterlib.scm -lel scx/load.scm -o xlib -o rendezvous-channels -s "$0" "$@"
+!#
 
 (define (regions)
   (let* ((dpy (open-display))
-	(cm (display-default-colormap dpy))
-	(black (black-pixel dpy))
-	(white (white-pixel dpy))
-	(blue (alloc-named-color cm 'blue))
-	(win (create-window (display-root-window dpy) 500 500 
-			    'event-mask '(button-press exposure)
-			    'background-pixel white))
-	(gc (create-gcontext win
-			     'background white
-			     'foreground black))
-	
-	(rectangles '((10 20 60 60) (50 100 30 30)))
-	(colors (list black blue))
-	(regions-alist 
-	 (list (cons (union-rectangle-with-region (car rectangles)
-						  (create-region))
-		     "black rectangle")
-	       (cons (union-rectangle-with-region (cadr rectangles)
-						  (create-region))
-		     "blue rectangle")))
+	 (cm (screen:default-colormap (display:default-screen dpy)))
+	 (black (black-pixel dpy))
+	 (white (white-pixel dpy))
+	 (blue (color:pixel (alloc-named-color dpy cm "blue")))
+	 (win (create-simple-window dpy (default-root-window dpy)
+				    0 0 500 500 1
+				    black white))
+	 (gc (create-gc dpy win
+			(make-gc-value-alist
+			 (background white)
+			 (foreground black))))
+	 
+	 (rectangles (list (make-rectangle 10 20 60 60)
+			   (make-rectangle 50 100 30 30)))
+	 (colors (list black blue))
+	 (regions-alist
+	  (map (lambda (rect text)
+		 (cons (union-rect-with-region (rectangle:x rect)
+					       (rectangle:y rect)
+					       (rectangle:width rect)
+					       (rectangle:height rect)
+					       (create-region))
+		       text))
+	       rectangles
+	       '("black rectangle" "blue rectangle"))))
 
-	(handle-event 
-	 (lambda (e)
-	   (let ((args (event-args e))
-		 (type (event-type e)))
-	     (case type
-	       ;; Zeichnen...
-	       ((expose) (begin
-			   (for-each (lambda (rect color)
-				       (set-gcontext-foreground! gc color)
-				       (fill-rectangle win gc rect))
-				     rectangles colors)
-			   #t))
-	       ;; Hit-Tests
-	       ((button-press)
-		(let* ((x (cdr (assq 'x args)))
-		       (y (cdr (assq 'y args)))
-		       (rs (filter (lambda (r-n)
-				     (point-in-region? (car r-n)
-						       x y))
-				   regions-alist)))
-		  (for-each (lambda (region-name)
-			      (display "You clicked: ")
-			      (display (cdr region-name))
-			      (newline))
-			    rs)
-		  ;; break if none was hit.
-		  (not (null? rs))))
-	       )))))
+    (map-window dpy win)
+    (init-sync-x-events dpy)
 
-    (map-window win)
-    (let loop ()
-      (display-flush-output dpy)
-      (let ((e (next-event dpy)))
-	(if (handle-event e)
-	    (loop)
-	    (close-display dpy))))))
+    (call-with-event-channel
+     dpy win (event-mask exposure button-press structure-notify)
+     (lambda (channel)
+       (let loop ()
+	 (let ((e (receive channel)))
+	   (cond
+	    ;; Zeichnen...
+	    ((expose-event? e)
+	     (for-each (lambda (rect color)
+			 (set-gc-foreground! dpy gc color)
+			 (fill-rectangles dpy win gc (list rect)))
+		       rectangles colors))
+	    ;; Hit-Tests
+	    ((button-event? e)
+	     (let* ((x (button-event-x e))
+		    (y (button-event-y e))
+		    (rs (filter (lambda (r-n)
+				  (point-in-region? (car r-n)
+						    x y))
+				regions-alist)))
+	       (for-each (lambda (region-name)
+			   (display "You clicked: ")
+			   (display (cdr region-name))
+			   (newline))
+			 rs)
+	       ;; break if none was hit.
+	       (if (null? rs)
+		   (begin
+		     (close-display dpy)
+		     (exit)))))))
+	 (loop))))))
 
 (regions)
-	
-
-
-,exit
-y
-EOF
diff --git a/scheme/examples/scxev.scm b/scheme/examples/scxev.scm
index 7bf486e..b7530a2 100755
--- a/scheme/examples/scxev.scm
+++ b/scheme/examples/scxev.scm
@@ -1,33 +1,35 @@
 #!/bin/sh
+exec scsh -ll sunterlib-0.5/sunterlib.scm -lel scx/load.scm -o xlib -o rendezvous-channels -s "$0" "$@"
+!#
 
-../../scx <<EOF
-
-,batch on
-,open xlib
-,batch off
+(define all-events-mask
+  (event-mask
+   key-press key-release button-press button-release enter-window leave-window
+   pointer-motion pointer-motion-hint button-1-motion button-2-motion 
+   button-3-motion button-4-motion button-5-motion button-motion keymap-state
+   exposure visibility-change structure-notify resize-redirect
+   substructure-notify substructure-redirect focus-change property-change
+   colormap-change owner-grab-button))
 
 (define (scxev)
   (let* ((dpy (open-display))
 	 (black (black-pixel dpy))
 	 (white (white-pixel dpy))
-	 (win (create-window (display-default-root-window dpy)
-			     300 200
-			     'event-mask '(all-events)
-			     'background-pixel white))
-	 )
-    (set-wm-name! win '("scx Event Listener"))
-    (map-window win)
-    (let event-loop ()
-      (display-flush-output dpy)
-      (let ((e (wait-event dpy)))
-	(display (event-type e)) (display " Event, Data:\n")
-	(display (event-args e)) (newline) (newline)
-	
-	(event-loop))
-      (close-display dpy))))
+	 (win (create-simple-window dpy (default-root-window dpy) 0 0
+				    300 200 0 black white)))
+
+    (set-wm-name! dpy win (string-list->property '("scx Event Listener")))
+    (map-window dpy win)
+
+    (init-sync-x-events dpy)
+    (call-with-event-channel
+     dpy win all-events-mask
+     (lambda (channel)
+       (let loop ()
+	 (let ((e (receive channel)))
+	   (display (any-event-type e)) (display " on window ")
+	   (display (any-event-window e)) (newline)
+	   (if (not (destroy-window-event? e))
+	       (loop))))))))
 
 (scxev)
-
-,exit
-y
-EOF
\ No newline at end of file