Refactor the intcode machine

5 files changed, 102 insertions, 84 deletions

diff --git a/2019/05/puzzles.lisp b/2019/05/puzzles.lisp
index 28eb32d..7602231 100644
--- a/2019/05/puzzles.lisp
+++ b/2019/05/puzzles.lisp
@@ -3,19 +3,10 @@
 (load "../interpreter.lisp")
 
 (defun main (filename)
-  (let ((stdout (make-string-output-stream)))
-    (intcode:run (intcode:parse "input") nil stdout :initial-arguments
-                 ;; START PART 1
-                 '(1)
-                 ;; END PART 1 START PART 2
-                 '(5)
-                 ;; END PART 2
-                 )
-    (parse-integer (last-line (get-output-stream-string stdout)))))
-
-(defun last-line (string)
-  (let* ((nl-e (position #\Newline string :from-end t))
-         (nl-b (position #\Newline string :from-end t :end nl-e)))
-    (subseq string (1+ (or nl-b -1)) nl-e)))
+  (let (result)
+    (intcode:run (intcode:parse filename)
+                 (lambda () (if (= +puzzle-part+ 1) 1 5))
+                 (lambda (x) (setq result x)))
+    result))
 
 (format t "~d~%" (main "input"))
\ No newline at end of file
diff --git a/2019/07/Makefile b/2019/07/Makefile
deleted file mode 100644
index 5a21270..0000000
--- a/2019/07/Makefile
+++ /dev/null
@@ -1 +0,0 @@
-include ../../Makefiles/lisp.mk
\ No newline at end of file
diff --git a/2019/07/machine.lisp b/2019/07/machine.lisp
index 798bbb8..64157c7 100755
--- a/2019/07/machine.lisp
+++ b/2019/07/machine.lisp
@@ -2,5 +2,10 @@
 
 (load "../interpreter.lisp")
 
-(intcode:run (intcode:parse "input") *standard-input* *standard-output*
-             :initial-arguments (mapcar #'parse-integer (cdr *posix-argv*)))
\ No newline at end of file
+(intcode:run (intcode:parse "input")
+             (lambda ()
+               (parse-integer
+                (if (rest *posix-argv*)
+                    (first (setf *posix-argv* (rest *posix-argv*)))
+                    (read-line))))
+             (lambda (x) (format t "~d~%" x)))
\ No newline at end of file
diff --git a/2019/interpreter.lisp b/2019/interpreter.lisp
index 719ff9e..532d6a9 100644
--- a/2019/interpreter.lisp
+++ b/2019/interpreter.lisp
@@ -8,22 +8,20 @@
 
 (defstruct (machine (:conc-name mach-)
                     (:constructor make-machine
-                        (program stdin stdout initial-arguments))
-                    (:type (vector t)))
-  (ip        0 :type integer)
-  (program nil :type array)
-  (stdin   nil :type (or null stream))
-  (stdout  nil :type (or null stream))
-  (initial-arguments nil :type list))
+                        (mem input-handler output-handler)))
+  (ip 0 :type integer)
+  (rel-base 0 :type integer)
+  (mem nil :type array)
+  (ext-mem (make-hash-table) :type hash-table)
+  (input-handler nil :type (or null function))
+  (output-handler nil :type (or null function)))
 
 (defstruct (instruction (:conc-name instr-)
                         (:constructor make-instruction
-                            (opcode param-count param-modes last-outputs-p))
-                        (:type (vector t)))
-  (opcode         nil :type integer)
-  (param-count    nil :type integer)
-  (param-modes    nil :type array)
-  last-outputs-p)
+                            (opcode param-count param-modes)))
+  (opcode      nil :type integer)
+  (param-count nil :type integer)
+  (param-modes nil :type array))
 
 (defconstant +op-add+   1)
 (defconstant +op-mul+   2)
@@ -33,6 +31,7 @@
 (defconstant +op-jn+    6)
 (defconstant +op-le+    7)
 (defconstant +op-eq+    8)
+(defconstant +op-rel+   9)
 (defconstant +op-quit+ 99)
 
 (defparameter *handlers* (make-array 100))
