1 ;; Wish visualization module
15 (define (make-wish w h palette)
16 (let-values (((in out id) (process (conc "wish -geometry " w "x" h))))
17 (with-output-to-port out
19 (print "wm title . \"MARS Visualizer\"")
20 (print "frame .fb -borderwidth 10")
21 (print "pack .fb -side top")
22 (let loop ((remaining-palette palette))
23 (unless (null? remaining-palette)
24 (let ((name (caar remaining-palette))
25 (col (cdar remaining-palette)))
26 (print "label .fb.l" name " -text " name " -fg " col)
27 (print "pack .fb.l" name " -side left"))
28 (loop (cdr remaining-palette))))
29 (print "frame .fc -relief sunken -borderwidth 2")
30 (print "pack .fc -side bottom")
31 (print "canvas .fc.c -width " w " -height " h " -bg black")
33 (print "image create photo core -width " w " -height " h " -palette 256/256/256")
34 (print ".fc.c create image 0 0 -anchor nw -image core")))
37 (define (wish-in wish) (car wish))
38 (define (wish-out wish) (cdr wish))
40 (define (wish% wish . args)
41 (with-output-to-port (wish-out wish)
45 (define (destroy-wish wish)
46 (wish% wish "destroy .")
47 (close-input-port (wish-in wish))
48 (close-output-port (wish-out wish)))
50 (define (set-wish-pixel wish x y col)
51 (wish% wish "core put " col " -to " x " " y)))
56 ;; (let ((w (make-wish 640 480)))
57 ;; (set-wish-pixel w 10 10 "red")