Visualizer kinda works.

Not happy with the code layout though.

diff --git a/mars.scm b/mars.scm
index 7e7334c..40e4ca1 100644 (file)
--- a/mars.scm
+++ b/mars.scm
@@ -2,370 +2,344 @@
 ;;; An implementation of the Memory Array Redcode Simulator (MARS)
 ;;;
 
-(import (chicken io)
-        (chicken string)
-        (chicken random)
-        (chicken condition)
-        (chicken process-context)
-        matchable wish)
-
-
-;;; Instructions
-;;
-
-(define (make-instr opcode modifier A-mode A-num B-mode B-num)
-  (lambda args
-    (match args
-      (('opcode) opcode)
-      (('modifier) modifier)
-      (('A-mode) A-mode)
-      (('A-num) A-num)
-      (('B-mode) B-mode)
-      (('B-num) B-num)
-      (('make-copy) (make-instr opcode modifier A-mode A-num B-mode B-num))
-      (('set! 'opcode x) (set! opcode x))
-      (('set! 'modifier x) (set! modifier x))
-      (('set! 'A-mode x) (set! A-mode x))
-      (('set! 'A-num x) (set! A-num x))
-      (('set! 'B-mode x) (set! B-mode x))
-      (('set! 'B-num x) (set! B-num x))
-      (('set-from! other)
-       (set! opcode (other 'opcode))
-       (set! modifier (other 'modifier))
-       (set! A-mode (other 'A-mode))
-       (set! A-num (other 'A-num))
-       (set! B-mode (other 'B-mode))
-       (set! B-num (other 'B-num)))
-      (('->string)
-       (conc opcode
-             "." modifier
-             " " (mode->string A-mode) A-num
-             " " (mode->string B-mode) B-num))
-      (else
-       (error "Invalid instr arguments" args)))))
-
-(define (mode->string mode)
-  (case mode
-    ((immediate) "#")
-    ((direct) "$")
-    ((indirect-A) "*")
-    ((indirect-B) "@")
-    ((pre-indirect-A) "{")
-    ((pre-indirect-B) "<")
-    ((post-indirect-A) "}")
-    ((post-indirect-B) ">")
-    (else
-     (error "Unknown mode."))))
-
-(define initial-instruction
-  (make-instr 'DAT 'F 'immediate 0 'immediate 0))
-
-
-;;; Memory setup and addressing
-;;
-
-(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)
-      (if (< i 0)
-          (norm-addr (+ i core-size))
-          (modulo i core-size)))
-    (define (norm-ref v i)
-      (vector-ref v (norm-addr i)))
-    (define (norm-set! v i x)
-      (vector-set! v (norm-addr i)
-                   (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))
-        (loop (+ i 1))))
+(module mars
+    (make-instr
+     make-prog
+     prog-name
+     prog-instrs
+     prog-offset
+     install-progs
+     make-queue
+     queue-owner
+     queue-ptrs
+     make-core
+     run-mars)
+
+  (import scheme
+          (chicken base)
+          (chicken io)
+          (chicken string)
+          (chicken random)
+          (chicken condition)
+          (chicken process-context)
+          matchable)
+
+
+  ;;; Instructions
+  ;;
+
+  (define (make-instr opcode modifier A-mode A-num B-mode B-num)
     (lambda args
       (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)
-         (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)
-         (run-set-functions i n))
-        ((i 'set! v x n)
-         ((norm-ref core-vec i) 'set! v x)
-         (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))
-        (('dump)
-         (let loop ((i 0))
-           (unless (>= i core-size)
-             (print* i ":\t" ((vector-ref core-vec i) '->string))
-             (let ((n (vector-ref names-vec i)))
-               (unless (null? n)
-                 (print* "\t;" n)))
-             (print)
-             (loop (+ i 1)))))
-        (('size) core-size)))))
-
-
-;;; Programmes and task queues
-;;
-
-(define (make-prog name instrs offset)
-  (list name instrs offset))
-
-(define (prog-name prog) (list-ref prog 0))
-(define (prog-instrs prog) (list-ref prog 1))
-(define (prog-offset prog) (list-ref prog 2))
-
-(define (install-prog core prog addr)
-  (let loop ((ptr addr)
-             (instrs (prog-instrs prog)))
-    (unless (null? instrs)
-      (core ptr 'set-from-instr! (car instrs) (prog-name prog))
-      (loop (core '->addr (+ ptr 1)) (cdr instrs))))
-  (make-queue (prog-name prog)
-              (core '->addr (+ addr (prog-offset prog)))))
-
-(define (can-install-prog? core prog-len addr)
-  (let loop ((ptr addr)
-             (remaining prog-len))
-    (if (= remaining 0)
-        #t
-        (if (null? (core ptr 'name))
-            (loop (core '->addr (+ ptr 1))
-                  (- remaining 1))
-            #f))))
-
-(define (install-progs core progs)
-  (let loop ((queues '())
-             (progs-left progs))
-    (if (null? progs-left)
-        queues
-        (let ((addr (pseudo-random-integer (core 'size)))
-              (prog (car progs-left)))
-          (if (can-install-prog? core (length (prog-instrs prog)) addr)
-              (loop (cons (install-prog core prog addr) queues)
-                    (cdr progs-left))
-              (loop queues progs-left))))))
-
-(define (make-queue name ptr)
-  (list name ptr))
-
-(define (queue-owner queue) (car queue))
-(define (queue-ptrs queue) (cdr queue))
-
-(define (queue-set-ptrs! queue ptrs)
-  (set-cdr! queue ptrs))
-
-
-;;; Executive function
-;;
-
-(define (run core queues steps-left)
-  (cond
-   ((<= steps-left 0) queues)      ;Tie between remaining players
-   ;; ((<= (length queues) 1) queues) ;There's only one player left who thus wins
-   (else
-    (let* ((queue (car queues))
-           (remaining-queues (cdr queues))
-           (ptrs (queue-ptrs queue))
-           (new-ptrs (execute-instr core (car ptrs) (queue-owner queue))))
-      (if (null? new-ptrs)
-          (run remaining-queues (- steps-left 1))
-          (begin
-            (queue-set-ptrs! queue (append (cdr ptrs) new-ptrs))
-            (run core (append remaining-queues (list queue)) (- steps-left 1))))))))
-
-(define (execute-instr core ptr name)
-  (let* ((A-ptr (eval-operand core (core ptr 'A-mode) (core ptr 'A-num) ptr name))
-         (B-ptr (eval-operand core (core ptr 'B-mode) (core ptr 'B-num) ptr name))
-         (modifier (core ptr 'modifier)))
-    (case (core ptr 'opcode)
-      ((DAT)
-       '()) ;Game over, man, game over!
-      ((MOV)
-       (if (eq? modifier 'I)
-           (core B-ptr 'set-from! A-ptr name)
-           (combine-and-store core A-ptr B-ptr modifier name (lambda (x y) y)))
-       (list (core '->addr (+ ptr 1))))
-      ((ADD)
-       (combine-and-store core A-ptr B-ptr modifier name +)
-       (list (core '->addr (+ ptr 1))))
-      ((SUB)
-       (combine-and-store core A-ptr B-ptr modifier name -)
-       (list (core '->addr (+ ptr 1))))
-      ((MUL)
-       (combine-and-store core A-ptr B-ptr modifier name *)
-       (list (core '->addr (+ ptr 1))))
-      ((DIV)
-       (condition-case 
-           (begin
-             (combine-and-store core A-ptr B-ptr modifier name quotient)
-                                
-             (list (core '->addr (+ ptr 1))))
-         ((exn arithmetic) '())))
-      ((MOD)
-       (condition-case
-           (begin
-             (combine-and-store core A-ptr B-ptr modifier name modulo)
-             (list (core '->addr (+ ptr 1))))
-         ((exn arithmetic) '())))
-      ((JMP)
-       (list (core '->addr (+ ptr (core A-ptr 'A-num)))))
-      ((JMZ)
-       (list (core '->addr (+ ptr (if (instr-zero? B-ptr modifier #f name)
-                                      (core A-ptr 'A-num)
-                                      1)))))
-      ((JMN)
-       (list (core '->addr (+ ptr (if (not (instr-zero? B-ptr modifier #f name))
-                                      (core A-ptr 'A-num)
-                                      1)))))
-      ((DJN)
-       (list (core '->addr (+ ptr (if (not (instr-zero? B-ptr modifier #t name))
-                                      (core A-ptr 'A-num)
-                                      1)))))
-      ((SEQ CMP)
-       (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 2 1)))))
-      ((SNE)
-       (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 1 2)))))
-      ((SLT)
-       (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier <) 2 1)))))
-      ((SPL)
-       (list (core '->addr (+ ptr 1) (core '->addr (+ ptr (core A-ptr 'A-num))))))
-      ((NOP)
-       (list (core '->addr (+ ptr 1))))
+        (('opcode) opcode)
+        (('modifier) modifier)
+        (('A-mode) A-mode)
+        (('A-num) A-num)
+        (('B-mode) B-mode)
+        (('B-num) B-num)
+        (('make-copy) (make-instr opcode modifier A-mode A-num B-mode B-num))
+        (('set! 'opcode x) (set! opcode x))
+        (('set! 'modifier x) (set! modifier x))
+        (('set! 'A-mode x) (set! A-mode x))
+        (('set! 'A-num x) (set! A-num x))
+        (('set! 'B-mode x) (set! B-mode x))
+        (('set! 'B-num x) (set! B-num x))
+        (('set-from! other)
+         (set! opcode (other 'opcode))
+         (set! modifier (other 'modifier))
+         (set! A-mode (other 'A-mode))
+         (set! A-num (other 'A-num))
+         (set! B-mode (other 'B-mode))
+         (set! B-num (other 'B-num)))
+        (('->string)
+         (conc opcode
+               "." modifier
+               " " (mode->string A-mode) A-num
+               " " (mode->string B-mode) B-num))
+        (else
+         (error "Invalid instr arguments" args)))))
+
+  (define (mode->string mode)
+    (case mode
+      ((immediate) "#")
+      ((direct) "$")
+      ((indirect-A) "*")
+      ((indirect-B) "@")
+      ((pre-indirect-A) "{")
+      ((pre-indirect-B) "<")
+      ((post-indirect-A) "}")
+      ((post-indirect-B) ">")
       (else
-       (error "Unrecognised opcode" (instr 'opcode))))))
-
-(define (compare-instrs core A-ptr B-ptr modifier test)
-  (case modifier
-    ((A) (test (core A-ptr 'A-num) (core B-ptr 'A-num)))
-    ((B) (test (core A-ptr 'B-num) (core B-ptr 'B-num)))
-    ((AB) (test (core A-ptr 'A-num) (core B-ptr 'B-num)))
-    ((BA) (test (core A-ptr 'B-num) (core B-ptr 'A-num)))
-    ((F) (and
-          (test (core A-ptr 'A-num) (core B-ptr 'A-num))
-          (test (core A-ptr 'B-num) (core B-ptr 'B-num))))
-    ((X) (and
-          (test (core A-ptr 'A-num) (core B-ptr 'B-num))
-          (test (core A-ptr 'B-num) (core B-ptr 'A-num))))
-    ((I) (and
-          (if (eq? test =)
-              (and
-               (eq? (core A-ptr 'opcode) (core B-ptr 'opcode))
-               (eq? (core A-ptr 'modifier) (core B-ptr 'modifier))
-               (eq? (core A-ptr 'A-mode) (core B-ptr 'B-mode))
-               (eq? (core A-ptr 'B-mode) (core B-ptr 'A-mode)))
-              #t)
-          (test (core A-ptr 'A-num) (core B-ptr 'B-num))
-          (test (core A-ptr 'B-num) (core B-ptr 'A-num))))))
-
-(define (instr-zero? core ptr modifier decrement name)
-  (case modifier
-    ((A AB)
-     (if decrement (core ptr 'set! 'A-num (- (core ptr 'A-num) 1) name))
-     (= 0 (core ptr 'A-num)))
-    ((A AB)
-     (if decrement (core ptr 'set! 'B-num (- (core ptr 'B-num) 1) name))
-     (= 0 (core ptr 'B-num)))
-    ((X I F)
-     (if decrement
-         (begin
-           (core ptr 'set! 'A-num (- (core ptr 'A-num) 1) name)
-           (core ptr 'set! 'B-num (- (core ptr 'B-num) 1) name)))
-     (and (= 0 (core ptr 'A-num))
-          (= 0 (core ptr 'B-num))))))
-
-(define (combine-and-store core A-ptr B-ptr modifier name f)
-  (case modifier
-    ((A) (core B-ptr 'set! 'A-num
-               (f (core B-ptr 'A-num) (core A-ptr 'A-num)) name))
-    ((B) (core B-ptr 'set! 'B-num
-               (f (core B-ptr 'B-num) (core A-ptr 'B-num)) name))
-    ((AB) (core B-ptr 'set! 'B-num
-                (f (core B-ptr 'B-num) (core A-ptr 'A-num)) name))
-    ((BA) (core B-ptr 'set! 'A-num
-                (f (core B-ptr 'A-num) (core A-ptr 'B-num)) name))
-    ((F I) (core B-ptr 'set! 'A-num
-                 (f (core B-ptr 'A-num) (core A-ptr 'A-num)) name)
-           (core B-ptr 'set! 'B-num
+       (error "Unknown mode."))))
+
+
+  ;;; Memory setup and addressing
+  ;;
+
+  (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)
+        (if (< i 0)
+            (norm-addr (+ i core-size))
+            (modulo i core-size)))
+      (define (norm-ref v i)
+        (vector-ref v (norm-addr i)))
+      (define (norm-set! v i x)
+        (vector-set! v (norm-addr i)
+                     (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))
+          (loop (+ i 1))))
+      (lambda args
+        (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)
+           (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)
+           (run-set-functions i n))
+          ((i 'set! v x n)
+           ((norm-ref core-vec i) 'set! v x)
+           (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))
+          (('dump)
+           (let loop ((i 0))
+             (unless (>= i core-size)
+               (print* i ":\t" ((vector-ref core-vec i) '->string))
+               (let ((n (vector-ref names-vec i)))
+                 (unless (null? n)
+                   (print* "\t;" n)))
+               (print)
+               (loop (+ i 1)))))
+          (('size) core-size)))))
+
+
+  ;;; Programmes and task queues
+  ;;
+
+  (define (make-prog name instrs offset)
+    (list name instrs offset))
+
+  (define (prog-name prog) (list-ref prog 0))
+  (define (prog-instrs prog) (list-ref prog 1))
+  (define (prog-offset prog) (list-ref prog 2))
+
+  (define (install-prog core prog addr)
+    (let loop ((ptr addr)
+               (instrs (prog-instrs prog)))
+      (unless (null? instrs)
+        (core ptr 'set-from-instr! (car instrs) (prog-name prog))
+        (loop (core '->addr (+ ptr 1)) (cdr instrs))))
+    (make-queue (prog-name prog)
+                (core '->addr (+ addr (prog-offset prog)))))
+
+  (define (can-install-prog? core prog-len addr)
+    (let loop ((ptr addr)
+               (remaining prog-len))
+      (if (= remaining 0)
+          #t
+          (if (null? (core ptr 'name))
+              (loop (core '->addr (+ ptr 1))
+                    (- remaining 1))
+              #f))))
+
+  (define (install-progs core progs)
+    (let loop ((queues '())
+               (progs-left progs))
+      (if (null? progs-left)
+          queues
+          (let ((addr (pseudo-random-integer (core 'size)))
+                (prog (car progs-left)))
+            (if (can-install-prog? core (length (prog-instrs prog)) addr)
+                (loop (cons (install-prog core prog addr) queues)
+                      (cdr progs-left))
+                (loop queues progs-left))))))
+
+  (define (make-queue name ptr)
+    (list name ptr))
+
+  (define (queue-owner queue) (car queue))
+  (define (queue-ptrs queue) (cdr queue))
+
+  (define (queue-set-ptrs! queue ptrs)
+    (set-cdr! queue ptrs))
+
+
+  ;;; Executive function
+  ;;
+
+  (define (run-mars core queues steps-left)
+    (cond
+     ((<= steps-left 0) queues)      ;Tie between remaining players
+     ;; ((<= (length queues) 1) queues) ;There's only one player left who thus wins
+     (else
+      (let* ((queue (car queues))
+             (remaining-queues (cdr queues))
+             (ptrs (queue-ptrs queue))
+             (new-ptrs (execute-instr core (car ptrs) (queue-owner queue))))
+        (if (null? new-ptrs)
+            (run-mars remaining-queues (- steps-left 1))
+            (begin
+              (queue-set-ptrs! queue (append (cdr ptrs) new-ptrs))
+              (run-mars core (append remaining-queues (list queue)) (- steps-left 1))))))))
+
+  (define (execute-instr core ptr name)
+    (let* ((A-ptr (eval-operand core (core ptr 'A-mode) (core ptr 'A-num) ptr name))
+           (B-ptr (eval-operand core (core ptr 'B-mode) (core ptr 'B-num) ptr name))
+           (modifier (core ptr 'modifier)))
+      (case (core ptr 'opcode)
+        ((DAT)
+         '()) ;Game over, man, game over!
+        ((MOV)
+         (if (eq? modifier 'I)
+             (core B-ptr 'set-from! A-ptr name)
+             (combine-and-store core A-ptr B-ptr modifier name (lambda (x y) y)))
+         (list (core '->addr (+ ptr 1))))
+        ((ADD)
+         (combine-and-store core A-ptr B-ptr modifier name +)
+         (list (core '->addr (+ ptr 1))))
+        ((SUB)
+         (combine-and-store core A-ptr B-ptr modifier name -)
+         (list (core '->addr (+ ptr 1))))
+        ((MUL)
+         (combine-and-store core A-ptr B-ptr modifier name *)
+         (list (core '->addr (+ ptr 1))))
+        ((DIV)
+         (condition-case 
+             (begin
+               (combine-and-store core A-ptr B-ptr modifier name quotient)
+               
+               (list (core '->addr (+ ptr 1))))
+           ((exn arithmetic) '())))
+        ((MOD)
+         (condition-case
+             (begin
+               (combine-and-store core A-ptr B-ptr modifier name modulo)
+               (list (core '->addr (+ ptr 1))))
+           ((exn arithmetic) '())))
+        ((JMP)
+         (list (core '->addr (+ ptr (core A-ptr 'A-num)))))
+        ((JMZ)
+         (list (core '->addr (+ ptr (if (instr-zero? B-ptr modifier #f name)
+                                        (core A-ptr 'A-num)
+                                        1)))))
+        ((JMN)
+         (list (core '->addr (+ ptr (if (not (instr-zero? B-ptr modifier #f name))
+                                        (core A-ptr 'A-num)
+                                        1)))))
+        ((DJN)
+         (list (core '->addr (+ ptr (if (not (instr-zero? B-ptr modifier #t name))
+                                        (core A-ptr 'A-num)
+                                        1)))))
+        ((SEQ CMP)
+         (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 2 1)))))
+        ((SNE)
+         (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 1 2)))))
+        ((SLT)
+         (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier <) 2 1)))))
+        ((SPL)
+         (list (core '->addr (+ ptr 1) (core '->addr (+ ptr (core A-ptr 'A-num))))))
+        ((NOP)
+         (list (core '->addr (+ ptr 1))))
+        (else
+         (error "Unrecognised opcode" (core ptr 'opcode))))))
+
+  (define (compare-instrs core A-ptr B-ptr modifier test)
+    (case modifier
+      ((A) (test (core A-ptr 'A-num) (core B-ptr 'A-num)))
+      ((B) (test (core A-ptr 'B-num) (core B-ptr 'B-num)))
+      ((AB) (test (core A-ptr 'A-num) (core B-ptr 'B-num)))
+      ((BA) (test (core A-ptr 'B-num) (core B-ptr 'A-num)))
+      ((F) (and
+            (test (core A-ptr 'A-num) (core B-ptr 'A-num))
+            (test (core A-ptr 'B-num) (core B-ptr 'B-num))))
+      ((X) (and
+            (test (core A-ptr 'A-num) (core B-ptr 'B-num))
+            (test (core A-ptr 'B-num) (core B-ptr 'A-num))))
+      ((I) (and
+            (if (eq? test =)
+                (and
+                 (eq? (core A-ptr 'opcode) (core B-ptr 'opcode))
+                 (eq? (core A-ptr 'modifier) (core B-ptr 'modifier))
+                 (eq? (core A-ptr 'A-mode) (core B-ptr 'B-mode))
+                 (eq? (core A-ptr 'B-mode) (core B-ptr 'A-mode)))
+                #t)
+            (test (core A-ptr 'A-num) (core B-ptr 'B-num))
+            (test (core A-ptr 'B-num) (core B-ptr 'A-num))))))
+
+  (define (instr-zero? core ptr modifier decrement name)
+    (case modifier
+      ((A AB)
+       (if decrement (core ptr 'set! 'A-num (- (core ptr 'A-num) 1) name))
+       (= 0 (core ptr 'A-num)))
+      ((A AB)
+       (if decrement (core ptr 'set! 'B-num (- (core ptr 'B-num) 1) name))
+       (= 0 (core ptr 'B-num)))
+      ((X I F)
+       (if decrement
+           (begin
+             (core ptr 'set! 'A-num (- (core ptr 'A-num) 1) name)
+             (core ptr 'set! 'B-num (- (core ptr 'B-num) 1) name)))
+       (and (= 0 (core ptr 'A-num))
+            (= 0 (core ptr 'B-num))))))
+
+  (define (combine-and-store core A-ptr B-ptr modifier name f)
+    (case modifier
+      ((A) (core B-ptr 'set! 'A-num
+                 (f (core B-ptr 'A-num) (core A-ptr 'A-num)) name))
+      ((B) (core B-ptr 'set! 'B-num
                  (f (core B-ptr 'B-num) (core A-ptr 'B-num)) name))
-    ((X) (core B-ptr 'set! 'A-num
-               (f (core B-ptr 'A-num) (core A-ptr 'B-num)) name)
-         (core B-ptr 'set! 'B-num
-               (f (core B-ptr 'B-num) (core A-ptr 'A-num)) name))))
-
-(define (eval-operand core mode num ptr name)
-  (core '->addr (+ ptr
-                   (case mode
-                     ((immediate) 0)
-                     ((direct) num)
-                     ((indirect-A) (+ num (core (+ ptr num) 'A-num)))
-                     ((indirect-B) (+ num (core (+ ptr num) 'B-num)))
-                     ((pre-indirect-A)
-                      (let ((aux-ptr (+ ptr num)))
-                        (core aux-ptr 'set! 'A-num (- (core aux-ptr 'A-num) 1) name)
-                        (+ num (core aux-ptr 'A-num))))
-                     ((pre-indirect-B)
-                      (let ((aux-ptr (+ ptr num)))
-                        (core aux-ptr 'set! 'B-num (- (core aux-ptr 'B-num) 1) name)
-                        (+ num (core aux-ptr 'B-num))))
-                     ((post-indirect-A)
-                      (let* ((aux-ptr (+ ptr num))
-                             (old-A-num (core aux-ptr 'A-num)))
-                        (core aux-ptr 'set! 'A-num (+ (core aux-ptr 'A-num) 1) name)
-                        (+ num old-A-num)))
-                     ((post-indirect-B)
-                      (let* ((aux-ptr (+ ptr num))
-                             (old-B-num (core aux-ptr 'B-num)))
-                        (core aux-ptr 'set! 'B-num (+ (core aux-ptr 'B-num) 1) name)
-                        (+ num old-B-num)))
-                     (else
-                      (error "Unrecognized mode" mode))))))
-
-;;; Main procedure
-;; 
-
-;;; TEST CODE
-
-(define addressing-test
-  (make-prog 'at (list
-                   (make-instr 'DAT 'F 'immediate 42 'immediate 53)
-                   (make-instr 'DAT 'F 'immediate 123 'immediate 256)
-                   (make-instr 'MOV 'A 'indirect-B 4 'direct 7)
-                   (make-instr 'NOP 'I 'immediate 0 'immediate 0)
-                   (make-instr 'NOP 'I 'immediate 0 'immediate 0)
-                   (make-instr 'NOP 'I 'immediate 0 'immediate 0)
-                   (make-instr 'DAT 'F 'immediate -5 'immediate -6)) 2))
-
-(define imp
-  (make-prog 'imp (list (make-instr 'MOV 'I 'direct 0 'direct 1)) 0))
-
-(define dwarf
-  (make-prog 'dwarf (list
-                     (make-instr 'DAT 'F 'immediate 0 'immediate -1)
-                     (make-instr 'ADD 'AB 'immediate 5 'direct -1)
-                     (make-instr 'MOV 'I 'direct -2 'indirect-B -2)
-                     (make-instr 'JMP 'I 'immediate -2 'immediate 0)) 1))
-
-(define palette '((imp . "red")
-                  (dwarf . "blue")))
-
-(define w (make-wish 640 480 palette))
-
-(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 palette))))))
-(define queues (install-progs core (list dwarf imp)))
+      ((AB) (core B-ptr 'set! 'B-num
+                  (f (core B-ptr 'B-num) (core A-ptr 'A-num)) name))
+      ((BA) (core B-ptr 'set! 'A-num
+                  (f (core B-ptr 'A-num) (core A-ptr 'B-num)) name))
+      ((F I) (core B-ptr 'set! 'A-num
+                   (f (core B-ptr 'A-num) (core A-ptr 'A-num)) name)
+       (core B-ptr 'set! 'B-num
+             (f (core B-ptr 'B-num) (core A-ptr 'B-num)) name))
+      ((X) (core B-ptr 'set! 'A-num
+                 (f (core B-ptr 'A-num) (core A-ptr 'B-num)) name)
+       (core B-ptr 'set! 'B-num
+             (f (core B-ptr 'B-num) (core A-ptr 'A-num)) name))))
+
+  (define (eval-operand core mode num ptr name)
+    (core '->addr (+ ptr
+                     (case mode
+                       ((immediate) 0)
+                       ((direct) num)
+                       ((indirect-A) (+ num (core (+ ptr num) 'A-num)))
+                       ((indirect-B) (+ num (core (+ ptr num) 'B-num)))
+                       ((pre-indirect-A)
+                        (let ((aux-ptr (+ ptr num)))
+                          (core aux-ptr 'set! 'A-num (- (core aux-ptr 'A-num) 1) name)
+                          (+ num (core aux-ptr 'A-num))))
+                       ((pre-indirect-B)
+                        (let ((aux-ptr (+ ptr num)))
+                          (core aux-ptr 'set! 'B-num (- (core aux-ptr 'B-num) 1) name)
+                          (+ num (core aux-ptr 'B-num))))
+                       ((post-indirect-A)
+                        (let* ((aux-ptr (+ ptr num))
+                               (old-A-num (core aux-ptr 'A-num)))
+                          (core aux-ptr 'set! 'A-num (+ (core aux-ptr 'A-num) 1) name)
+                          (+ num old-A-num)))
+                       ((post-indirect-B)
+                        (let* ((aux-ptr (+ ptr num))
+                               (old-B-num (core aux-ptr 'B-num)))
+                          (core aux-ptr 'set! 'B-num (+ (core aux-ptr 'B-num) 1) name)
+                          (+ num old-B-num)))
+                       (else
+                        (error "Unrecognized mode" mode)))))))
 

diff --git a/parse.scm b/parse.scm
new file mode 100644 (file)
index 0000000..c2bec6a
--- /dev/null
+++ b/parse.scm
@@ -0,0 +1,34 @@
+(import (chicken irregex))
+
+(define (string->instr str)
+  (let ((idx 0)
+        (l (string-length str))
+        (whitespace-irx (irregex "[ \t]*"))
+        (newline-irx (irregex "\n"))
+        (comment-irx (irregex ";[^\n]*")))
+    (define (accept-token irx mandatory)
+      (let ((wsmatch (irregex-match whitespace-irx (substr str idx))))
+        (set! idx (+ idx (irregex-match-end-index wsmatch)))) ;Skip leading whitespace
+      (let ((res (irregex-match irx (substring str idx))))
+        (if res
+            (begin
+              (set! idx (+ idx (irregex-match-end-index res)))
+              (irregex-match-substring res))
+            (if mandatory
+                (error "Unexpected token at input string index" idx)
+                #f))))
+    (define (accept-token-string token-str mandatory)
+      (accept-token (irregex token-str) mandatory))
+    (define (load-file)
+      (let loop ()
+        (if (line)
+            (loop))))
+    (define (line)
+      (or (accept-token comment-irx #f)
+          (accept-token newline-irx #f)
+          (and(accept-token newline-irx #t))))
+    (define (instruction)
+      (and (opcode)
+           (accept-token period-irx #t)
+           (accept-modifier)))))
+               

diff --git a/test.scm b/test.scm
new file mode 100644 (file)
index 0000000..090c941
--- /dev/null
+++ b/test.scm
@@ -0,0 +1,34 @@
+(import mars visualizer)
+
+(define addressing-test
+  (make-prog 'at (list
+                  (make-instr 'DAT 'F 'immediate 42 'immediate 53)
+                  (make-instr 'DAT 'F 'immediate 123 'immediate 256)
+                  (make-instr 'MOV 'A 'indirect-B 4 'direct 7)
+                  (make-instr 'NOP 'I 'immediate 0 'immediate 0)
+                  (make-instr 'NOP 'I 'immediate 0 'immediate 0)
+                  (make-instr 'NOP 'I 'immediate 0 'immediate 0)
+                  (make-instr 'DAT 'F 'immediate -5 'immediate -6)) 2))
+
+(define imp
+  (make-prog 'imp (list (make-instr 'MOV 'I 'direct 0 'direct 1)) 0))
+
+(define dwarf
+  (make-prog 'dwarf (list
+                     (make-instr 'DAT 'F 'immediate 0 'immediate -1)
+                     (make-instr 'ADD 'AB 'immediate 5 'direct -1)
+                     (make-instr 'MOV 'I 'direct -2 'indirect-B -2)
+                     (make-instr 'JMP 'I 'immediate -2 'immediate 0)) 1))
+
+(define palette '((imp . "red")
+                  (dwarf . "blue")))
+
+(define vis (make-vis 640 480 8000 palette))
+
+(define core (make-core 8000 (make-instr 'DAT 'F 'immediate 0 'immediate 0)
+                        (lambda (i n)
+                          (vis 'update-owner i n))))
+
+(define queues (install-progs core (list dwarf imp)))
+
+;; (run-mars core queues 10000)

diff --git a/visualizer.scm b/visualizer.scm
new file mode 100644 (file)
index 0000000..8215202
--- /dev/null
+++ b/visualizer.scm
@@ -0,0 +1,72 @@
+;; Visualization module
+
+(module visualizer
+    (make-vis)
+
+  (import scheme
+          (chicken base)
+          (chicken io)
+          (chicken process)
+          (chicken port)
+          (chicken string)
+          srfi-1 matchable)
+
+  (define (make-vis target-width target-height core-size palette)
+    ;; (let-values (((in out id) (process (conc "wish -geometry " w "x" h)))))
+    (let-values (((in out id) (process "wish")))
+      (define (wish% . args)
+        (with-output-to-port out
+          (lambda ()
+            (apply print args))))
+      (wish% "wm title . \"MARS Visualizer\"")
+      (wish% "frame .fb -borderwidth 10")
+      (wish% "pack .fb -side top")
+      (let loop ((remaining-palette palette))
+        (unless (null? remaining-palette)
+          (let ((name (caar remaining-palette))
+                (col (cdar remaining-palette)))
+            (wish% "label .fb.l" name " -text " name " -fg " col)
+            (wish% "pack .fb.l" name " -side left"))
+          (loop (cdr remaining-palette))))
+      (wish% "frame .fc -relief sunken -borderwidth 2")
+      (wish% "pack .fc -side bottom")
+      (let* ((aspect-ratio (/ target-width target-height))
+             (core-width (inexact->exact (round (sqrt (* aspect-ratio core-size)))))
+             (core-height (inexact->exact (ceiling (/ core-size core-width))))
+             (cell-width (inexact->exact (round (/ target-width core-width))))
+             (cell-height (inexact->exact (round (/ target-height core-height))))
+             (w (* cell-width core-width))
+             (h (* cell-height core-height)))
+        (wish% "canvas .fc.c -width " w " -height " h " -bg black")
+        (wish% "pack .fc.c")
+        (wish% "image create photo core -width " w " -height " h " -palette 256/256/256")
+        (wish% ".fc.c create image 0 0 -anchor nw -image core")
+        (let loop ((xi (- (* core-height core-width) 1)))
+          (unless (< xi (modulo core-size core-width))
+            (wish% "core put grey -to "
+                   (* cell-width xi) " " (* cell-height (- core-height 1))
+                   " " (* cell-width (+ xi 1)) (* cell-height core-height))
+            (loop (- xi 1))))
+        (lambda args
+          (match args
+            (('wish args ...) (apply wish% args))
+            (('destroy) (wish% "destroy ."))
+            (('update-owner addr name)
+             (let ((xi (modulo addr core-width))
+                   (yi (quotient addr core-width)))
+               ;; (print "core width: " core-width)
+               ;; (print "core height: " core-height)
+               ;; (print "cell width: " cell-width)
+               ;; (print "cell height: " cell-height)
+               ;; (print "xi: " xi " yi: " yi)
+               ;; (print "col: " (cdr (assoc name palette)))
+               (wish% "core put " (cdr (assoc name palette))
+                      " -to " (* cell-width xi) " " (* cell-height yi)
+                      " " (* cell-width (+ xi 1)) " " (* cell-height (+ yi 1)))))))))))
+                      
+
+;; Test code
+
+;; (import visualizer)
+;; (define v (make-vis 640 480 8000 '((imp . "blue") (dwarf . "red"))))
+

diff --git a/wish.scm b/wish.scm
deleted file mode 100644 (file)
index b06e1d8..0000000
--- a/wish.scm
+++ /dev/null
@@ -1,59 +0,0 @@
-;; 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)))