Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
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
ohpauleez authored and David Nolen committed Oct 26, 2012
1 parent 84b625a commit e33668f
Show file tree
Hide file tree
Showing 3 changed files with 281 additions and 7 deletions.
4 changes: 3 additions & 1 deletion .gitignore
Expand Up @@ -2,4 +2,6 @@
*.jar
*.org
*.patch
target/
*.diff
*.swp
target/
195 changes: 190 additions & 5 deletions src/main/clojure/cljs/core/logic.cljs
Expand Up @@ -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)

Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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)))


89 changes: 88 additions & 1 deletion src/test/cljs/cljs/core/logic/tests.cljs
Expand Up @@ -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'")
Expand Down Expand Up @@ -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

Expand Down Expand Up @@ -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
)
Expand Down

0 comments on commit e33668f

Please sign in to comment.