@@ -40,14 +39,13 @@
 (define-condition machine-sysjump (error) ())
 (define-condition machine-sysexit (error) ())
 
-(defun run (program &optional stdin stdout &key initial-arguments)
-  (loop with mach = (make-machine program stdin stdout initial-arguments) do
+(defun run (program &optional input-handler output-handler)
+  (loop with mach = (make-machine program input-handler output-handler) do
     (let* ((instr (decode-next-instr mach))
            (opcode (instr-opcode instr))
            (handler (aref *handlers* opcode))
-           (arguments (fetch-arguments instr mach))
            (ip-shift (1+ (instr-param-count instr))))
-      (handler-case (apply handler mach arguments)
+      (handler-case (funcall handler mach instr)
         (machine-sysjump (c)
           (declare (ignore c))
           (decf (mach-ip mach) ip-shift))
@@ -58,7 +56,7 @@
 
 (defun decode-next-instr (mach)
   (let* ((raw-instr
-           (aref (mach-program mach) (mach-ip mach)))
+           (memref mach (mach-ip mach)))
          (opcode
            (mod raw-instr 100))
          (param-count
@@ -71,51 +69,74 @@
              (#.+op-jn+   2)
              (#.+op-le+   3)
              (#.+op-eq+   3)
+             (#.+op-rel+  1)
              (#.+op-quit+ 0)))
          (param-modes
            (make-array 3 :initial-contents
                        (list (mod (floor raw-instr   100) 10)
                              (mod (floor raw-instr  1000) 10)
-                             (mod (floor raw-instr 10000) 10))))
-         (last-outputs-p
-           (member opcode '(#.+op-add+ #.+op-mul+ #.+op-set+
-                            #.+op-le+ #.+op-eq+))))
-    (make-instruction opcode param-count param-modes last-outputs-p)))
-
-(defun fetch-arguments (instr mach)
-  (when (instr-last-outputs-p instr)
-    (setf (aref (instr-param-modes instr)
-                (1- (instr-param-count instr)))
-          1))
-  (loop with program = (mach-program mach) with ip = (mach-ip mach)
-        for i from 1 to (instr-param-count instr)
-        collect (ecase (aref (instr-param-modes instr) (1- i))
-                  (0 (aref program (aref program (+ ip i))))
-                  (1               (aref program (+ ip i))))))
+                             (mod (floor raw-instr 10000) 10)))))
+    (make-instruction opcode param-count param-modes)))
+
+(defun memref (mach i)
+  (let ((mem (mach-mem mach)))
+    (if (< i (length mem))
+        (aref mem i)
+        (gethash i (mach-ext-mem mach) 0))))
+
+(defun (setf memref) (value mach i)
+  (let ((mem (mach-mem mach)))
+    (if (< i (length mem))
+        (setf (aref mem i) value)
+        (setf (gethash i (mach-ext-mem mach)) value))))
+
+(defun fetch-param (mach i in-out mode)
+  (let* ((ip (mach-ip mach))
+         (rel-base (mach-rel-base mach))
+         (argptr (+ ip i)))
+    (ecase in-out
+      (in (ecase mode
+            (0 (memref mach (memref mach argptr)))
+            (1 (memref mach argptr))
+            (2 (memref mach (+ (memref mach argptr) rel-base)))))
+      (out (ecase mode
+             (0 (memref mach argptr))
+             (2 (+ (memref mach argptr) rel-base)))))))
 
 ;;; Instructions
 
 (defmacro definstruction (name (&rest params) &body forms)
-  (let ((instr (intern (format nil "+OP-~:@(~a~)+" name))))
-    `(setf (aref *handlers* ,instr) (lambda ,params ,@forms))))
-
-(definstruction add (mach x y dst)
-  (setf (aref (mach-program mach) dst) (+ x y)))
-
-(definstruction mul (mach x y dst)
-  (setf (aref (mach-program mach) dst) (* x y)))
-
-(definstruction set (mach dst)
-  (setf (aref (mach-program mach) dst)
-        (if (mach-initial-arguments mach)
-            (destructuring-bind (head &rest tail)
-                (mach-initial-arguments mach)
-              (setf (mach-initial-arguments mach) tail)
-              head)
-            (parse-integer (read-line (mach-stdin mach))))))
+  (let ((op-symbol (intern (format nil "+OP-~:@(~a~)+" name))))
+    `(setf (aref *handlers* ,op-symbol)
+           (lambda (mach instr)
+             (let ((ptype 'in)
+                   (i 0)
+                   in out)
+               (dolist (param ',(cdr params))
+                 (if (eq param '&out)
+                     (setq ptype 'out)
+                     (let ((pval (fetch-param
+                                  mach (1+ i) ptype
+                                  (aref (instr-param-modes instr) i))))
+                       (if (eq ptype 'in)
+                           (push pval in)
+                           (push pval out))
+                       (incf i))))
+               (apply (lambda ,(remove-if (lambda (sym) (eq sym '&out)) params)
+                        ,@forms)
+                      mach (append (reverse in) (reverse out))))))))
+
+(definstruction add (mach x y &out dst)
+  (setf (memref mach dst) (+ x y)))
+
+(definstruction mul (mach x y &out dst)
+  (setf (memref mach dst) (* x y)))
+
+(definstruction set (mach &out dst)
+  (setf (memref mach dst) (funcall (mach-input-handler mach))))
 
 (definstruction out (mach x)
-  (format (mach-stdout mach) "~d~%" x))
+  (funcall (mach-output-handler mach) x))
 
 (definstruction jt (mach x addr)
   (unless (zerop x)
@@ -127,11 +148,14 @@
     (setf (mach-ip mach) addr)
     (error 'machine-sysjump)))
 
-(definstruction le (mach x y dst)
-  (setf (aref (mach-program mach) dst) (bool-to-int (< x y))))
+(definstruction le (mach x y &out dst)
+  (setf (memref mach dst) (bool-to-int (< x y))))
+
+(definstruction eq (mach x y &out dst)
+  (setf (memref mach dst) (bool-to-int (= x y))))
 
-(definstruction eq (mach x y dst)
-  (setf (aref (mach-program mach) dst) (bool-to-int (= x y))))
+(definstruction rel (mach x)
+  (incf (mach-rel-base mach) x))
 
 (definstruction quit (mach)
   (declare (ignore mach))
@@ -149,7 +173,9 @@
   (loop for comma-pos = (position-if #'commap string)
         collect (parse-integer (subseq string 0 comma-pos)) into numbers
         unless comma-pos
-          return (coerce numbers 'vector)
+          return (make-array (length numbers)
+                             :initial-contents numbers
+                             :fill-pointer t)
         do (setq string (subseq string (1+ comma-pos)))))
 
 ;;; Helper Functions
@@ -158,11 +184,4 @@
   (char= char #\,))
 
 (defun bool-to-int (bool)
-  (if bool 1 0))
-
-(defun try-aref (array &rest subscripts)
-  (loop for i in subscripts
-        for j in (array-dimensions array)
-        unless (< -1 i j)
-          return nil
-        finally (return (apply #'aref array subscripts))))
\ No newline at end of file
+  (if bool 1 0))
\ No newline at end of file
diff --git a/Makefiles/lisp.mk b/Makefiles/lisp.mk
index b9122df..d181127 100644
--- a/Makefiles/lisp.mk
+++ b/Makefiles/lisp.mk
@@ -1,8 +1,12 @@
 .POSIX:
 
 all:
-	sed '/START PART 2/,/END PART 2/d' puzzles.lisp >puzzle-1.lisp
-	sed '/START PART 1/,/END PART 1/d' puzzles.lisp >puzzle-2.lisp
+	sed -e '/START PART 2/,/END PART 2/d'                                       \
+		-e '1a(defconstant +puzzle-part+ 1)'                                    \
+		puzzles.lisp >puzzle-1.lisp
+	sed -e '/START PART 1/,/END PART 1/d'                                       \
+		-e '1a(defconstant +puzzle-part+ 2)'                                    \
+		puzzles.lisp >puzzle-2.lisp
 	chmod +x puzzle-[12].lisp
 
 clean: