Improved visualization.

diff --git a/mars.scm b/mars.scm
index caccfa1..7e7334c 100644 (file)
--- a/mars.scm
+++ b/mars.scm
@@ -356,15 +356,16 @@
                      (make-instr 'MOV 'I 'direct -2 'indirect-B -2)
                      (make-instr 'JMP 'I 'immediate -2 'immediate 0)) 1))
 
-(define w (make-wish 640 480))
-(define colours '((imp . "red")
+(define palette '((imp . "red")
                   (dwarf . "blue")))
 
+(define w (make-wish 640 480 palette))
+
 (define core (make-core (* 640 480) (make-instr 'DAT 'F 'immediate 0 'immediate 0)
                         (lambda (i n)
                           (set-wish-pixel w
                                           (remainder i 640)
                                           (quotient i 640)
-                                          (cdr (assoc n colours))))))
+                                          (cdr (assoc n palette))))))
 (define queues (install-progs core (list dwarf imp)))
 

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))
 
-  (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))