From e33668ff0bd76aded94b7911e498c62473e47a6f Mon Sep 17 00:00:00 2001
From: Paul deGrandis <paul.degrandis@gmail.com>
Date: Wed, 24 Oct 2012 10:52:24 -0700
Subject: [PATCH] Partial map support and easy unification ported to CLJS

Update all the necessary protocols for partial-maps

Correct PMaps protocols to dispatch to the map protocols

Update unify to dispatch to the -walk protocols

Updated partial map to use unify protocol in CLJS

Added CLJS tests for unifier, binding-map, partial-map

Patching up and doc'ing the failing tests for unifier/binding-map/pmap

git now ignores Vim files patches as .diff

Remove print statements from the CLJS tests
---
 .gitignore                               |   4 +-
 src/main/clojure/cljs/core/logic.cljs    | 195 ++++++++++++++++++++++-
 src/test/cljs/cljs/core/logic/tests.cljs |  89 ++++++++++-
 3 files changed, 281 insertions(+), 7 deletions(-)

diff --git a/.gitignore b/.gitignore
index a5879f45..a6d4759f 100644
--- a/.gitignore
+++ b/.gitignore
@@ -2,4 +2,6 @@
 *.jar
 *.org
 *.patch
-target/
\ No newline at end of file
+*.diff
+*.swp
+target/
diff --git a/src/main/clojure/cljs/core/logic.cljs b/src/main/clojure/cljs/core/logic.cljs
index 99db61fc..db6e721d 100644
--- a/src/main/clojure/cljs/core/logic.cljs
+++ b/src/main/clojure/cljs/core/logic.cljs
@@ -3,7 +3,8 @@
   (:use-macros [cljs.core.logic.macros :only
                 [defne defna defnu fresh == -inc]])
   (:require-macros [cljs.core.logic.macros :as m])
-  (:require [clojure.set :as set]))
+  (:require [clojure.set :as set])
+  (:use [clojure.walk :only [postwalk]]))
 
 (def ^{:dynamic true} *occurs-check* true)
 
@@ -298,9 +299,12 @@
   LConsSeq
   (-lfirst [_] a)
   (-lnext [_] d)
