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

modified to match the new interface.

This commit is contained in:
frese 2003-03-13 13:48:22 +00:00
parent fa5085eccf
commit 9748014efe
1 changed files with 50 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

92
scheme/examples/hello.scm
View File

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