Permalink
Browse files

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
  • Loading branch information...
1 parent 84b625a commit e33668ff0bd76aded94b7911e498c62473e47a6f @ohpauleez ohpauleez committed with David Nolen Oct 24, 2012
Showing with 281 additions and 7 deletions.
  1. +3 −1 .gitignore
  2. +190 −5 src/main/clojure/cljs/core/logic.cljs
  3. +88 −1 src/test/cljs/cljs/core/logic/tests.cljs
View
@@ -2,4 +2,6 @@
*.jar
*.org
*.patch
-target/
+*.diff
+*.swp
+target/
@@ -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))))
+ (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)))
+
+
@@ -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'")
@@ -821,6 +822,71 @@
'({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
(println "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
)

0 comments on commit e33668f

Please sign in to comment.