Visualizer kinda works.

[jars.git] / visualizer.scm

diff --git a/visualizer.scm b/visualizer.scm
new file mode 100644 (file)
index 0000000..8215202
--- /dev/null
+++ b/visualizer.scm
@@ -0,0 +1,72 @@
+;; Visualization module
+
+(module visualizer
+    (make-vis)
+
+  (import scheme
+          (chicken base)
+          (chicken io)
+          (chicken process)
+          (chicken port)
+          (chicken string)
+          srfi-1 matchable)
+
+  (define (make-vis target-width target-height core-size palette)
+    ;; (let-values (((in out id) (process (conc "wish -geometry " w "x" h)))))
+    (let-values (((in out id) (process "wish")))
+      (define (wish% . args)
+        (with-output-to-port out
+          (lambda ()
+            (apply print args))))
+      (wish% "wm title . \"MARS Visualizer\"")
+      (wish% "frame .fb -borderwidth 10")
+      (wish% "pack .fb -side top")
+      (let loop ((remaining-palette palette))
+        (unless (null? remaining-palette)
+          (let ((name (caar remaining-palette))
+                (col (cdar remaining-palette)))
+            (wish% "label .fb.l" name " -text " name " -fg " col)
+            (wish% "pack .fb.l" name " -side left"))
+          (loop (cdr remaining-palette))))
+      (wish% "frame .fc -relief sunken -borderwidth 2")
+      (wish% "pack .fc -side bottom")
+      (let* ((aspect-ratio (/ target-width target-height))
+             (core-width (inexact->exact (round (sqrt (* aspect-ratio core-size)))))
+             (core-height (inexact->exact (ceiling (/ core-size core-width))))
+             (cell-width (inexact->exact (round (/ target-width core-width))))
+             (cell-height (inexact->exact (round (/ target-height core-height))))
+             (w (* cell-width core-width))
+             (h (* cell-height core-height)))
+        (wish% "canvas .fc.c -width " w " -height " h " -bg black")
+        (wish% "pack .fc.c")
+        (wish% "image create photo core -width " w " -height " h " -palette 256/256/256")
+        (wish% ".fc.c create image 0 0 -anchor nw -image core")
+        (let loop ((xi (- (* core-height core-width) 1)))
+          (unless (< xi (modulo core-size core-width))
+            (wish% "core put grey -to "
+                   (* cell-width xi) " " (* cell-height (- core-height 1))
+                   " " (* cell-width (+ xi 1)) (* cell-height core-height))
+            (loop (- xi 1))))
+        (lambda args
+          (match args
+            (('wish args ...) (apply wish% args))
+            (('destroy) (wish% "destroy ."))
+            (('update-owner addr name)
+             (let ((xi (modulo addr core-width))
+                   (yi (quotient addr core-width)))
+               ;; (print "core width: " core-width)
+               ;; (print "core height: " core-height)
+               ;; (print "cell width: " cell-width)
+               ;; (print "cell height: " cell-height)
+               ;; (print "xi: " xi " yi: " yi)
+               ;; (print "col: " (cdr (assoc name palette)))
+               (wish% "core put " (cdr (assoc name palette))
+                      " -to " (* cell-width xi) " " (* cell-height yi)
+                      " " (* cell-width (+ xi 1)) " " (* cell-height (+ yi 1)))))))))))
+                      
+
+;; Test code
+
+;; (import visualizer)
+;; (define v (make-vis 640 480 8000 '((imp . "blue") (dwarf . "red"))))
+