-  IPrintable
-  (-pr-seq [this opts]
-    (pr-sequential pr-seq "(" " " ")" opts (lcons-pr-seq this)))
+  ;;IPrintable
+  ;;(-pr-seq [this opts]
+  ;;  (pr-sequential pr-seq "(" " " ")" opts (lcons-pr-seq this)))
+  IPrintWithWriter
+  (-pr-writer [this writer opts]
+    ^:deprecation-nowarn  (pr-sequential-writer writer pr-writer "(" " " ")" opts (lcons-pr-seq this)))
   IEquiv
   (-equiv [this o]
     (or (identical? this o)
@@ -811,4 +815,185 @@
 (defn prefix [s <s]
   (if (= s <s)
     ()
-    (conj (prefix (rest s) <s) (first s))))
\ No newline at end of file
+    (conj (prefix (rest s) <s) (first s))))
+
+;; ==============================================================================
+;; partial-maps
+
+(defprotocol IUnifyWithPMap
+  (unify-with-pmap [pmap u s]))
+
+(defrecord PMap []
+  IUnifyWithMap
+  (-unify-with-map [v u s]
+    (loop [ks (keys v) s s]
+      (if (seq ks)
+        (let [kf (first ks)
+              uf (get u kf ::not-found)]
+          (if (= uf ::not-found)
+            nil
+            (if-let [s (-unify s (get v kf) uf)]
+              (recur (next ks) s)
+              nil)))
+        s)))
+
+  IUnifyWithPMap
+  (unify-with-pmap [v u s]
+    (-unify-with-map v u s))
+
+  IUnifyTerms
+  (-unify-terms [u v s]
+    (unify-with-pmap v u s))
+
+  IUnifyWithLVar
+  (-unify-with-lvar [v u s]
+    (-ext-no-check s u v)))
+
+(extend-protocol IUnifyWithPMap
+  nil
+  (unify-with-pmap [v u s] nil)
+
+  js/Object
+  (unify-with-pmap [v u s] nil)
+
+  cljs.core.logic.LVar
+  (unify-with-pmap [v u s]
+    (-ext s v u))
+
+  ObjMap
+  (unify-with-pmap [v u s]
+    (-unify-with-map u v s))
+
+  PersistentArrayMap
+  (unify-with-pmap [v u s]
+    (-unify-with-map u v s))
+
+  PersistentHashMap
+  (unify-with-pmap [v u s]
+    (-unify-with-map u v s)))
+
+(defn partial-map
+  "Given map m, returns partial map that unifies with maps even if it doesn't share all of the keys of that map.
+   Only the keys of the partial map will be unified:
+
+   (m/run* [q]
+         (m/fresh [pm x]
+                (m/== pm (partial-map {:a x}))
+                (m/== pm {:a 1 :b 2})
+                (m/== pm q)))
+   ;;=> ({:a 1})"
+  [m]
+  (map->PMap m))
+
+;; =============================================================================
+;; Easy Unification
+
+(defn- lvarq-sym? [s]
+  (and (symbol? s) (= (first (str s)) \?)))
+
+(defn- proc-lvar [lvar-expr store]
+  (let [v (if-let [u (@store lvar-expr)]
+            u
+            (lvar lvar-expr))]
+    (swap! store conj [lvar-expr v])
+    v))
+
+(defn- lcons-expr? [expr]
+  (and (seq? expr) (some '#{.} (set expr))))
+
+(declare prep*)
+
+(defn- replace-lvar [store]
+  (fn [expr]
+    (if (lvarq-sym? expr)
+      (proc-lvar expr store)
+      (if (lcons-expr? expr)
+        (prep* expr store)
+        expr))))
+
+(defn- prep*
+  ([expr store] (prep* expr store false false))
+  ([expr store lcons?] (prep* expr store lcons? false))
+  ([expr store lcons? last?]
+     (let [expr (if (and last? (seq expr))
+                  (first expr)
+                  expr)]
+       (cond
+        (lvarq-sym? expr) (proc-lvar expr store)
+        (seq? expr) (if (or lcons? (lcons-expr? expr))
+                      (let [[f & n] expr
+                            skip (= f '.)
+                            tail (prep* n store lcons? skip)]
+                        (if skip
+                          tail
+                          (lcons (prep* f store) tail)))
+                      (postwalk (replace-lvar store) expr))
+        :else expr))))
+
+(defn prep
+  "Prep a quoted expression. All symbols preceded by ? will
+  be replaced with logic vars."
+  [expr]
+  (let [lvars (atom {})
+        prepped (if (lcons-expr? expr)
+                  (prep* expr lvars true)
+                  (postwalk (replace-lvar lvars) expr))]
+    (with-meta prepped {:lvars @lvars})))
+
+(defn unify [s u v]
+  (if (identical? u v)
+    s
+    (let [u (-walk s u)
+          v (-walk s v)]
+      (if (identical? u v)
+        s
+        (-unify-terms u v s)))))
+
+(defn unifier*
+  "Unify the terms u and w."
+  ([u w]
+     (first
+      (m/run* [q]
+        (== u w)
+        (== u q))))
+  ([u w & ts]
+     (apply unifier* (unifier* u w) ts)))
+
+(defn binding-map*
+  "Return the binding map that unifies terms u and w.
+  u and w should prepped terms."
+  ([u w]
+     (let [lvars (merge (-> u meta :lvars)
+                        (-> w meta :lvars))
+           s (unify empty-s u w)]
+       (when s
+         (into {} (map (fn [[k v]]
+                         [k (-reify s v)])
+                       lvars)))))
+  ([u w & ts]
+     (apply binding-map* (binding-map* u w) ts)))
+
+(defn unifier
+  "Unify the terms u and w. Will prep the terms."
+  ([u w]
+     {:pre [(not (lcons? u))
+            (not (lcons? w))]}
+     (let [up (prep u)
+           wp (prep w)]
+       (unifier* up wp)))
+  ([u w & ts]
+     (apply unifier (unifier u w) ts)))
+
+(defn binding-map
+  "Return the binding map that unifies terms u and w.
+  Will prep the terms."
+  ([u w]
+     {:pre [(not (lcons? u))
+            (not (lcons? w))]}
+     (let [up (prep u)
+           wp (prep w)]
+       (binding-map* up wp)))
+  ([u w & ts]
+     (apply binding-map (binding-map u w) ts)))
+
+
diff --git a/src/test/cljs/cljs/core/logic/tests.cljs b/src/test/cljs/cljs/core/logic/tests.cljs
index d1f6618e..d07ec6af 100644
--- a/src/test/cljs/cljs/core/logic/tests.cljs
+++ b/src/test/cljs/cljs/core/logic/tests.cljs
@@ -9,7 +9,8 @@
    [cljs.core.logic
     :only [pair lvar lcons -unify -ext-no-check -walk -walk*
            -reify-lvar-name empty-s to-s succeed fail s# u# conso
-           nilo firsto resto emptyo appendo membero *occurs-check*]]))
+           nilo firsto resto emptyo appendo membero *occurs-check*
+           unifier, binding-map, partial-map]]))
 
 (defn js-print [& args]
   (if (js* "typeof console != 'undefined'")
@@ -820,6 +821,71 @@
              (m/== q {nil :foo}))
            '({nil :foo})))
 
+;; -----------------------------------------------------------------------------
+;; Unifier
+
+(println "simple unifier")
+
+; test-unifier-1
+(assert (= (unifier '(?x ?y) '(1 2))
+         '(1 2)))
+
+; test-unifier-2
+(assert (= (unifier '(?x ?y 3) '(1 2 ?z))
+         '(1 2 3)))
+
+; test-unifier-3
+(assert (= (unifier '[(?x . ?y) 3] [[1 2] 3])
+         '[(1 2) 3]))
+
+; test-unifier-4
+;; Currently failes with:
+; Error: No protocol method IWithMeta.-with-meta defined for type object: [object Object]
+;(assert (= (unifier '(?x . ?y) '(1 . ?z))
+;         (lcons 1 '_.0)))
+
+; test-unifier-5
+;; Currently failes with:
+; Error: No protocol method IWithMeta.-with-meta defined for type object: [object Object]
+;(assert (= (unifier '(?x 2 . ?y) '(1 2 3 4 5))
+;         '(1 2 3 4 5)))
+
+; test-unifier-6
+;; Currently failes with:
+; Error: No protocol method IWithMeta.-with-meta defined for type object: [object Object]
+;(assert (= (unifier '(?x 2 . ?y) '(1 9 3 4 5))
+;         nil))
+
+; test-binding-map-1
+(assert (= (binding-map '(?x ?y) '(1 2))
+         '{?x 1 ?y 2}))
+
+; test-binding-map-2
+(assert (= (binding-map '(?x ?y 3) '(1 2 ?z))
+         '{?x 1 ?y 2 ?z 3}))
+
+; test-binding-map-3
+(assert (= (binding-map '[(?x . ?y) 3] [[1 2] 3])
+         '{?x 1 ?y (2)}))
+
+; test-binding-map-4
+;; Currently failes with:
+; Error: No protocol method IWithMeta.-with-meta defined for type object: [object Object]
+;(assert (= (binding-map '(?x . ?y) '(1 . ?z))
+;         '{?z _.0, ?x 1, ?y _.0}))
+
+; test-binding-map-5
+;; Currently failes with:
+; Error: No protocol method IWithMeta.-with-meta defined for type object: [object Object]
+;(assert (= (binding-map '(?x 2 . ?y) '(1 2 3 4 5))
+;         '{?x 1 ?y (3 4 5)}))
+
+; test-binding-map-6
+;; Currently failes with:
+; Error: No protocol method IWithMeta.-with-meta defined for type object: [object Object]
+;(assert (= (binding-map '(?x 2 . ?y) '(1 9 3 4 5))
+;         nil))
+
 ;; -----------------------------------------------------------------------------
 ;; Occurs Check
 
@@ -875,6 +941,27 @@
              (match-set #{:cat :bird :dog} q))
            '(_.0)))
 
+;; -----------------------------------------------------------------------------
+;; Partial maps
+
+(println "partial maps")
+
+;; Currently fails, unifies to: (#PMap {:a <lvar:x_3>}}
+;(assert (= '({:a 1})
+;         (run* [q]
+;               (fresh [pm x]
+;                      (== pm (partial-map {:a x}))
+;                      (== pm {:a 1 :b 2})
+;                      (== pm q)))))
+
+(assert (= '(1)
+         (run* [q]
+               (fresh [pm x]
+                      (== pm (partial-map {:a x}))
+                      (== pm {:a 1 :b 2})
+                      (== x q)))))
+
+
 (comment
   ;; FIXME: for some reason set #{:cat :bird} works on match-set call - David
   )