wish.scm

   1 ;; Wish visualization module
   2
   3 (module wish
   4     (make-wish
   5      destroy-wish
   6      set-wish-pixel)
   7
   8   (import scheme
   9           (chicken base)
  10           (chicken io)
  11           (chicken process)
  12           (chicken port)
  13           (chicken string))
  14
  15   (define (make-wish w h palette)
  16     (let-values (((in out id) (process (conc "wish -geometry " w "x" h))))
  17       (with-output-to-port out
  18         (lambda ()
  19           (print "wm title . \"MARS Visualizer\"")
  20           (print "frame .fb -borderwidth 10")
  21           (print "pack .fb -side top")
  22           (let loop ((remaining-palette palette))
  23             (unless (null? remaining-palette)
  24               (let ((name (caar remaining-palette))
  25                     (col (cdar remaining-palette)))
  26                 (print "label .fb.l" name " -text " name " -fg " col)
  27                 (print "pack .fb.l" name " -side left"))
  28               (loop (cdr remaining-palette))))
  29           (print "frame .fc -relief sunken -borderwidth 2")
  30           (print "pack .fc -side bottom")
  31           (print "canvas .fc.c -width " w " -height " h " -bg black")
  32           (print "pack .fc.c")
  33           (print "image create photo core -width " w " -height " h " -palette 256/256/256")
  34           (print ".fc.c create image 0 0 -anchor nw -image core")))
  35       (cons in out)))
  36
  37   (define (wish-in wish) (car wish))
  38   (define (wish-out wish) (cdr wish))
  39
  40   (define (wish% wish . args)
  41     (with-output-to-port (wish-out wish)
  42       (lambda ()
  43         (apply print args))))
  44
  45   (define (destroy-wish wish)
  46     (wish% wish "destroy .")
  47     (close-input-port (wish-in wish))
  48     (close-output-port (wish-out wish)))
  49
  50   (define (set-wish-pixel wish x y col)
  51     (wish% wish "core put " col " -to " x " " y)))
  52
  53
  54   ;; ;; Test code
  55
  56   ;; (let ((w (make-wish 640 480)))
  57   ;;   (set-wish-pixel w 10 10 "red")
  58   ;;   (sleep 3)
  59   ;;   (destroy-wish w)))