1 ;; Visualization module
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
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")
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))
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)))))))))))
71 ;; (import visualizer)
72 ;; (define v (make-vis 640 480 8000 '((imp . "blue") (dwarf . "red"))))