X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=jars.git;a=blobdiff_plain;f=wish.scm;fp=wish.scm;h=d8a45a5d0aa6aa82dcec34625d19174f2d4806b8;hp=0000000000000000000000000000000000000000;hb=80272dcf66d5e333302fa310c4c346d6af5d503c;hpb=402486b539f041dc0b8b56933cbeeb637ed7cd92

diff --git a/wish.scm b/wish.scm
new file mode 100644
index 0000000..d8a45a5
--- /dev/null
+++ b/wish.scm
@@ -0,0 +1,47 @@
+;; 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)
+    (let-values (((in out id) (process (conc "wish -geometry " w "x" h))))
+      (with-output-to-port out
+        (lambda ()
+          (print "canvas .c -width " w " -height " h " -bg black")
+          (print "pack .c")
+          (print "image create photo core -width " w " -height " h " -palette 256/256/256")
+          (print ".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)))