visualizer.scm

   1 ;; Visualization module
   2
   3 (module visualizer
   4     (make-vis)
   5
   6   (import scheme
   7           (chicken base)
   8           (chicken io)
   9           (chicken process)
  10           (chicken port)
  11           (chicken string)
  12           srfi-1 matchable)
  13
  14   (define (make-vis target-width target-height core-size palette)
  15     ;; (let-values (((in out id) (process (conc "wish -geometry " w "x" h)))))
  16     (let-values (((in out id) (process "wish")))
  17       (define (wish% . args)
  18         (with-output-to-port out
  19           (lambda ()
  20             (apply print args))))
  21       (wish% "wm title . \"MARS Visualizer\"")
  22       (wish% "wm attributes . -topmost true")
  23       (wish% "frame .fb -borderwidth 10")
  24       (wish% "pack .fb -side top")
  25       (let loop ((remaining-palette palette))
  26         (unless (null? remaining-palette)
  27           (let ((name (caar remaining-palette))
  28                 (col (cdar remaining-palette)))
  29             (wish% "label .fb.l" col " -text \"" name "\" -fg " col)
  30             (wish% "pack .fb.l" col " -side left"))
  31           (loop (cdr remaining-palette))))
  32       (wish% "frame .fc -relief sunken -borderwidth 2")
  33       (wish% "pack .fc -side bottom")
  34       (let* ((aspect-ratio (/ target-width target-height))
  35              (core-width (inexact->exact (round (sqrt (* aspect-ratio core-size)))))
  36              (core-height (inexact->exact (ceiling (/ core-size core-width))))
  37              (cell-width (inexact->exact (round (/ target-width core-width))))
  38              (cell-height (inexact->exact (round (/ target-height core-height))))
  39              (w (* cell-width core-width))
  40              (h (* cell-height core-height)))
  41         (wish% "canvas .fc.c -width " w " -height " h " -bg black")
  42         (wish% "pack .fc.c")
  43         (wish% "image create photo core -width " w " -height " h " -palette 256/256/256")
  44         (wish% ".fc.c create image 0 0 -anchor nw -image core")
  45         (let loop ((xi (- (* core-height core-width) 1)))
  46           (unless (< xi (modulo core-size core-width))
  47             (wish% "core put grey -to "
  48                    (* cell-width xi) " " (* cell-height (- core-height 1))
  49                    " " (* cell-width (+ xi 1)) (* cell-height core-height))
  50             (loop (- xi 1))))
  51         (lambda args
  52           (match args
  53             (('wish args ...) (apply wish% args))
  54             (('destroy) (wish% "destroy ."))
  55             (('update-owner addr name)
  56              (let ((xi (modulo addr core-width))
  57                    (yi (quotient addr core-width)))
  58                ;; (print "core width: " core-width)
  59                ;; (print "core height: " core-height)
  60                ;; (print "cell width: " cell-width)
  61                ;; (print "cell height: " cell-height)
  62                ;; (print "xi: " xi " yi: " yi)
  63                ;; (print "col: " (cdr (assoc name palette)))
  64                (wish% "core put " (cdr (assoc name palette))
  65                       " -to " (* cell-width xi) " " (* cell-height yi)
  66                       " " (* cell-width (+ xi 1)) " " (* cell-height (+ yi 1)))))))))))
  67
  68
  69 ;; Test code
  70
  71 ;; (import visualizer)
  72 ;; (define v (make-vis 640 480 8000 '((imp . "blue") (dwarf . "red"))))
  73