Concatenative Behavior Tree in Clojure

core.clj

(ns b3clj.core)

; TODO more stack operations
(defn spush
  ([stack item] (spush stack :data item))
  ([stack typ item] (update-in stack [typ] conj item)))

(defn spop
  ([stack] (spop stack :data))
  ([stack typ]
   (update-in stack [typ] rest)))

(defn speek
  ([stack] (speek stack :data))
  ([stack typ] (first (get stack typ))))

(defn sswap
  ([stack] (sswap stack :data))
  ([stack typ]
    (update-in stack [typ]
      (fn [[a b & r]]
        (conj r a b)))))

(defn succeed [stack] (spush stack :status :success))
(defn fail    [stack] (spush stack :status :failure))
(defn run     [stack] (spush stack :status :running))

(defn composite [unit stack & fns]
  (loop [stack (spush stack :status unit)
         [f & fns] fns]
    (let [stack (f stack)
          stack (update-in stack [:status]
                  (fn [[st acc & other]]
                    (cons (if (= acc unit) st acc) other)))]
      (if (and fns (= (speek stack :status) unit))
        (recur stack fns)
        stack))))

; TODO more node types
(def sequential (partial composite :success))
(def selector (partial composite :failure))

(defn complete [fn stack]
  (first
    (drop-while
      #(= (speek % :status) :running)
      (iterate fn (fn stack)))))

; Implement FizzBuzz
; (map fizzbuzz (range 100))

(defn modn [n]
  #(if (= 0 (mod (speek %) n))
    (-> %
      spop
      succeed)
    (fail %)))

(defn message [msg]
  #(-> %
    (spush msg)
    succeed))

(defn fizzbuzz [n]
  (-> {}
    (spush n)
    (selector
      #(sequential %
          (modn 15)
          (message "FizzBuzz"))
      #(sequential %
          (modn 3)
          (message "Fizz"))
      #(sequential %
          (modn 5)
          (message "Buzz")))
    speek))

; Age guessing game
; (share {:bob 5} [[:dave 6 :eve] [:dave 4 :bob] [:alice 2 :carl] [:alice 3 :bob]])

(defn know-age [stack]
  (if (speek stack :age)
    (succeed stack)
    (fail stack)))

(defn useful-hint [stack]
  (let [hint (speek stack :hint)
        [a diff b] hint
        [name age] (speek stack :age)]
    (if hint
      (if (or (= a name) (= b name))
        (succeed stack)
        (-> stack
          (spop :hint)
          run))
      (fail stack))))

(defn calculate-hint [stack]
  (let [hint (speek stack :hint)
        [a diff b] hint
        [name age] (speek stack :age)
        stack (if hint
                (-> stack
                  (spop :hint)
                  run)
                (succeed stack))]
    (-> stack
      (spush :age
        (if (= a name)
          [b (+ age diff)]
          [a (- age diff)]))
      (sswap :age))))

(defn person [stack]
  ;(println stack)
  (sequential stack
    know-age
    useful-hint
    calculate-hint))

(defn share [ages hints]
  (loop [ages ages]
    (let [pstacks (for [age ages] {:age (list age) :hint (sequence hints)})
          pstacks (map (partial complete person) pstacks)
          new-ages (reduce into {} (map :age pstacks))]
      (if (= ages new-ages)
        new-ages
        (recur new-ages)))))