;; Wish visualization module (module wish (make-wish destroy-wish set-wish-pixel) (import scheme (chicken base) (chicken io) (chicken process) (chicken port) (chicken string)) (define (make-wish w h palette) (let-values (((in out id) (process (conc "wish -geometry " w "x" h)))) (with-output-to-port out (lambda () (print "wm title . \"MARS Visualizer\"") (print "frame .fb -borderwidth 10") (print "pack .fb -side top") (let loop ((remaining-palette palette)) (unless (null? remaining-palette) (let ((name (caar remaining-palette)) (col (cdar remaining-palette))) (print "label .fb.l" name " -text " name " -fg " col) (print "pack .fb.l" name " -side left")) (loop (cdr remaining-palette)))) (print "frame .fc -relief sunken -borderwidth 2") (print "pack .fc -side bottom") (print "canvas .fc.c -width " w " -height " h " -bg black") (print "pack .fc.c") (print "image create photo core -width " w " -height " h " -palette 256/256/256") (print ".fc.c create image 0 0 -anchor nw -image core"))) (cons in out))) (define (wish-in wish) (car wish)) (define (wish-out wish) (cdr wish)) (define (wish% wish . args) (with-output-to-port (wish-out wish) (lambda () (apply print args)))) (define (destroy-wish wish) (wish% wish "destroy .") (close-input-port (wish-in wish)) (close-output-port (wish-out wish))) (define (set-wish-pixel wish x y col) (wish% wish "core put " col " -to " x " " y))) ;; ;; Test code ;; (let ((w (make-wish 640 480))) ;; (set-wish-pixel w 10 10 "red") ;; (sleep 3) ;; (destroy-wish w)))