From 9748014efeff4ea7c35ddb6750737db977fffe34 Mon Sep 17 00:00:00 2001
From: frese <frese>
Date: Thu, 13 Mar 2003 13:48:22 +0000
Subject: [PATCH] modified to match the new interface.

---
 scheme/examples/hello.scm | 92 +++++++++++++++++++++------------------
 1 file changed, 50 insertions(+), 42 deletions(-)

diff --git a/scheme/examples/hello.scm b/scheme/examples/hello.scm
index cbe4557..686b4d7 100755
--- a/scheme/examples/hello.scm
+++ b/scheme/examples/hello.scm
@@ -4,55 +4,63 @@
 
 ,batch on
 
-,open xlib
+,open xlib rendezvous-channels threads
 
 (define (hello text)
   (let* ((dpy (open-display))
-	 (cm (copy-colormap-and-free (display-default-colormap dpy)))
+	 (screen (display:default-screen dpy))
+	 (cm (screen:default-colormap screen))
+	 ;;(cm (copy-colormap-and-free dpy (screen:default-colormap screen)))
 
 	 ;; many ways to get color in your progs.
-	 (black (black-pixel dpy))
-	 (white (white-pixel dpy))
-	 (blue (alloc-color! cm (make-color 0 0 1)))
-	 (green (alloc-named-color cm "#00FF00"))
-	 (red (alloc-named-color cm 'red))
+	 (black (screen:black-pixel screen))
+	 (white (screen:white-pixel screen))
+	 (blue (alloc-color dpy cm 0 0 1))
+	 (green-color (alloc-named-color dpy cm "#00FF00"))
+	 (green (if green-color (color:pixel green-color) white))
 
-	 (win (create-window 
-	       (display-default-root-window dpy)
-	       100 200 300 200 10
-	       'copy-from-parent 'copy-from-parent 'copy-from-parent
-	       (make-set-window-attribute-alist
-		(event-mask (event-mask exposure button-press))
-		(background-pixel white)
-		(colormap cm))))
-	 (gc (create-gcontext 
-	      win
-	      (make-gc-value-alist (background white)
-				   (foreground black))))
-	 (font (open-font dpy "*-new century schoolbook-bold-r*24*"))
-	 (font2 (open-font dpy "*times*18*")))
-    (set-wm-name! win '("scx Hello World Program"))
-    (map-window win)
+	 (win (create-simple-window dpy
+				    (default-root-window dpy)
+				    100 200 400 200 1
+				    black white))
+	 (gc (create-gc dpy win 
+			(make-gc-value-alist (background white)
+					     (foreground black))))
+	 (font (load-font dpy "*-new century schoolbook-bold-r*24*"))
+	 (font2 (load-font dpy "*times*18*")))
 
-    (let event-loop ()
-      (display-flush-output dpy)
-      (let ((e (wait-event dpy)))
-	(if
-	 (cond
-	  ((expose-event? e)
-	   (set-gcontext-font! gc font)
-	   (set-gcontext-foreground! gc black)
-	   (draw-poly-text win gc 10 25 text '1-byte)
-	   (set-gcontext-foreground! gc blue)
-	   (draw-poly-text win gc 20 50 (list font text) '1-byte)
-	   (set-gcontext-foreground! gc red)
-	   (set-gcontext-font! gc font2)
-	   (draw-image-text win gc 30 75 text '1-byte)
-	   #t)
-	  (else #f))
-	 (event-loop)
-	 #f)))
-    (close-display dpy)))
+    (set-window-colormap! dpy win cm)
+    (set-wm-name! dpy win (string-list->property '("scx Hello World Program")))
+
+    (spawn (lambda ()
+	     (let loop ((se (most-recent-sync-x-event)))
+	       (display "event: ") (display (sync-x-event-event se))
+	       (display "\n")
+	       (loop (next-sync-x-event se (lambda (e) #t))))))
+    ;;(synchronize dpy #f)
+
+    (init-sync-x-events dpy)
+    (let ((handler
+	   (lambda (channel)
+	     (map-window dpy win)
+	     (let loop ()
+	       (if
+		(let ((e (receive channel)))
+		  (cond
+		   ((expose-event? e)
+		    (set-gc-font! dpy gc font)
+		    (set-gc-foreground! dpy gc black)
+		    (draw-image-string dpy win gc 10 65 text)
+		    
+		    (set-gc-foreground! dpy gc green)
+		    (draw-text dpy win gc 20 40
+			       (make-text-items text (change-font font2)
+						(with-delta 20 text))))
+		   (else #f)))
+		(loop))))))
+      (call-with-event-channel dpy win (event-mask exposure button-press)
+			       handler)
+      (close-display dpy))))
 
 (hello "Hello World!")