Improved visualization.

[jars.git] / wish.scm

diff --git a/wish.scm b/wish.scm
index d8a45a5..b06e1d8 100644 (file)
--- a/wish.scm
+++ b/wish.scm
@@ -12,14 +12,26 @@
           (chicken port)
           (chicken string))
 
           (chicken port)
           (chicken string))
 

-  (define (make-wish w h)
+  (define (make-wish w h palette)

     (let-values (((in out id) (process (conc "wish -geometry " w "x" h))))
       (with-output-to-port out
         (lambda ()
     (let-values (((in out id) (process (conc "wish -geometry " w "x" h))))
       (with-output-to-port out
         (lambda ()

-          (print "canvas .c -width " w " -height " h " -bg black")
-          (print "pack .c")
+          (print "wm title . \"MARS Visualizer\"")
+          (print "frame .fb -borderwidth 10")
+          (print "pack .fb -side top")
+          (let loop ((remaining-palette palette))
+            (unless (null? remaining-palette)
+              (let ((name (caar remaining-palette))
+                    (col (cdar remaining-palette)))
+                (print "label .fb.l" name " -text " name " -fg " col)
+                (print "pack .fb.l" name " -side left"))
+              (loop (cdr remaining-palette))))
+          (print "frame .fc -relief sunken -borderwidth 2")
+          (print "pack .fc -side bottom")
+          (print "canvas .fc.c -width " w " -height " h " -bg black")
+          (print "pack .fc.c")

           (print "image create photo core -width " w " -height " h " -palette 256/256/256")
           (print "image create photo core -width " w " -height " h " -palette 256/256/256")

-          (print ".c create image 0 0 -anchor nw -image core")))
+          (print ".fc.c create image 0 0 -anchor nw -image core")))

       (cons in out)))
 
   (define (wish-in wish) (car wish))
       (cons in out)))
 
   (define (wish-in wish) (car wish))