brainfuck interpreter

;utility
(defun file-get-contents (filename)
  "http://sodaware.sdf.org/notes/cl-read-file-into-string/"
  (with-open-file (stream filename)
    (let ((contents (make-string (file-length stream))))
      (read-sequence contents stream)
      contents)))

;program
(load "~/quicklisp/setup.lisp")
(ql:quickload "pathnames" :silent t) ;This is Peter Seibel's pathnames library from Practical Common Lisp

(defparameter +max-cell-value+ (1- (expt 2 8)))
(defparameter +min-cell-value+ 0)
(defparameter +instruction-list+ (list #\+ #\- #\> #\< #\. #\, #\[ #\]))

(defclass tape-memory ()
  ((leftern-tape
    :accessor left-tape
    :initform (make-array 30 :fill-pointer 0 :adjustable t)
    :initarg :leftern-tape)
   (rightern-tape
    :accessor right-tape
    :initform (make-array 30 :fill-pointer 0 :adjustable t)
    :initarg :rightern-tape))
  (:documentation "A simple holder for the tape-mems to avoid loose vars."))

(defparameter *output-mode* 'ascii
  "Specifies dispatch for formatting output to correct output mode.")
(defparameter *input* (make-string-input-stream ""))
(defparameter *PC* 0
  "The Program Counter for the brainfuck programs.")
(defparameter *head* 0
  "The tape head/pointer aka the pointer to current memory cell.")
(defparameter *program* (make-array 30 :fill-pointer 0 :adjustable t)
  "Holds the actual program as a vector of instruction symbols")
(defparameter *tape* (make-instance 'tape-memory)
  "The infinite tape memory itself")
(vector-push-extend 0 (right-tape *tape*)) ;Hacky. *head* starts at 0.

(defun left-cell-num (head)
  "Convert a tape-index into appropriate left-tape vector index. 1- since
   0 is treated as positive (and therefore is in right-tape."
  (1- (abs head)))
(defun tape-cell (tape head)
  "Should return the tape-cell requested, whether that's in left or right."
  (if (< head 0)
      (elt (left-tape tape) (left-cell-num head))
      (elt (right-tape tape) head)))
(defun set-tape-cell (tape head value)
  "Sets the value of the current cell to value."
  (if (< head 0)
       (setf (elt (left-tape tape) (left-cell-num head)) value)
       (setf (elt (right-tape tape) head) value)))

(defun potential-right-extend (tape head)
  "Extend the infinite right-tape if head points out-of-bounds."
  (if (and (not (minusp head)) ;Want to treat 0 as positive
       (>= head (fill-pointer (right-tape tape))))
    (vector-push-extend 0 (right-tape tape))
    'no-extension-necessary))
(defun potential-left-extend (tape head)
  "Extend the infinite left-tape if head points out-of-bounds."
  (if (and (minusp head)
       (>= (left-cell-num head) (fill-pointer (left-tape tape))))
    (vector-push-extend 0 (left-tape tape))
    'no-extension-necessary))

(defun increment-cell (tape head)
  "Increment current cell. Wrap around to +min-cell-value+ if overflow."
  (let* ((old-val (tape-cell tape head))
     (new-val (if (> (1+ old-val) +max-cell-value+)
              +min-cell-value+
              (1+ old-val))))
    (set-tape-cell tape head new-val)))
(defun decrement-cell (tape head)
  "Decrement current cell. Wrap around to +max-cell-value+ if underflow."
  (let* ((old-val (tape-cell tape head))
     (new-val (if (< (1- old-val) +min-cell-value+)
              +max-cell-value+
              (1- old-val))))
    (set-tape-cell tape head new-val)))

(defun output-cell (tape head)
  "Outputs the value of the current cell."
  (let ((print-datum (output-mode-format (tape-cell tape head))))
    (format *query-io* "~A" print-datum)
    print-datum))
(defun output-mode-format (cell-value)
  "Interprets cell-value according to current *output-mode*."
  (cond ((equal *output-mode* 'ascii)
     (code-char cell-value))
    (t (error "~A is not a valid *output-mode*." *output-mode*))))

(defun input-cell (tape head)
  "Replaces the value of the current cell with the first byte of *input*, or 0 if end-of-input."
  (let ((input-datum (if (listen *input*) (char-code (read-char *input*)) 0)))
    (set-tape-cell tape head input-datum)))

(defun string->program (program-string)
  "Turns a string into a program vector."
  (let ((program-list
     (remove-if #'(lambda (c) (not (member c +instruction-list+)))
            (loop for c across program-string collect c)))
    (program-vector (make-array 30 :fill-pointer 0 :adjustable t)))
    (loop for c in program-list do (vector-push-extend c program-vector))
    program-vector))
(defun load-program-from-string (program-string)
  "\"Loads\" a program from a string."
  (setf *program* (string->program program-string)))
(defun load-program-from-file (pot-file-string)
  (let ((pot-file-input (com.gigamonkeys.pathnames:file-exists-p pot-file-string)))
    (if pot-file-input
    (load-program-from-string (file-get-contents pot-file-input))
    (load-program-from-string pot-file-string))))

(defun find-matching-] (pc program)
  "Linear search until match found. Error if no match."
  (loop for i from (1+ pc) below (length program)
       with depth = 0
       when (and (zerop depth) (equal (elt program i) #\]))
       do (return i)
       when (equal (elt program i) #\[)
       do (incf depth)
       when (equal (elt program i) #\])
       do (decf depth)
       finally (error "~Dth instruction: [. Looked for matching ], but end-of-program with depth ~D.~%" pc depth)))
(defun jump-if-zero (head tape pc program)
  "Returns value so brainfuck-interpreter can update pc as required."
  (if (zerop (tape-cell tape head))
      (find-matching-] pc program)
      pc))

(defun find-matching-[ (pc program)
  "Linear search backwards until match found. Error if no match."
  (loop for i from (1- pc) downto 0
       with depth = 0
       when (and (zerop depth) (equal (elt program i) #\[))
       do (return i)
       when (equal (elt program i) #\])
       do (incf depth)
       when (equal (elt program i) #\[)
       do (decf depth)
       finally (error "~Dth instruction: ]. Looked for matching [, but start-of-program with depth ~D.~%" pc depth)))
(defun jump-unless-zero (head tape pc program)
  "Returns value so brainfuck-interpreter can update pc as required."
  (if (not (zerop (tape-cell tape head)))
      (find-matching-[ pc program)
      pc))

(defun move-rightp (s) (equal #\> s))
(defun move-leftp (s) (equal #\< s))
(defun incrementp (s) (equal #\+ s))
(defun decrementp (s) (equal #\- s))
(defun outputp (s) (equal #\. s))
(defun inputp (s) (equal #\, s))
(defun jump-if-zerop (s) (equal #\[ s))
(defun jump-unless-zerop (s) (equal #\] s))

(defun brainfuck-interpret (instruction)
  "The evaluator itself."
  (cond ((move-rightp instruction)
     (potential-right-extend *tape* (incf *head*)))
    ((move-leftp instruction)
     (potential-left-extend *tape* (decf *head*)))
    ((incrementp instruction)
     (increment-cell *tape* *head*))
    ((decrementp instruction)
     (decrement-cell *tape* *head*))
    ((outputp instruction)
     (output-cell *tape* *head*))
    ((inputp instruction)
     (input-cell *tape* *head*))
    ((jump-if-zerop instruction)
     (setf *pc* (jump-if-zero *head* *tape* *pc* *program*)))
    ((jump-unless-zerop instruction)
     (setf *pc* (jump-unless-zero *head* *tape* *pc* *program*)))
    (t 'ignore)))

(defun input-stream-potentially-file (input)
  (if (not input)
      nil
      (let ((pot-file-input
         (com.gigamonkeys.pathnames:file-exists-p input)))
    (if pot-file-input
        (open pot-file-input :direction :input)
        (make-string-input-stream input)))))

(defun execute (program &key (input nil))
  (setf *pc* 0)
  (setf *tape* (make-instance 'tape-memory))
  (vector-push-extend 0 (right-tape *tape*))
  (setf *head* 0)
  (setf *program* program)
  (setf *input* (input-stream-potentially-file input))
  (loop while (< *pc* (length *program*))
     do (brainfuck-interpret (elt *program* *pc*))
     do (incf *pc*)))

(defun main (argv)
  (let ((-program (member "-program" argv :test #'equal))
    (-input (member "-input" argv :test #'equal)))
    (cond ((and -program -input (= 5 (length argv)))
       (execute (load-program-from-file (cadr -program))
            :input (cadr -input)))
      ((and -program (= 3 (length argv)))
       (execute (load-program-from-file (cadr -program))))
      (t (error "Malformed launch: PROG -program PATH/STRING -input PATH/STRING")))))

;Presumably, this will only trigger when called with args from terminal:
(when (< 1 (length *posix-argv*))
  (main *posix-argv*))