scsh-conservatory
/
scx
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

The all new, all fancy Xft demo program

This commit is contained in:
eknauel 2003-10-27 07:49:43 +00:00
parent 6097628ca7
commit 4bdbd7e168
1 changed files with 65 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

81
scheme/examples/hello-xft.scm
View File

@ -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")))
(scx-xft-pattern-print (xft-font-pattern font))
(scx-xft-pattern-print (xft-font-pattern font2))
(xft-white (scx-xft-color-alloc-name dpy visual cm "white"))
(standard-font (open-font dpy screen (make-xft-pattern))))
(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
xft-draw xft-black font 10 65 text)
(scx-xft-draw-string-8bit
xft-draw xft-blue font2 10 140 text))
(draw-font-name xft-draw xft-black xft-white font))
((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