The all new, all fancy Xft demo program

scheme/examples/hello-xft.scm

@@ -4,9 +4,54 @@
 
 ,batch on
 
-,open xlib xft xrender rendezvous-channels threads
+,open srfi-1 signals xlib xft xrender rendezvous-channels threads
 
-(define (hello text)
+(define *font-size* 36.0)
+
+(define (fontset->list-of-patterns fs)
+  (let ((count (scx-xft-fontset-count fs))
+	(ref (lambda (x) (scx-xft-fontset-ref fs x))))
+    (unfold
+     (lambda (x) (equal? count x))
+     ref
+     (lambda (x) (+ x 1))
+     0)))
+
+(define (list-all-fonts display screen)
+  (let ((p (make-xft-pattern))
+	(os (make-xft-objectset)))
+    (scx-xft-objectset-add os (xft-pattern-object family))
+    (let ((fs (scx-xft-list-fonts-pattern-objects display screen p os)))
+      (fontset->list-of-patterns fs))))
+
+(define (family-name-of-font font)
+  (call-with-values
+   (lambda ()
+     (scx-xft-pattern-get (xft-font-pattern font) (xft-pattern-object family) 0))
+   (lambda (code name)
+     (if (scx-xft-result-match? code)
+	 name "unknown font name"))))
+
+(define (draw-font-name xft-draw xft-color-fg xft-color-bg font)
+  (scx-xft-draw-rect xft-draw xft-color-bg 0 0 400 200)
+  (scx-xft-draw-string-8bit xft-draw xft-color-fg font 10 65 (family-name-of-font font)))
+
+(define (open-font dpy screen pattern)
+  (call-with-values
+   (lambda ()
+     (let ((copy (scx-xft-pattern-duplicate pattern)))
+       (scx-xft-pattern-add copy (xft-pattern-object size) *font-size* #f)
+       (scx-xft-font-match dpy screen copy)))
+   (lambda (result pattern)
+     (cond 
+      ((and (scx-xft-result-match? result)
+	    (scx-xft-font-open-pattern dpy pattern))
+       => (lambda (font) font))
+      (else
+       (scx-xft-pattern-print pattern)
+       (error "Could not open font!"))))))
+
+(define (font-demo)
   (let* ((dpy (open-display))
 	 (screen (display:default-screen dpy))
 	 (cm (screen:default-colormap screen))
@@ -23,18 +68,14 @@
 	 (gc (create-gc dpy win 
 			(make-gc-value-alist (background white)
 					     (foreground black))))
-	 (font (scx-xft-font-open-name dpy screen "Luxi Mono-24"))
-	 (font2 (scx-xft-font-open-name dpy screen "Times-36"))
 	 (visual (screen:default-visual screen))
 	 (xft-draw (scx-xft-draw-create dpy win visual cm))
 	 (xft-black (scx-xft-color-alloc-name dpy visual cm "black"))
-	 (xft-blue (scx-xft-color-alloc-name dpy visual cm "blue")))
+	 (xft-white (scx-xft-color-alloc-name dpy visual cm "white"))
-
+	 (standard-font (open-font dpy screen (make-xft-pattern))))
-    (scx-xft-pattern-print (xft-font-pattern font))
-    (scx-xft-pattern-print (xft-font-pattern font2))
 
     (set-window-colormap! dpy win cm)
-    (set-wm-name! dpy win (string-list->property '("scx Hello World Program")))
+    (set-wm-name! dpy win (string-list->property '("scx Xft Demo Program")))
 
     (spawn (lambda ()
 	     (let loop ((se (most-recent-sync-x-event)))
@@ -47,24 +88,32 @@
     (let ((handler
 	   (lambda (channel)
 	     (map-window dpy win)
-	     (let loop ()
+	     (let loop ((font-patterns (list-all-fonts dpy screen))
+			(font standard-font))
+
 	       (if
 		(let ((e (receive channel)))
 		  (cond
+
+		   ((button-event? e)
+		    (if (null? font-patterns)
+			(loop (list-all-fonts dpy screen) standard-font)
+			(let ((font (open-font dpy screen (car font-patterns))))
+			  (draw-font-name xft-draw xft-black xft-white font)
+			  (loop (cdr font-patterns) font))))
+
 		   ((expose-event? e)
-		    (scx-xft-draw-string-8bit 
+		    (draw-font-name xft-draw xft-black xft-white font))
-		     xft-draw xft-black font 10 65 text)
+
-		    (scx-xft-draw-string-8bit
-		     xft-draw xft-blue font2 10 140 text))
 		   ((motion-event? e) #t)
 		   (else #f)))
-		(loop))))))
+		(loop font-patterns font))))))
       (call-with-event-channel dpy win (event-mask exposure button-press
 						   pointer-motion)
 			       handler)
       (close-display dpy))))
 
-(hello "Hello World!")
+(font-demo)
 
 ,exit