A little Joy in Clojure

joy.clj

;; Playing around with Joy in Clojure
;; http://en.wikipedia.org/wiki/Joy_%28programming_language%29

;; The code is partly based on Joy in Scheme by John Cowan
;; http://home.ccil.org/~cowan/

(defn get-var [var env] (@env var))
(defn set-var! [var val env] (swap! env conj {var val}))
(def global-env (atom {}))
(def joy-stack (atom []))
(defn joy-push! [x] (swap! joy-stack conj x))
(defn joy-push-list! [xs] (doseq [x xs] (joy-push! x)))
(defn joy-pop [] (let [x (peek @joy-stack)] (swap! joy-stack pop) x))

(defn joy-invoke [p]
  (cond
   (fn? p) (p)
   :else (joy-exec p)))

(defn joy-exec-one [i]
  (if (symbol? i)
    (joy-invoke (get-var i global-env))
    (joy-push! i)))

(defn joy-exec [ps]
  (doseq [p ps] (joy-exec-one p)))

(defmacro let-pop [v & body]
  `(let [~v (joy-pop)]
     ~@body))

(defmacro let-pops
  [[x & more] body]
  (if (empty? more)
    `(let-pop ~x ~body)
    `(let-pops ~more (let-pop ~x ~body))))

(defmacro joy-prim [[name & vars] body]
  `(set-var! ~name (fn [] (let-pops [~@vars]
                                   (joy-push! ~body))) global-env))
(defmacro joy-prim-list [[name & vars] body]
  `(set-var! ~name (fn [] (let-pops [~@vars]
                                   (joy-push-list! ~body))) global-env))
(defmacro joy-prim-void [[name & vars] body]
  `(set-var! ~name (fn [] (let-pops [~@vars]
                                   ~body)) global-env))

(joy-prim ['+ a b] (+ a b))
(joy-prim ['- a b] (- a b))
(joy-prim ['* a b] (* a b))
(joy-prim ['/ a b] (/ a b))
(joy-prim-list ['dup x] [x x])
(joy-prim-list ['swap x y] [y x])
(joy-prim ['dip x p] (do (joy-exec p) x))
(joy-prim-list ['rotate x y z] [z y x])
(joy-prim-list ['rollup x y z] [z x y])
(joy-prim-list ['rolldown x y z] [y z x])
(joy-prim ['popd y z] z)
(joy-prim ['concat s t] (if (string? s) (str s t) (concat s t)))
(joy-prim ['first a] (first a))
(joy-prim ['rest a] (rest a))
(joy-prim ['or a b] (or a b))
(joy-prim-void ['i x] (joy-exec x))
(joy-prim-void ['pop x] nil)

(joy-prim ['map xs p] (map (fn [x]
                            (joy-push! x)
                            (joy-exec p)
                            (joy-pop)) xs))
(defn primrec [b p]
  (let [v (joy-pop)]
    (if (= v 0)
      (joy-exec b)
      (do
        (joy-push! v)
        (joy-push! (dec v))
        (primrec b p)
        (joy-exec p)))))

(joy-prim-void ['primrec b p] (primrec b p))

(defn enjoy-prim [p]
  (reset! joy-stack [])
  (joy-exec p)
  @joy-stack)

(defmacro enjoy [& prog]
  `(enjoy-prim '~prog))

(enjoy 32 110 2 * /)
(enjoy [32 dup *] i)
(enjoy 32 10 pop)
(enjoy 1 2 3 rolldown)
(enjoy "ok" "computer" concat)
(enjoy [1 2 3] [4 5 6 7] concat)
(enjoy [1 3 2] rest)
(enjoy true false or)
(enjoy [1 2 3 4 5 6 7 8 9 10] [dup *] map)
(enjoy 10 [1] [*] primrec)