BrainF*ck compiler

bfc.clj

;; Alan Dipert BFC

(defn bfc [program]
  (let [allowed #{\+ \- \< \> \[ \] \.}
        src (->> program (filter allowed)
                 (interpose \space) (apply str))
        fns (zipmap '(- + < > . ?) (repeatedly gensym))]
    (letfn [(bfc* [s]
              (if (vector? s)
                `(while (not (~(fns '?))) ~@(map bfc* s))
                `(~(fns s))))]
      `(let [tape# (int-array 6000 0)
             pointer# (atom 0)
             ~(fns '-) #(aset tape# @pointer# (dec (aget tape# @pointer#)))
             ~(fns '+) #(aset tape# @pointer# (inc (aget tape# @pointer#)))
             ~(fns '<) #(swap! pointer# dec)
             ~(fns '>) #(swap! pointer# inc)
             ~(fns '.) #(print (char (aget tape# @pointer#)))
             ~(fns '?) #(zero? (aget tape# @pointer#))]
         ~@(map bfc* (read-string (str "(" src ")")))))))


(-> "+++++[->+<]"
    bfc
    eval)

(-> 
 (str 
  "++++++++++" 
  "[> +++++++ > ++++++++++ > +++ > + <<<< -]"
  "> ++ ."
  "> + ."
  "+++++ ++ ."
  "."
  "+++ ."
  "> ++ ."
  "<< +++++ +++++ +++++ ."
  "> ."
  "+++ ."
  "----- - ."
  "----- --- ."
  "> + ."
  "> .")
 bfc
 eval)

bfi.clj

(defn bfi [program]
  (let [tape (int-array 6000 0)
        src (->> program (filter #{\+ \- \< \> \[ \] \.}) (interpose \space) (apply str))
        pointer (atom 0)
        run (fn run [src]
              (let [[fst & rst] src]
                (cond
                 (vector? fst)
                 (do
                   (while (not (zero? (aget tape @pointer))) (run fst))
                   (recur rst))

                 fst
                 (do (condp = fst
                       '- (aset tape @pointer (dec (aget tape @pointer)))
                       '+ (aset tape @pointer (inc (aget tape @pointer)))
                       '< (swap! pointer dec)
                       '> (swap! pointer inc)
                       '. (print (char (aget tape @pointer))))
                     (recur rst)))))]
    (run (read-string (str "(" src ")")))))