X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=jars.git;a=blobdiff_plain;f=wish.scm;h=b06e1d81a0dd108aad9b9d224171abc5f8ac5c75;hp=d8a45a5d0aa6aa82dcec34625d19174f2d4806b8;hb=0dd1d148e53122a31f3cd6f4f440f43e03ba80c5;hpb=80272dcf66d5e333302fa310c4c346d6af5d503c

diff --git a/wish.scm b/wish.scm
index d8a45a5..b06e1d8 100644
--- a/wish.scm
+++ b/wish.scm
@@ -12,14 +12,26 @@
           (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 ()
-          (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 ".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))