From: plugd <plugd@thelambdalab.xyz>
Date: Wed, 20 Nov 2019 15:01:56 +0000 (+0100)
Subject: Added basic visualization.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=80272dcf66d5e333302fa310c4c346d6af5d503c;p=jars.git

Added basic visualization.
---

diff --git a/mars.scm b/mars.scm
index e76a032..caccfa1 100644
--- a/mars.scm
+++ b/mars.scm
@@ -7,7 +7,7 @@
         (chicken random)
         (chicken condition)
         (chicken process-context)
-        matchable)
+        matchable wish)
 
 
 ;;; Instructions
@@ -64,7 +64,7 @@
 ;;; Memory setup and addressing
 ;;
 
-(define (make-core core-size initial-instr)
+(define (make-core core-size initial-instr . set-functions)
   (let ((core-vec (make-vector core-size '()))
         (names-vec (make-vector core-size '())))
     (define (norm-addr i)
@@ -78,6 +78,10 @@
                    (if (integer? x)
                        (norm-addr x)
                        x)))
+    (define (run-set-functions i n)
+      (let loop ((remaining-fns set-functions))
+        (unless (null? remaining-fns)
+          ((car remaining-fns) i n))))
     (let loop ((i 0))
       (unless (>= i core-size)
         (vector-set! core-vec i (initial-instr 'make-copy))
@@ -86,13 +90,16 @@
       (match args
         ((i 'set-from! j n)
          ((norm-ref core-vec i) 'set-from! (norm-ref core-vec j))
-         (norm-set! names-vec i n))
+         (norm-set! names-vec i n)
+         (run-set-functions i n))
         ((i 'set-from-instr! instr n)
          ((norm-ref core-vec i) 'set-from! instr)
-         (norm-set! names-vec i n))
+         (norm-set! names-vec i n)
+         (run-set-functions i n))
         ((i 'set! v x n)
          ((norm-ref core-vec i) 'set! v x)
-         (norm-set! names-vec i n))
+         (norm-set! names-vec i n)
+         (run-set-functions i n))
         ((i 'name) (norm-ref names-vec i))
         (((? integer? i) v) ((norm-ref core-vec i) v))
         (('->addr (? integer? i)) (norm-addr i))
@@ -349,5 +356,15 @@
                      (make-instr 'MOV 'I 'direct -2 'indirect-B -2)
                      (make-instr 'JMP 'I 'immediate -2 'immediate 0)) 1))
 
-(define core (make-core 20 (make-instr 'DAT 'F 'immediate 0 'immediate 0)))
+(define w (make-wish 640 480))
+(define colours '((imp . "red")
+                  (dwarf . "blue")))
+
+(define core (make-core (* 640 480) (make-instr 'DAT 'F 'immediate 0 'immediate 0)
+                        (lambda (i n)
+                          (set-wish-pixel w
+                                          (remainder i 640)
+                                          (quotient i 640)
+                                          (cdr (assoc n colours))))))
 (define queues (install-progs core (list dwarf imp)))
+
diff --git a/vis.scm b/wish.scm
similarity index 100%
rename from vis.scm
rename to wish.scm