;; 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% "wm attributes . -topmost true") (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"))))