Brainf*** Interpreter

brainf.clj

(ns brainf
  (:require [clojure.string :as str]))

(defn new-machine
  "Creates a new untouched machine running the given instructions
   and accepting the given input."
  [instructions input]
  {:data         [0]          ;; Data tape
   :pos          0            ;; Data pointer index
   :input        input        ;; Current input stream
   :output       []           ;; Current output stream
   :instructions instructions ;; Instruction tape
   :inst-pointer 0})          ;; Instruction pointer index

(defn curr-datum
  "Retrieves the datum at the current cell of a machine."
  [{:keys [data pos]}]
  (nth data pos))
  
(defn byte-inc
  "Increments a ubyte with wraparound overflow."
  [n]
  (if (= 255 n) 0 (inc n)))

(defn byte-dec
  "Decrements a ubyte with wraparound underflow."
  [n]
  (if (= 0 n) 255 (dec n)))

(defn ensure-data-size
  "Expands the given data vector with zeros until it
   meets the given minimum size."
  [data min-size]
  (let [diff (- min-size (count data))]
    (if (> diff 0)
      (into data (repeat diff 0))
      data)))

(defn inc-data-pointer
  "Increments the data pointer of a machine."
  [{:keys [data pos inst-pointer] :as machine}]
  (let [new-pos (inc pos)]
    (assoc machine
      :pos new-pos
      :data (ensure-data-size data (inc new-pos))
      :inst-pointer (inc inst-pointer))))

(defn dec-data-pointer
  "Decrements the data pointer of a machine."
  [{:keys [pos inst-pointer] :as machine}]
  (assoc machine
    :pos (dec pos) ;; No negative bounds check...
    :inst-pointer (inc inst-pointer))) 

(defn inc-datum
  "Increments the current datum cell of a machine."
  [{:keys [data pos inst-pointer] :as machine}]
  (-> machine
    (update-in [:data pos] byte-inc)
    (assoc :inst-pointer (inc inst-pointer))))

(defn dec-datum
  "Decrements the current datum cell of a machine."
  [{:keys [data pos inst-pointer] :as machine}]
  (-> machine
    (update-in [:data pos] byte-dec)
    (assoc :inst-pointer (inc inst-pointer))))
  
(defn output-datum
  "Sends the current datum cell of a machine to its output stream."
  [{:keys [data pos output inst-pointer] :as machine}]
  (let [curr-byte (curr-datum machine)
        curr-char (char curr-byte)]
    (assoc machine
      :output (conj output curr-char)
      :inst-pointer (inc inst-pointer))))

(defn input-datum
  "Consumes the next input of a machine as an ASCII code and stores
   it in the current datum cell."
  [{:keys [data pos input inst-pointer] :as machine}]
  (if-not (empty? input)
    (let [[new-datum & rest-input] input]
      (-> machine
        (assoc-in [:data pos] (int new-datum))
        (assoc
          :input rest-input 
          :inst-pointer (inc inst-pointer))))))

(defn seek-after-match
  "Returns the pointer index of the next instruction following the
   matching ']' instruction.
   'Matching' here accounts for nesting, where a stack input of 1
   will match the next ']' found, 2 will match the second ']', etc.,
   and where '[' will increment the stack level as the search
   continues."
  [instructions pointer stack]
  (let [next-step (inc pointer)]
    (case (nth instructions pointer)
      \[ (recur instructions next-step (inc stack))
      \] (if (= 1 stack)
           next-step
           (recur instructions next-step (dec stack)))
      (recur instructions next-step stack))))
    
(defn seek-before-match
  "Returns the pointer index of the next instruction following the
   matching '[' instruction (moving right-to-left along the tape).
   'Matching' here accounts for nesting, where a stack input of 1
   will match the next '[' found, 2 will match the second '[', etc.,
   and where ']' will increment the stack level as the search
   continues."
  [instructions pointer stack]
  (let [next-step (dec pointer)]
    (case (nth instructions pointer)
      \] (recur instructions next-step (inc stack))
      \[ (if (= 1 stack)
           (inc pointer)
           (recur instructions next-step (dec stack)))
      (recur instructions next-step stack))))

(defn branch
  "Branches the machine to the instruction after the matching loop-back
   (']') command if the current datum is zero, or does nothing otherwise."
  [{:keys [data pos instructions inst-pointer] :as machine}]
  (let [inc-inst (inc inst-pointer)
        next-instruction (if (zero? (curr-datum machine))
                           (seek-after-match instructions inc-inst 1)
                           inc-inst)]
    (assoc machine :inst-pointer next-instruction)))

(defn loop-back
  "Branches the machine to the instruction after the matching branch
   ('[') command if the current datum is non-zero, or does nothing otherwise."
  [{:keys [data pos instructions inst-pointer] :as machine}]
  (let [next-instruction (if (zero? (curr-datum machine))
                           (inc inst-pointer)
                           (seek-before-match instructions (dec inst-pointer) 1))]
    (assoc machine :inst-pointer next-instruction)))

(def commands
  {\> inc-data-pointer
   \< dec-data-pointer
   \+ inc-datum
   \- dec-datum
   \. output-datum
   \, input-datum
   \[ branch
   \] loop-back})

(defn machine-step
  "Executes the current instruction of the machine, and returns the
   subsequent machine state."
  [{:keys [data pos input output instructions inst-pointer] :as machine}]
  (let [command-fn (get commands (nth instructions inst-pointer))]
    (command-fn machine)))

(defn machine-incomplete?
  "Returns whether the machine is finished running, either by failure or
   by running to the end of the tape."
  [{:keys [instructions inst-pointer] :as machine}]
  (and (not (nil? machine))
       (< inst-pointer (count instructions))))

(defn run-machine
  "Runs a machine until it has completed, returning the final machine
   state."
  [machine]
  (->> machine
    (iterate machine-step)
    (drop-while machine-incomplete?)
    first))

(defn machine-output
  "Returns the output of a machine as a string."
  [{output :output :as machine}]
  (if-not (nil? machine)
    (str/join output)))

(defn execute-string
  "Evaluate the Brainf*** source code in `source` using `input` as a source of
  characters for the `,` input command.

  Either returns a sequence of output characters, or `nil` if there was
  insufficient input."
  [source input]
  (->> (new-machine source input)
       run-machine
       machine-output))