(ns mimir.match
  (:use [clojure.set :only (intersection map-invert rename-keys difference union join)]
        [clojure.tools.logging :only (debug info warn error spy enabled?)]
        [clojure.walk :only (postwalk prewalk walk postwalk-replace)])
  (:import [java.util.regex Pattern]
           [clojure.lang IPersistentMap IPersistentSet Sequential Symbol Fn Keyword]))

(defprotocol MatchAny (match-any [this x acc]))
(defprotocol MatchMap (match-map [this x acc]))
(defprotocol MatchSeq (match-seq [this x acc]))

(defn filter-walk
  [pred coll]
  (let [acc (transient [])]
    (postwalk #(when (pred %) (conj! acc %)) coll)
    (distinct (persistent! acc))))

(defn singleton-coll? [x]
  (and (coll? (first x)) (not (next x))))

(defn maybe-singleton-coll [x]
  (if (singleton-coll? x) (first x) x))

(def default-match-var? #(and (symbol? %)
                                  (not (or (resolve %)  ('#{do fn* let* if} %)
                                           (re-matches #".*/.*"(str %)) (re-matches #"\..*"(name %))
                                           (re-matches #".*\."(name %)) (re-matches #".*#"(name %))))))
(def ^:dynamic *match-var?* default-match-var?)

(def ^:dynamic *var-symbol* symbol)

(defn bind-vars [x pattern acc]
  (if-let [var (if (*match-var?* pattern)
                 pattern
                 (-> pattern meta :tag))]
    (if (contains? acc var)
      (let [v (acc var)]
        (if-not (= v var)
          (if (= (acc v) var)
            (assoc acc var x)
            (match-any v x acc))
          acc))
      (assoc acc var x))
    acc))

(defn preserve-meta [form meta]
  (if (and (instance? clojure.lang.IMeta form)
           (not (and (list? form)
                     (= 'quote (first form))
                     (symbol (second form)))))
    (list 'if (list 'instance? 'clojure.lang.IMeta form)
          (list 'with-meta form (list 'quote meta))
          form)
    form))

(defn meta-walk [form]
  (let [m (dissoc (meta form) :line)]
    (if (seq m)
      (preserve-meta (walk meta-walk identity form) m)
      (if (*match-var?* form)
        (list 'quote form)
        (walk meta-walk identity form)))))

(defn bound-vars [x]
  (let [vars (transient [])
        var-walk (fn this [form]
                   (let [v (or (-> form meta :tag) form)]
                     (when (*match-var?* v)
                       (conj! vars v)))
                   form)]
    (prewalk var-walk x)
    (distinct (persistent! vars))))

(defn regex-vars [x]
  (let [vars (transient [])
        regex-walk (fn this [form]
                     (when (instance? Pattern form)
                       (reduce conj! vars
                               (map (comp symbol second)
                                    (re-seq #"\(\?<(.+?)>.*?\)" (str form)))))
                     form)]
    (postwalk regex-walk x)
    (distinct (persistent! vars))))

(extend-type Object
  MatchAny (match-any [this x acc] (when (= this x) acc))
  MatchMap (match-map [this x acc])
  MatchSeq (match-seq [this x acc]))

(extend-type nil
  MatchAny (match-any [this x acc] (when (nil? x) acc))
  MatchMap (match-map [this x acc])
  MatchSeq (match-seq [this x acc] (when-not (seq x) acc)))

(extend-type IPersistentMap
  MatchAny
  (match-any [this x acc] (match-map x this acc))
  MatchMap
  (match-map [x this acc] (loop [[k & ks] (keys this)
                                 acc acc]
                            (if-not k
                              (bind-vars x this acc)
                              (when (contains? x k)
                                (when-let [acc (match-any (this k) (x k) acc)]
                                  (recur ks (bind-vars (x k) (this k) acc))))))))

(extend-type Symbol
  MatchAny
  (match-any [this x acc] (if (*match-var?* this)
                            (bind-vars x this acc)
                            (when (= this x) acc))))

(extend-type Pattern
  MatchAny
  (match-any [this x acc] (let [re (re-matcher this (str x))
                                groups (regex-vars this)]
                            (when (.matches re)
                              (reduce #(assoc % (*var-symbol* %2)
                                              (.group re (str %2)))
                                      acc groups)))))

(extend-type Class
  MatchAny
  (match-any [this x acc] (when (instance? this x) acc)))

(extend-type Fn
  MatchAny
  (match-any [this x acc] (when (try (this x) (catch RuntimeException _))
                            (bind-vars x this acc))))

(extend-type Keyword
  MatchAny
  (match-any [this x acc] (when (or (and (coll? x)
                                         (contains? x this))
                                    (= x this))
                            (bind-vars x this acc)))

  MatchMap
  (match-map [this x acc] (when (contains? x this)
                            (bind-vars x this acc))))

(extend-type IPersistentSet
  MatchAny
  (match-any [this x acc] (loop [[k & ks] (seq this)
                                 acc acc]
                            (when k
                              (if-let [acc (match-any k x acc)]
                                (bind-vars x this acc)
                                (recur ks acc))))))

(def rest? '#{& .})

(extend-type Sequential
  MatchAny
  (match-any [this x acc] (match-seq x this acc))
  MatchSeq
  (match-seq [x this acc] (loop [[p & ps] this
                                 [y & ys] x
                                 acc acc]
                            (if (rest? y)
                              (when (rest? p) (recur ps ys acc))
                              (if (and (not p) (not y))
                                (bind-vars x this acc)
                                (if (rest? p)
                                  (let [rst (when y (vec (cons y ys)))]
                                    (when-let [acc (if (*match-var?* (first ps))
                                                     acc
                                                     (match-seq rst (repeat (count rst)
                                                                            (first ps)) acc))]
                                      (bind-vars (or rst ()) (first ps) acc)))
                                  (when-let [acc (match-any p y acc)]
                                    (recur ps ys (bind-vars y p acc)))))))))

(defn truth [& _] true)

(defn unquote-vars-in-scope [&env form]
  (if &env
    (postwalk #(if (and (list? %)
                        (= 'quote (first %))
                        (&env (second %)))
                 (second %) %) form)
    form))

(defn prepare-matcher [m &env]
  (->> (preserve-meta (walk identity meta-walk m) (meta m))
       (postwalk-replace {'_ truth :else truth '. ''.})
       (unquote-vars-in-scope &env)))

(defn match* [x pattern] (match-any pattern x {}))

(defmacro match [x m]
  `(match* ~x ~(prepare-matcher m &env)))

(defn all-vars [lhs]
  (vec (concat (bound-vars lhs)
               (map *var-symbol* (regex-vars lhs)))))

(defmacro condm* [match-var [lhs rhs & ms]]
  `(if-let [{:syms ~(remove (set (keys &env)) (all-vars lhs))}
            (mimir.match/match ~match-var ~lhs)]
     ~rhs
     ~(when ms
        `(condm* ~match-var ~ms))))

(defmacro condm [x & ms]
  (let [match-var (if-let [v (-> x meta :tag)] v '*match*)]
    `(let [~match-var ~(if (and (instance? clojure.lang.IMeta x)
                                (not (and (list? x)
                                          (= 'quote (first x))
                                          (symbol? (second x)))))
                         (with-meta x {})
                         x)]
       (condm* ~match-var ~ms))))

(defn single-arg? [ms]
  (not-any? coll? (take-nth 2 ms)))

(defmacro fm [& ms]
  `(fn ~'this [& ~'args]
     (condm (if ~(single-arg? ms) (first ~'args) ~'args) ~@ms)))

(defmacro defm [name args & ms]
  (let [[doc ms] (split-with string? ms)
        [_ _ [match-var & _ ]] (partition-by '#{&} args)]
    `(do
       (defn ~name ~args
         ~(when (seq ms)
            `(condm ~(list 'first (if (single-arg? ms)
                                    (list 'first match-var)
                                    match-var)) ~@ms)))
       (alter-meta! (var ~name) merge {:doc (apply str ~doc)})
       ~name)))

(ns mimir.mk
  (:use [clojure.tools.logging :only (debug info warn error spy)]
        [mimir.match :only (filter-walk prepare-matcher *match-var?* match-any bind-vars MatchAny MatchSeq)]
        [clojure.walk :only (postwalk-replace postwalk)])
  (:import [java.io Writer]
           [clojure.lang Symbol Seqable])
  (:refer-clojure :exclude [reify var? ==]))

(defprotocol MatchVar (match-var [this x acc]))

(extend-protocol MatchVar
  Object
  (match-var [x this acc] (when-let [x (-> x meta :tag)]
                            (match-any x this acc)))
  nil
  (match-var [x this acc])
  Symbol
  (match-var [x this acc]))

(extend-protocol MatchAny
  Object
  (match-any [this x acc] (if (= this x) acc
                              (match-var x this acc)))
  Symbol
  (match-any [this x acc] (if (= this x) acc
                              (match-var x this acc)))
  nil
  (match-any [this x acc] (if (nil? x) acc
                              (match-var x this acc))))

(deftype LVar [name]
  MatchAny
  (match-any [this x acc] (if (= this x) acc
                              (bind-vars x this acc)))
  MatchVar
  (match-var [x this acc] (match-any x this acc))
  MatchSeq
  (match-seq [x this acc] (when ((every-pred sequential? seq) (acc x))
                            (match-any this (acc x) acc)))
  Object
  (hashCode [this] (if name (.hashCode name) 0))
  (equals [this o] (and (instance? LVar o) (= (.name this) (.name ^LVar o)))))

(defmethod print-method LVar [o ^Writer w]
  (.write w (str (.name o))))

(defmacro alias-macro [m a]
  `(doto (intern *ns* '~a (var ~m)) .setMacro))

(defn var? [x] (instance? LVar x))

(defn cons-pairs-to-seqs [x]
  (if (and (sequential? x) (= 3 (count x)) (= '. (second x))
           ((some-fn sequential? nil?) (last x)))
    (cons (first x) (last x))
    x))

(defmacro unify [u v s]
  (let [[u v] (map #(prepare-matcher % &env) [u v])]
    `(binding [*match-var?* var?]
       (merge (match-any ~u ~v ~s) (match-any ~v ~u ~s)))))

(def ^:private subscripts '[₀ ₁ ₂ ₃ ₄ ₅ ₆ ₇ ₈ ₉])

(defn reify-name [n]
  (symbol (apply str "–" (map (comp subscripts int bigdec str) (str n)))))

(defn reify [v s]
  (loop [v v s s check #{v}]
    (let [v' (postwalk-replace s v)]
      (debug v')
      (if (contains? check v')
        v'
        (recur v' s (conj check v'))))))

(defmacro ≡ [u v]
  `(fn ≡ [a#]
     [(unify ~u ~v a#)]))
(alias-macro ≡ ==)

(defmacro ≠ [u v]
  `(fn ≠ [a#]
     [(when-not (seq (select-keys (unify ~u ~v a#) (keys a#))) a#)]))
(alias-macro ≠ !=)

(defn interleave-all [& colls]
  (when-let [ss (seq (remove nil? (map seq colls)))]
    (concat (map first ss) (lazy-seq (apply interleave-all (map rest ss))))))

(defmacro condᵉ [& gs]
  (let [a (gensym "a")]
    `(fn condᵉ [~a]
       (interleave-all ~@(map #(do `(run-internal ~(vec %) [~a])) gs)))))
(alias-macro condᵉ conde)

(defmacro fresh [[& x] & gs]
  `(let [~@(mapcat (fn [x] `[~x (LVar. (gensym '~x))]) x)]
     [~@gs]))

(defmacro project [[& x] & gs]
  (let [a (gensym "a")]
    `(fn project [~a]
       (let [~@(mapcat (fn [x] `[~x (~a ~x)]) x)]
         (run-internal ~(vec gs) [~a])))))

(defn run-internal [gs s]
  (lazy-seq
    (let [[g & gs] (flatten gs)
          s (remove nil? s)]
      (if-not g
        s
        (mapcat #(when-let [s (g %)]
                   (concat (run-internal gs [(first s)])
                           (run-internal gs (rest s)))) s)))))

(defn reify-goal [xs s]
  (let [xs (map #(reify % s) xs)
        vs (loop [[v & vs] (distinct (filter-walk var? xs))
                  acc {}]
             (if-not v
               acc
               (recur vs (assoc acc v (or (acc (s v)) (reify-name (count acc)))))))]
    (postwalk cons-pairs-to-seqs (postwalk-replace vs xs))))

(defmacro run* [[& x] & g]
  (let [g (postwalk-replace {'_ '(mimir.mk.LVar. (gensym '_))} g)]
    `(binding [*match-var?* var?]
       (run-internal (fresh [~@x] ~@g (partial reify-goal ~(vec x))) [{}]))))

(defmacro run [n [& x] & g]
  `(take ~n (run* [~@x] ~@g)))

(def succeed (≡ false false))
(def fail (≡ false true))

(defn consᵒ [a d l]
  (if (var? l)
    (let [d (if (var? d) ['. d] d)]
      (≡ (cons a d) l))
    [(≡ a (first l))
     (≡ d (rest l))]))

(defn firstᵒ [l a]
  (fresh [d]
    (consᵒ a d l)))

(defn restᵒ [l d]
  (fresh [a]
    (consᵒ a d l)))

(defn memberᵒ [x ls]
  (fresh [a d]
    (consᵒ a d ls)
    (condᵉ
      ((≡ a x))
      ((memberᵒ x d)))))

(defn appendᵒ [l1 l2 o]
  (condᵉ
   ((≡ l1 ()) (≡ l2 o))
   ((fresh [a d r]
      (consᵒ a d l1)
      (consᵒ a r o)
      (appendᵒ d l2 r)))))

(ns mimir.parse
  (:require [clojure.core.reducers :as r]
            [flatland.ordered.map :as om]
            [flatland.ordered.set :as os])
  (:import [java.util.regex Pattern]
           [java.util Map Set List]
           [clojure.lang Keyword ArityException]
           [flatland.ordered.set OrderedSet]))

(set! *warn-on-reflection* true)

(declare node maybe-singleton)

(def ^:dynamic *allow-split-tokens* true) ;; Overrides post-delimiter.

(def ^:dynamic *memoize* true)
(def ^:dynamic *capture-string-literals* false)
(def ^:dynamic *pre-delimiter* #"\s*")
(def ^:dynamic *post-delimiter* #"(:?\s+|$)")
(def ^:dynamic *offset* 0)
(def ^:dynamic *rule* nil)
(def ^:dynamic *default-result* [])
(def ^:dynamic *token-fn* conj)
(def ^:dynamic *suppress-tags* false)
(def ^:dynamic *node-fn* #'node)
(def ^:dynamic *default-action* #'maybe-singleton)
(def ^:dynamic *grammar-actions* true)
(def ^:dynamic *alternatives-rank* (comp count flatten :result))
(def ^:dynamic *grammar* {})
(def ^:dynamic *failure-grammar* {:no-match [#"\S*" #(throw (IllegalStateException. (str "Don't know how to parse: " %)))]})
(def ^:dynamic *start-rule* first)
(def ^:dynamic *extract-result* (comp first :result))
(def ^:dynamic *rules-seen-at-point* #{})

(defn maybe-singleton
  ([])
  ([x] x)
  ([x & args] (vec (cons x args))))

(defn suppressed-rule? [r]
  (when-let [[ _ r] (re-find #"^<(.+)>$" (name r))]
    (keyword r)))

(defn node? [x]
  (and (vector? x) (keyword? (first x))))

(defn node [& args]
  (let [args (apply maybe-singleton args)]
    (if (or *suppress-tags* (suppressed-rule? *rule*))
      args
      (if (and (sequential? args) (not (node? args)))
        (vec (cons *rule* args))
        [*rule* args]))))

(defn suppressed-defintion? [r]
  (let [suppressed-defintion (keyword (str "<" (name r) ">"))]
    (if (*grammar* suppressed-defintion)
      suppressed-defintion
      r)))

(defrecord StringParser [string offset token result])

(defn string-parser
  ([s] (if (instance? StringParser s) s (string-parser s *default-result*)))
  ([s result] (StringParser. s 0 nil result)))

(defn at-end? [{:keys [string offset] :as in}]
  (= offset (count string)))

(defn try-parse [{:keys [string offset result] :as in} ^Pattern re]
  (when in
    (let [m (re-matcher re (subs string offset))]
      (when (.lookingAt m)
        (assoc in
          :offset (+ offset (.end m 0))
          :token (.group m 0))))))

(defn try-parse-skip-delimiter [in m]
  (when-let [{:keys [token] :as in} (if-let [result (try-parse in m)]
                                      result
                                      (-> in
                                          (try-parse *pre-delimiter*)
                                          (try-parse m)))]
    (when-let [in (if *allow-split-tokens* in (try-parse in *post-delimiter*))]
      (assoc in :token token))))

(defn next-token [in m capture?]
  (when-let [{:keys [token offset] :as in} (try-parse-skip-delimiter in m)]
    (assoc (if capture?
             (binding [*offset* offset]
               (->  in
                    (update-in [:result] *token-fn* token)))
             in) :token nil)))

(defn name-and-predicate [n]
  (let [[_ predicate n] (re-find #"^([!&]?)(.+)" (name n))]
    [(keyword n) (when (seq predicate) (symbol predicate))]))

(defn name-and-quantifier [n]
  (let [[_ n quantifier] (re-find #"(.+?)([+*?]?)$" (name n))]
    [(keyword n) (when (seq quantifier) (symbol quantifier))]))

(defprotocol IParser
  (parse [this] [this in]))

(defn fold-into [ctor coll]
  (r/fold (r/monoid into ctor) conj coll))

(defn valid-choices [in ms]
  (fold-into vector (r/remove nil? (r/map #(parse % in) (vec ms)))))

(extend-protocol IParser
  Pattern
  (parse [this in]
    (next-token in this true))

  Character
  (parse [this in]
    (parse (str this) in))

  String
  (parse
    ([this] (parse (string-parser this)))
    ([this in]
       (next-token in (re-pattern (Pattern/quote this)) *capture-string-literals*)))

  Keyword
  (parse [this in]
    (when-not (*rules-seen-at-point* [this in])  ;; Only guards against StackOverflow, doesn't actually handle left recursion.
      (binding [*rules-seen-at-point* (conj *rules-seen-at-point* [this in])]
        (let [[this quantifier] (name-and-quantifier this)
              [this predicate] (name-and-predicate this)
              suppressed (suppressed-rule? this)
              this (suppressed-defintion? this)]
          (if-let [[rule action] (some *grammar* [this suppressed])]
            (letfn [(parse-one [in]
                      (let [current-result (:result in)]
                        (when-let [result (parse rule (assoc in :result *default-result*))]
                          (binding [*rule* this]
                            (update-in result [:result]
                                       #(*token-fn* current-result
                                                    (*node-fn* (try
                                                                 (apply (or (when *grammar-actions* action)
                                                                            *default-action*) %)
                                                                 (catch ArityException _
                                                                   (apply *default-action* %))))))))))
                    (parse-many [in quantifier]
                      (case quantifier
                        ? (or (parse-one in) in)
                        * (loop [in in]
                            (if-let [in (parse-one in)]
                              (recur in)
                              in))
                        + (when-let [in (parse-one in)]
                            (parse-many in '*))
                        (parse-one in)))]
              (let [result (parse-many in quantifier)]
                (case predicate
                  ! (when-not result in)
                  & (when result in)
                  result)))
            (throw (IllegalStateException. (str "Unknown rule: " this))))))))

  Set
  (parse [this in]
    (when-let [alternatives (seq (distinct (valid-choices in this)))]
      (apply max-key :offset (sort-by *alternatives-rank* alternatives))))

  OrderedSet
  (parse [this in]
    (first (valid-choices in this)))

  Map
  (parse [this in]
    (binding [*grammar* this]
      (parse (*start-rule* (os/into-ordered-set (keys this))) (string-parser in))))

  List
  (parse [this in]
    (loop [in in
           [m & m-rst] this]
      (if (and in m (not (at-end? in)))
        (recur (parse m in) m-rst)
        (when-not m in))))

  StringParser
  (parse
    ([this] (parse *grammar* this))
    ([this parser]
       (parse parser this))))

(def choice os/ordered-set)

(defn fun [s]
  (resolve (symbol s)))

(defn op
  ([op x] ((fun op) x))
  ([x op y] ((fun op) x y)))

(defmacro dynamic-reader []
  (let [locals (vec (keys &env))]
    `#(eval `(let [~'~locals ~~locals]
               ~(read-string %)))))

(def ^:dynamic *dynamic-reader*)

(defn action? [x]
  ((some-fn fn? var?) x))

(defn rule? [r]
  (and (vector? r) (= 2 (count r)) (action? (last r))))

(defn grammar [& rules]
  (let [rules (mapcat (fn [[rs [f]]] (if f (conj (vec (butlast rs)) [(last rs) f]) rs))
                      (partition-all 2 (partition-by action? rules)))]
    (into (om/ordered-map) (map (fn [[name rule]] [name (if (rule? rule)
                                                          rule
                                                          [rule])])
                                (partition 2 rules)))))

(defn parser-options [options]
  (into {} (map (fn [[k v]]
                  [(if (keyword? k)
                     (or (resolve (symbol (str "*" (name k) "*")))
                         (throw (IllegalArgumentException. (str "Unknown option: " k))))
                     k) v]) options)))

(defn create-parser
  ([& rules]
     (let [[[default-options] rules] (split-with map? rules)
           default-options (parser-options default-options)
           grammar (apply grammar rules)]
       (fn parser
         ([in & options]
            (with-bindings (merge default-options (parser-options (apply hash-map options)))
              (let [real-parse parse]
                (try
                  (when *memoize* ;; Just rebinding doesn't work for some reason
                    (alter-var-root #'parse memoize))
                  (when-let [in (parse grammar in)]
                    (if (at-end? in)
                      (*extract-result* in)
                      (parse *failure-grammar* in)))
                  (finally
                   (when *memoize*
                     (alter-var-root #'parse (constantly real-parse))))))))))))

(ns mimir.well
  (:use [clojure.set :only (intersection map-invert rename-keys difference union join)]
        [clojure.tools.logging :only (debug info warn error spy)]
        [clojure.walk :only (postwalk postwalk-replace)]
        [mimir.match :only (filter-walk maybe-singleton-coll match all-vars *match-var?* default-match-var?)])
  (:require [clojure.core.reducers :as r])
  (:refer-clojure :exclude [assert])
  (:gen-class))

(defn create-net []
  {:productions #{}
   :working-memory #{}
   :predicates {}
   :predicate-invokers {}
   :expression-cache {}
   :alpha-network {}
   :beta-join-nodes {}})

(def ^:dynamic *net* (atom (create-net)))

(defn dbg [x] (println x) x)

(doseq [k (keys @*net*)]
  (eval `(defn ~(symbol (name k)) [] (~k @*net*))))

(defn triplet? [x]
  (and (sequential? x) (= 3 (count x)) (symbol? (second x))))

(defn is-var? [x]
  (when-let [^String s (and (symbol? x) (name x))]
    (or (.startsWith s "?")
        (re-matches #"[A-Z]+" s))))

(defn var-sym [x]
  (symbol (str "?" x)))

(alter-var-root #'*match-var?* (constantly (every-pred default-match-var? (complement is-var?))))

(defn is-matcher? [x xs]
  (and (is-var? x) (not (symbol? (first xs)))))

(defn matcher? [c]
  (and (sequential? c)
       (= 'mimir.match/match* (first c))))

(defn parser
  ([x] (parser x identity identity))
  ([x atom-fn triplet-fn] (parser x atom-fn triplet-fn true))
  ([[x & xs] atom-fn triplet-fn match]
     (when x
       (cond (and match ((some-fn map? set? vector?) x)) (cons (atom-fn (list 'mimir.match/match (gensym "?") x))
                                                               (parser xs atom-fn triplet-fn match))
             ((some-fn sequential? map? set? string?) x) (cons (atom-fn x)
                                                               (parser xs atom-fn triplet-fn match))
             (and match (is-matcher? x xs)) (cons (atom-fn (list 'mimir.match/match x (first xs)))
                                                  (parser (rest xs) atom-fn triplet-fn match))
             (triplet? (cons x (take 2 xs))) (cons (triplet-fn (cons x (take 2 xs)))
                                                   (parser (drop 2 xs) atom-fn triplet-fn match))
             :else (cons x (parser xs atom-fn triplet-fn match))))))

(defn quote-non-vars [rhs]
  (postwalk #(if (and (symbol? %)
                      (not (is-var? %))) (list 'quote %) %) rhs))

(defn vars [x] (filter-walk is-var? x))

(defn quote-fact [t]
  (list 'quote t))

(defn expand-rhs [t]
  (cons 'mimir.well/assert t))

(def relations (reduce (fn [m rel] (assoc m rel rel))
                       '{<- mimir.well/bind = mimir.match/match* != not=} '[< > <= => not=]))

(defn macroexpand-conditions [lhs]
  (loop [[c & cs] (map macroexpand lhs)
         acc []]
    (if-not c
      acc
      (recur cs
             (if (every? seq? c)
               (into acc c)
               (conj acc c))))))

(defn expand-lhs [t]
  (if-let [rel (relations (second t))]
    (let [[var _ & [rest]] t]
      (if-let [rest (and (seq? rest)
                         (macroexpand-conditions [rest]))]
          (concat (butlast rest) [(list rel var (last rest))])
        (list rel var rest)))
    t))

(defn ellipsis
  ([x] (ellipsis 5 x))
  ([n x]
     (let [[start more] (split-at n (take (inc n) x))]
       (str (seq start)
            (when more
              (str "... [total: " (count x) "]"))))))

(defn binding? [c]
  (and (sequential? c)
       (= 'mimir.well/bind (first c))))

(defn binding-var [c]
  (when (binding? c) (second c)))

(defn binding-vars-for-rule [cs]
  (set (map binding-var (filter binding? cs))))

(defn purge-match-vars [xs]
  (let [match-vars (remove is-var? (keys xs))]
    (apply dissoc xs (concat (map var-sym match-vars) match-vars))))

(defmacro rule [name & body]
  (let [body (if ('#{=>} (first body)) (cons (list (gensym "?") '<- true) body) body)
        [body salience] (if (#{:salience} (first body)) [(drop 2 body) (second body)] [body 0])
        [lhs _ rhs] (partition-by '#{=>} body)
        [doc lhs] (split-with string? lhs)
        expanded-lhs (->> (macroexpand-conditions (parser lhs expand-lhs expand-lhs))
                          (map #(with-meta % {:ns *ns*})))
        rhs (parser rhs identity expand-rhs false)
        binding-vars (binding-vars-for-rule expanded-lhs)]
    `(let [f# (defn ~name
                ([] (~name {}))
                ([{:syms ~(vec (vars lhs)) :as ~'args}] (~name (working-memory) ~'args))
                ([~'wm ~'args]
                   (debug "rule" '~name '~*ns*)
                   (for [vars# (check-rule '~(vec expanded-lhs) ~'wm ~'args)
                         :let [{:syms ~(vec (concat (all-vars lhs) (vars lhs)))} vars#
                               ~'*matches* (map val (sort-by key (dissoc (purge-match-vars vars#) '~@binding-vars)))]]
                     (do
                       (debug "rhs" vars#)
                       ~@rhs))))]
       (debug "defining rule" '~name)
       (when-not (= '~lhs '~expanded-lhs)
         (debug "expanded" '~lhs)
         (debug "    into" '~expanded-lhs))
       (alter-meta! f# merge {:lhs '~lhs :rhs '~rhs :doc ~(apply str doc) :salience ~salience})
       (swap! *net* update-in [:productions] conj f#)
       f#)))

(defmacro with-cache [cache-name key & f]
  (let [cache-name (keyword cache-name)]
    `(let [key# ~key]
       (if-not (contains? ('~cache-name @*net*) key#)
         (let [v# (do ~@f)]
           (swap! *net* assoc-in ['~cache-name key#] v#)
           v#)
         (get-in @*net* ['~cache-name key#])))))

(defn join-on [x y]
  (let [vars-and-match-vars #(set (concat (remove '#{_} (all-vars %)) (vars %)))]
    (intersection (vars-and-match-vars x) (vars-and-match-vars y))))

(defn var-to-index [c]
  (loop [[v & vs] (vars c)
         acc {}]
    (if v
      (recur vs (if (acc v)
                  acc
                  (assoc acc v (var-sym (inc (count acc))))))
      acc)))

(defn ordered-vars [c]
  (->> (var-to-index c) vals sort vec))

(defn tree-eval-walk [locals]
  (fn [form]
    (condp some [form]
      seq? (with-cache expression-cache form
             (eval form))
      locals (locals form)
      form)))

(defmacro tree-eval [tree]
  (let [locals (keys (select-keys &env (filter-walk symbol? tree)))
        locals (into {} (map #(vector (list 'quote %) %) locals))]
    `(let [real-locals# ~locals]
       (postwalk (tree-eval-walk real-locals#) '~tree))))

(defn uses-*matches*? [c]
  (boolean (some '#{*matches*} (flatten c))))

(defn predicate-for [c]
  (with-cache predicate c
    (let [args (ordered-vars c)
          src `(fn [~@args & [~'*matches*]] ~c)
          meta (meta c)]
      (debug " compiling" c)
      (binding [*ns* (or (:ns meta) *ns*)]
        (with-meta (eval src) (merge meta {:src c :args args :uses-*matches* (uses-*matches*? c)}))))))

(defn alias-match-vars [m]
  (merge m
         (zipmap (map (comp var-sym name) (keys m)) (vals m))))

(defn match-using-predicate [c wme]
  (let [predicate (predicate-for c)]
    (try
      (when-let [result (predicate wme)]
        (debug " evaluated to true" wme)
        (merge
         {'?1 wme}
         (when (matcher? c) (alias-match-vars result))))
      (catch RuntimeException e
        (debug " threw non fatal" e)))))

(defn match-triplet [c wme]
  (loop [[v & vs] wme [t & ts] c m {}]
    (if v
      (condp some [t]
        #{v} (recur vs ts m)
        is-var? (recur vs ts (assoc m t v))
        nil)
      (do
        (debug " evaluated to true" wme)
        m))))

(defn predicate? [c]
  (-> c first
      ((some-fn
        (every-pred
         symbol? (partial ns-resolve (or (-> c meta :ns) *ns*)))
        (every-pred
         (complement symbol?) ifn?)))))

(defn bind [to expr] expr)
(defn constraint [expr] expr)

(defn constraint? [c]
  (and (sequential? c)
       (= 'mimir.well/constraint (first c))))

(defn multi-var-predicate? [c]
  (and (predicate? c) (or (> (count (vars c)) 1) (constraint? c))))

(defn multi-var-predicate-placeholder [c]
  (let [pred (predicate-for c)]
    (debug " more than one argument, needs beta network")
    (with-meta (zipmap (-> pred meta :args) (repeat pred))
      (assoc (meta pred) :pred pred))))

(defn match-wme [c wme]
  (if (predicate? c)
    (match-using-predicate c wme)
    (match-triplet c wme)))

(defn ^:private wm-crud [action test msg fact]
  (when (test (working-memory) fact)
    (debug msg " fact" fact)
    (swap! *net* update-in [:working-memory] action fact)
    (doseq [c (keys (:alpha-network @*net*))
            :let [match (match-wme c fact)]
            :when match]
      (debug " alpha network change" match)
      (swap! *net* update-in [:alpha-network] #(merge-with action % {c match}))))
  fact)

(defn fact [fact]
  (wm-crud conj (complement contains?) "asserting" fact))

(defn retract* [fact]
  (wm-crud disj contains? "retracting" fact))

(defn update [fact f & args]
  (let [wm (or (first (filter #(match % fact) (working-memory)))
               fact)]
    (retract* wm)
    (mimir.well/fact (condp some [f]
                       fn? (apply f wm args)
                       vector? (let [[a & _] args
                                     args (if (fn? a) args [(constantly a)])]
                                 (apply update-in wm f args))
                       f))))

(defmacro facts [& wms]
  (when wms
    `(doall
      (for [wm# ~(vec (parser wms identity quote-fact false))]
        (fact wm#)))))

(defn fold-into [ctor coll]
  (r/fold (r/monoid into ctor) conj coll))

(defn matching-wmes
  ([c] (matching-wmes c (working-memory) false))
  ([c wm needs-beta?]
     (debug "condition" c)
     (if (or ((some-fn multi-var-predicate? binding?) c)
             needs-beta?)
       #{(multi-var-predicate-placeholder c)}
       (->> wm
            (map #(match-wme c %))
            (remove nil?)
            set))))

(defn alpha-network-lookup [c wm needs-beta?]
  (with-cache alpha-network c
    (matching-wmes c wm needs-beta?)))

(defn alpha-memory
  ([c] (alpha-memory c (working-memory) false))
  ([c wm needs-beta?]
     (let [var-to-index (var-to-index c)
           vars-by-index (map-invert var-to-index)]
       (->> (alpha-network-lookup (with-meta (postwalk-replace var-to-index c) (meta c)) wm needs-beta?)
            (map #(rename-keys (with-meta % (merge (meta %) (postwalk-replace vars-by-index (meta %)))) vars-by-index))))))

(defn cross [left right]
  (debug " nothing to join on, treating as or")
  (set
   (for [x left y right]
     (merge x y))))

(defn multi-var-predicate-node? [am]
  (and (seq? am) (= 1 (count am))
       (fn? (-> am first meta :pred))))

(defn permutations* [n coll]
  (if (zero? n)
    [[]]
    (->> (permutations* (dec n) coll)
         (r/mapcat #(r/map (fn [x] (cons x %)) coll)))))

(defn permutations
  ([coll] (permutations (count coll) coll))
  ([n coll]
     (fold-into vector (permutations* n coll))))

(defn predicate-invoker [args join-on binding-vars uses-*matches*]
  (with-cache predicate-invokers [args join-on binding-vars uses-*matches*]
    (eval `(fn [pred# {:syms [~@(filter join-on args)] :as matches#}]
             (let [matches# (when ~uses-*matches*
                              (vals (dissoc (purge-match-vars matches#) '~@binding-vars)))]
               (fn [[~@(remove join-on args)]]
                 (pred# ~@args matches#)))))))

(defn deal-with-multi-var-predicates [c1-am c2-am join-on c2 binding-vars]
  (let [pred (-> c2-am first meta :pred)
        args (-> c2-am first meta :args)
        bind-var (binding-var c2)
        matcher ((some-fn matcher? constraint? c2))
        uses-*matches* (-> pred meta :uses-*matches*)
        join-on (if bind-var (conj join-on bind-var) join-on)
        needed-args (vec (remove join-on args))
        permutated-wm (permutations (count needed-args) (working-memory))
        invoker (predicate-invoker args join-on binding-vars uses-*matches*)
        join-fn (fn [m]
                  (let [invoker (invoker pred m)]
                    (->> permutated-wm
                         (r/map (fn [wm]
                                  (try
                                    (when-let [r (invoker wm)]
                                      (merge m
                                             (zipmap needed-args wm)
                                             (when matcher
                                               (alias-match-vars r))
                                             (when bind-var
                                               {bind-var r})))
                                    (catch RuntimeException e
                                      (debug " threw non fatal" e)))))
                         (r/remove nil?))))]
    (debug " multi-var-predicate")
    (debug " args" args)
    (debug " known args" join-on "- need to find" needed-args)
    (debug " permutations of wm" (ellipsis permutated-wm))
    (->> c1-am
         (r/mapcat join-fn)
         (fold-into vector))))

(defn beta-join-node [c2 c1-am binding-vars wm]
  (let [c2-am (alpha-memory c2 wm (some binding-vars (vars c2)))]
    (with-cache beta-join-nodes [c1-am c2-am]
      (let [join-on (join-on (-> c1-am first keys) c2)]
        (debug "join" join-on)
        (debug "  left" (ellipsis c1-am))
        (debug " right" (ellipsis c2-am))
        (let [result (cond
                      (multi-var-predicate-node? c2-am) (deal-with-multi-var-predicates
                                                          c1-am c2-am
                                                          join-on c2 binding-vars)
                      (empty? join-on) (cross c1-am c2-am)
                      :else (join c1-am c2-am))]
          (debug "result" (ellipsis result))
          result)))))

(defn order-conditions [cs]
  (mapcat #(concat (sort-by (comp count vars) (remove constraint? %))
                   (filter constraint? %))
          (partition-by binding? cs)))

(defn check-rule [cs wm args]
  (debug "conditions" cs)
  (let [binding-vars (binding-vars-for-rule cs)]
    (loop [[c & cs] (order-conditions cs)
           matches #{args}]
      (if-not c
        matches
        (recur cs (beta-join-node c matches binding-vars wm))))))

(defn salience [p]
  (or (-> p meta :salience) 0))

(defn run-once
  ([] (run-once (working-memory) (productions)))
  ([wm productions]
     (->> productions (sort-by salience) vec
          ;; This is not thread safe.
          ;; (r/mapcat #(% wm {}))
          ;; (fold-into vector)
          (mapcat #(% wm {}))
          doall)))

(defn run*
  ([] (repeatedly run-once)))

(defn run
  ([] (run *net*))
  ([net]
     (binding [*net* net]
       (loop [wm (working-memory)
              productions (:productions @net)
              acc #{}]
         (let [acc (union (set (run-once wm productions)) acc)]
           (if (seq (difference (working-memory) wm))
             (recur (working-memory) productions acc)
             acc))))))

(defn reset []
  (reset! *net* (create-net)))

(defmacro assert
  ([fact]
     `(let [fact# (list ~@(quote-non-vars fact))]
        (fact fact#)))
  ([id rel attr]
     `(assert ~(list id rel attr))))

(defmacro retract
  ([fact]
     `(let [fact# (list ~@(quote-non-vars fact))]
        (retract* fact#)))
  ([id rel attr]
     `(retract ~(list id rel attr))))

(defn different* [f xs]
  (apply distinct? (map f (maybe-singleton-coll xs))))

(defmacro different
  ([f] `(different ~f ~'*matches*))
  ([f xs]
     (if ((some-fn set? vector?) f)
       (map #(do `(constraint (different ~% ~xs))) f)
       `(constraint (different* ~f ~xs)))))

(defmacro all-different
  ([] `(different identity))
  ([& xs]
     `(different identity ~(vec xs))))

(defn same*
  ([test pred xs]
     (test (for [x xs y (remove #{x} xs)]
             (pred x y)))))

(defmacro not-same
  ([pred] `(not-same ~pred ~'*matches*))
  ([pred xs]
     (if ((some-fn set? vector?) pred)
       (map #(do `(constraint (not-same ~% ~xs))) pred)
       `(constraint (same* (partial not-any? true?) ~pred (maybe-singleton-coll ~xs))))))

(defn same [pred & xs]
  (if ((some-fn set? vector?) pred)
    (map #(list 'same % xs) pred)
    `(same* (partial every? true?) ~pred (maybe-singleton-coll ~xs))))

(defmacro gen-vars
  ([n] `(gen-vars ~n ~(gensym)))
  ([n prefix]
     `(vec (map #(var-sym (str '~prefix "-" %))
                (range 1 (inc ~n))))))

(defmacro unique [xs]
  (concat
   (for [[x y] (partition 2 1 xs)]
     `(pos? (compare ~x ~y)))
   (list (list 'identity xs))))

(defmacro take-unique [n]
  `(unique ~(gen-vars (eval n))))

(defmacro take-distinct [n]
  `(identity ~(gen-vars (eval n))))

(defn not-in [set]
  (complement set))

(defn is-not [x]
  (partial not= x))

(defmacro constrained-match [m x]
  `(some #(match % ~m) ~x))

(defmacro constrain
  ([m] `(constraint (constrained-match ~m ~'*matches*)))
  ([x m]`(constraint (constrained-match ~m ~x))))

(defn version []
  (-> "project.clj" clojure.java.io/resource
      slurp read-string (nth 2)))

(defn -main [& args]
  (println)
  (println "Welcome to Mímir |" (version) "| Copyright © 2012-13 Håkan Råberg")
  (println)
  (require 'clojure.main)
  (clojure.main/repl :init #(in-ns 'mimir.well)))