From c30656b58f082be264e382d0da5866c4c04a10f7 Mon Sep 17 00:00:00 2001
From: plugd <plugd@thelambdalab.xyz>
Date: Thu, 14 Nov 2019 01:03:04 +0100
Subject: [PATCH 1/1] Initial commit.

---
 mars.scm | 63 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 vis.scm  | 48 ++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 111 insertions(+)
 create mode 100644 mars.scm
 create mode 100644 vis.scm

diff --git a/mars.scm b/mars.scm
new file mode 100644
index 0000000..57e3e13
--- /dev/null
+++ b/mars.scm
@@ -0,0 +1,63 @@
+;;;
+;;; An implementation of the Memory Array Redcode Simulator (MARS)
+;;;
+
+;;; Constants
+;;
+
+(define core-size 8000)
+(define max-steps 10000)
+
+
+;;; Memory setup
+;;
+
+(define core (make-vector core-size '()))
+
+
+;;; Instructions
+;;
+
+(define (make-instr opcode modifier addrA modeA addrB modeB))
+
+
+;;; Players
+;;
+
+(define (make-player name . ptrs)
+  (cons name ptrs))
+
+(define (player-ptrs player)
+  (cdr player))
+
+(define (player-name player)
+  (car player))
+
+(define (player-set-ptrs! player ptrs)
+  (set-cdr! player ptrs))
+
+
+;;; Main loop
+;;
+
+(define (list-rot l)
+  (if (> (length l) 1)
+      (append (cdr l) (list (car l)))
+      l))
+
+(define (run playerA playerB step)
+  (cond
+   ((> step max-steps) 'tie)
+   ((null? (player-ptrs playerA) playerB))
+   ((null? (player-ptrs playerB) playerA))
+   (else
+    (let ((ptrs (player-ptrs playerA)))
+      (player-set-ptrs! (append (cdr ptrs)
+                                (execute-instr (car ptrs)))))
+    (run playerB player A (+ step 1)))))
+
+(define (execute-instr ptr)
+  (let ((instr (vector-ref core ptr)))
+    (match instr
+      ())))
+               
diff --git a/vis.scm b/vis.scm
new file mode 100644
index 0000000..6ae005b
--- /dev/null
+++ b/vis.scm
@@ -0,0 +1,48 @@
+;; Visualization experiments
+
+(import (chicken io)
+        (chicken process)
+        (chicken port)
+        (chicken string))
+
+;; Generic Wish interface
+
+(define wish-in '())
+(define wish-out '())
+
+(define (wish-startup w h)
+  (let-values (((in-port out-port id) (process (conc "wish -geometry " w "x" h))))
+    (set! wish-in in-port)
+    (set! wish-out out-port)))
+
+(define (wish-shutdown)
+  (wish% "destroy .")
+  (close-input-port wish-in)
+  (close-output-port wish-out))
+
+(define (wish% . args)
+  (with-output-to-port wish-out
+    (lambda ()
+      (apply print args))))
+
+;; High-level visualization commands
+
+(define (visualizer-open w h)
+  (wish-startup w h)
+  (wish% "canvas .c -width " w " -height " h " -bg black")
+  (wish% "pack .c")
+  (wish% "image create photo core -width " w " -height " h " -palette 256/256/256")
+  (wish% ".c create image 0 0 -anchor nw -image core"))
+
+(define (set-pixel x y col)
+  (wish% "core put " col " -to " x " " y))
+
+(define (visualizer-close)
+  (wish-shutdown))
+
+;; Test code
+
+(visualizer-open 640 480)
+(set-pixel 10 10 "red")
+(sleep 3)
+(visualizer-close)
-- 
2.20.1