core.clj

(ns match.core
  (:use [clojure.core.logic.unify :only [unifier unifier* binding-map
                                         binding-map* prep replace-lvar
                                         lvarq-sym? rem-?]]
        [clojure.walk :only [postwalk]])
  (:require [clojure.core.logic.minikanren :as mk]))

;;borrowed from contrib, thanks steve
(defmacro cond-let
  "Takes a binding-form and a set of test/expr pairs. Evaluates each test
one at a time. If a test returns logical true, cond-let evaluates and
returns expr with binding-form bound to the value of test and doesn't
evaluate any of the other tests or exprs. To provide a default value
either provide a literal that evaluates to logical true and is
binding-compatible with binding-form, or use :else as the test and don't
refer to any parts of binding-form in the expr. (cond-let binding-form)
returns nil."
  [bindings & clauses]
  (let [binding (first bindings)]
    (when-let [[test expr & more] clauses]
      (if (= test :else)
        expr
        `(if-let [~binding ~test]
           ~expr
           (cond-let ~bindings ~@more))))))

(defn emittable [expr]
  (postwalk
   (fn [expr]
     (cond
      (mk/lvar? expr)
      `(clojure.core.logic.minikanren.LVar.
        ~(.name expr)
        ~(.hash expr)
        ~(.cs expr))
      (symbol? expr)
      `(quote ~expr)
      (seq? expr)
      `(list ~@expr)
      (mk/lcons? expr)
      `(clojure.core.logic.minikanren.LCons.
        ~(emittable (.a expr))
        ~(emittable (.d expr))
        -1)
      :else expr))
   expr))

(alter-var-root #'replace-lvar
                (constantly
                 (fn replace-lvar [store]
                   (fn [expr]
                     (cond
                      (lvarq-sym? expr)
                      (let [v (if-let [u (@store expr)]
                                u
                                (mk/lvar (rem-? expr)))]
                        (swap! store conj [expr v])
                        v)
                      (and (seq? expr)
                           (= (first expr) 'cons))
                      (let [[_ head tail] expr]
                        (mk/lcons head tail))
                      :else expr)))))

(defmacro cond-m [value & matches]
  (let [value-name (gensym)
        match-name (gensym)]
    `(let [~value-name ~value]
       (cond-let [~match-name nil]
                 ~@(for [m (partition-all 2 matches)
                         :let [[pattern body] m
                               lvars (keys (:lvars (meta (prep [pattern]))))
                               matcher `(binding-map* ~(let [p (prep [pattern])]
                                                         `(with-meta
                                                            ~(emittable p)
                                                            ~(emittable
                                                              (meta p))))
                                                      [~value-name])
                               body `(let [~(zipmap
                                             (->> lvars
                                                  (map name)
                                                  (map (partial drop 1))
                                                  (map (partial apply str))
                                                  (map symbol))
                                             (map #(list 'quote %) lvars))
                                           ~match-name]
                                       ~body)]
                         x [matcher body]]
                     x)))))

(defmacro mn [name-or-first-clause & bodies]
  (let [fn-name (if (symbol? name-or-first-clause)
                  name-or-first-clause
                  (gensym "fn"))
        bodies (if-not (symbol? name-or-first-clause)
                 (conj bodies name-or-first-clause)
                 bodies)]
    `(fn* ~fn-name
          ([arg#]
             (cond-m arg#
                     ~@bodies
                     ?# (throw
                         (IllegalArgumentException. "no matching clause")))))))


(comment

  ((mn
    (cons 1 ?a) (println a))
   '[1 2])

;; SECD

  ((mn
    [(cons ?v nil) ?e' () ()]
    v

    [(cons ?v nil) ?e' () (cons [?s ?e ?c] ?d)]
    (recur [(cons v s) e c d])

    [?s ?e (cons [:term [:lit ?n]] ?c) ?d]
    (recur [(cons [:int n] s) e c d])

    [?s ?e (cons [:term [:var ?x]] ?c) ?d]
    (recur [(cons (get e x) s) e c d])

    [?s ?e (cons [:term [:lam [?x ?t]]] ?c) ?d]
    (recur [(cons [:closure [e x t]] s) e c d])

    [?s ?e (cons [:term [:app [?t0 ?t1]]] ?c) ?d]
    (recur [s e (list* [:term t1] [:term t0] :apply c) d])

    [(cons :succ (cons [:int ?n] ?s)) ?e (cons :apply ?c) ?d]
    (recur [(cons [:int (inc n)] s) e c d])

    [(cons [:closure [?e' ?x ?t]] (cons ?v ?s)) ?e (cons :apply ?c) ?d]
    (recur [() (assoc e' x v) (list [:term t]) (cons [s e c d] d)]))
   ;;init
   ['() '{inc :succ} '([:term [:lit 1]] [:term [:var inc]] :apply) ()])
   ;; => [:int 2]
  )