Multi-output rules running

Author: Paula Gearon

src/naga/lang/pabu.clj

@@ -67,16 +67,16 @@ Parses code and returns Naga rules."
 
 (def RuleAST
  {:type (s/eq :rule)
- :head [(s/one VK "property")
- (s/one Args "arguments")]
+ :head [[(s/one VK "property")
+  (s/one Args "arguments")]]
  :body [Predicate]})
 
 (s/defn ast->rule :- Rule
  "Converts the rule structure returned from the parser"
  [{:keys [head body] :as rule-ast} :- RuleAST]
- (r/rule (triplet head)
+ (r/rule (map triplet head)
  (mapcat structure body)
- (-> head first name gensym name)))
+ (-> head ffirst name gensym name)))
 
 (s/defn read-str :- {:rules [Rule]
  :axioms [Axiom]}

src/naga/lang/parser.clj

@@ -47,7 +47,7 @@
 
 ;; a clause with a rule
 (defparser nonbase-clause []
- (let->> [head (>> opt-whitespace (structure))
+ (let->> [head (>> opt-whitespace (structures))
  _ (>> opt-whitespace (string ":-") opt-whitespace)
  body (structures)
  _ (>> opt-whitespace (char \.) opt-whitespace)]

src/naga/rules.clj

@@ -15,7 +15,8 @@
  ([head body name]
  (assert (and (sequential? body) (or (empty? body) (every? sequential? body)))
  "Body must be a sequence of constraints")
- (assert (sequential? head) "Head must be a constraint")
+ (assert (and (sequential? head) (or (empty? head) (every? sequential? head)))
+ "Head must be a sequence of constraints")
  (st/new-rule head body name)))
 
 (s/defn named-rule :- Rule
@@ -54,7 +55,7 @@
  [& [f :as rs]]
  (let [[nm# rs#] (if (string? f) [f (rest rs)] [(gen-rule-name) rs])
  not-sep# (partial not= :-)
- head# (de-ns (first (take-while not-sep# rs#)))
+ head# (map de-ns (take-while not-sep# rs#))
  body# (map de-ns (rest (drop-while not-sep# rs#)))]
  `(rule (quote ~head#) (quote ~body#) ~nm#)))
 
@@ -100,7 +101,7 @@
  (let [name-bodies (u/mapmap :name :body rules)
  triggers (fn [head] (mapcat (partial find-matches head) name-bodies))
  deps (fn [{:keys [head body name]}]
- (st/new-rule head body name (triggers head)))]
+ (st/new-rule head body name (mapcat triggers head)))]
  {:rules (u/mapmap :name identity (map deps rules))
  :axioms axioms}))
 

src/naga/schema/structs.clj

@@ -44,6 +44,7 @@
 (def Pattern (s/if list? FilterPattern EPVPattern))
 
 (def Body [Pattern])
+(def Head [EPVPattern])
 
 (def ConstraintData
  {:last-count s/Num ;; The count from the previous execution
@@ -64,7 +65,7 @@
 ;; the body is conjunction of pattern matches.
 ;; All rules have a name, and a list of names of downstream rules.
 (s/defrecord Rule
- [head :- EPVPattern
+ [head :- Head
  body :- Body
  name :- s/Str
  salience :- s/Num
@@ -73,16 +74,16 @@
  execution-count :- (s/atom s/Num)])
 
 (s/defn new-rule
- ([head :- EPVPattern
+ ([head :- Head
  body :- Body
  name :- s/Str]
  (new-rule head body name []))
- ([head :- EPVPattern
+ ([head :- Head
  body :- Body
  name :- s/Str
  downstream :- [RulePatternPair]]
  (new-rule head body name downstream 0))
- ([head :- EPVPattern
+ ([head :- Head
  body :- Body
  name :- s/Str
  downstream :- [RulePatternPair]

src/naga/storage/memory/core.clj

@@ -5,9 +5,10 @@
  [clojure.string :as str]
  [clojure.core.cache :as c]
  [schema.core :as s]
- [naga.schema.structs :as st :refer [EPVPattern FilterPattern Pattern Results Value]]
+ [naga.schema.structs :as st :refer [EPVPattern FilterPattern Pattern Results Value Axiom]]
  [naga.store :as store]
  [naga.util :as u]
+ [naga.storage.store-util :as store-util]
  [naga.storage.memory.index :as mem])
  (:import [clojure.lang Symbol IPersistentVector IPersistentList]
  [naga.store Storage]))
@@ -166,7 +167,7 @@
 
 (s/defn modify-pattern :- [s/Any]
  "Creates a new EPVPattern from an existing one, based on existing bindings.
- Uses the mapping to copy from columns in 'existing' to overwrite variableis in 'pattern'.
+ Uses the mapping to copy from columns in 'existing' to overwrite variables in 'pattern'.
  The variable locations have already been found and are in the 'mapping' argument"
  [existing :- [Value]
  mapping :- {s/Num s/Num}
@@ -269,19 +270,71 @@
  {:cols (st/vars fpath)})]
  (reduce ljoin part-result rpath)))
 
+(s/defn group-exists? :- [s/Any]
+ "Determines if a group is instantiating a new piece of data,
+ and if so checks if it already exists."
+ [storage
+ group :- [Axiom]]
+ (let [[entity _ val] (some (fn [[_ a _ :as axiom]] (when (= a :db/ident) axiom)) group)]
+ (seq (store/resolve-pattern storage ['?e :db/ident val]))))
+
+(s/defn offset-mappings :- {s/Num s/Num}
+ "Build a pattern->data mapping that returns offsets into a pattern mapped to corresponding
+ offsets into data. If a data offset is negative, then this indicates a node must be built
+ instead of reading from the data."
+ [storage
+ full-pattern :- [s/Any]
+ data :- Results]
+ (let [data-vars (:cols (meta data))
+ known-vars (set data-vars)
+ var-positions (matching-vars full-pattern data-vars)
+ fresh-map (->> full-pattern
+ (filter #(and (st/vartest? %) (not (known-vars %))))
+ set
+ (map-indexed (fn [n v] [v (- (inc n))]))
+ (into {}))]
+ (->> full-pattern
+ (map-indexed
+ (fn [n v] (if (and (nil? (var-positions n)) (st/vartest? v)) [n (fresh-map v)])))
+ (filter identity)
+ (into var-positions))))
+
+(s/defn new-nodes :- [s/Num]
+ "Returns all the new node references that appears in a map of offsets.
+ Node references are negative numbers."
+ [offset-map :- {s/Num s/Num}]
+ (seq (set (filter neg? (vals offset-map)))))
 
 (s/defn project :- Results
- "Converts each row from a result, into just the requested columns, as per the pattern arg.
- Any specified value in the pattern will be copied into that position in the projection.
- e.g. For pattern [?h1 :friend ?h2]
+ "Converts each row from a result, into just the requested columns, as per the patterns arg.
+ Any specified value in the patterns will be copied into that position in the projection.
+ Unbound patterns will generate new nodes for each row.
+ e.g. For patterns [[?h1 :friend ?h2]]
  data: [[h1=frodo h3=bilbo h2=gandalf]
  [h1=merry h3=pippin h2=frodo]]
  leads to: [[h1=frodo :friend h2=gandalf]
  [h1=merry :friend h2=frodo]]"
- [pattern :- [s/Any]
+ [storage
+ patterns :- [[s/Any]]
+ data :- Results]
+ (let [full-pattern (vec (apply concat patterns))
+ pattern->data (offset-mappings storage full-pattern data)
+ nodes (new-nodes pattern->data)]
+ (map #(store-util/project-row storage full-pattern nodes pattern->data %) data)))
+
+(s/defn insert-project :- Results
+ "Similar to project, only the generated data will be in triples for insertion.
+ If triples describe entities with existing dc/ident fields, then they will be dropped."
+ [storage
+ patterns :- [[s/Any]]
  data :- Results]
- (let [pattern->data (matching-vars pattern (:cols (meta data)))]
- (map #(modify-pattern % pattern->data pattern) data)))
+ (let [full-pattern (vec (apply concat patterns))
+ pattern->data (offset-mappings storage full-pattern data)
+ nodes (new-nodes pattern->data)]
+ (->> data
+ (map #(partition 3 (store-util/project-row storage full-pattern nodes pattern->data %)))
+ (remove (partial group-exists? storage))
+ (apply concat))))
 
 (s/defn add-to-graph
  [graph
@@ -333,15 +386,15 @@
  (count-fn pattern)
  (count (mem/resolve-pattern graph pattern))))
 
- (query [_ output-pattern patterns]
- (project output-pattern (join-patterns graph patterns)))
+ (query [this output-pattern patterns]
+ (project this output-pattern (join-patterns graph patterns)))
 
  (assert-data [_ data]
  (->MemoryStore (add-to-graph graph data)))
 
- (query-insert [this assertion-pattern patterns]
+ (query-insert [this assertion-patterns patterns]
  (->> (join-patterns graph patterns)
- (project assertion-pattern)
+ (insert-project this assertion-patterns)
  (add-to-graph graph)
  ->MemoryStore)))
 

src/naga/storage/store_util.clj

@@ -11,13 +11,18 @@
  'pattern' must be a vector.
  The index mappings have already been found and are in the 'mapping' argument"
  [storage
- patterns :- [EPVPattern]
+ wide-pattern :- [s/Any]
+ nodes :- (s/maybe [s/Num])
  mapping :- {s/Num s/Num}
  row :- [Value]]
- (let [wide-pattern (vec (apply concat patterns))
- get-node (memoize (fn [n] (store/new-node storage)))
+ (let [get-node (memoize (fn [n] (store/new-node storage)))
+ node-statements (apply concat
+ (map (fn [i]
+ (let [node (get-node i)]
+ [node :db/ident node]))
+ nodes))
  update-pattern (fn [p [t f]]
  (let [v (if (< f 0) (get-node f) (nth row f))]
  (assoc p t v)))]
- (partition 3
-  (reduce update-pattern wide-pattern mapping))))
+ (concat node-statements
+ (reduce update-pattern wide-pattern mapping))))

src/naga/store.clj

@@ -11,9 +11,9 @@
  (container-property [store data] "Returns the property to use to indicate a containership relation for given data. Must be in the naga namespace")
  (resolve-pattern [store pattern] "Resolves a pattern against storage")
  (count-pattern [store pattern] "Counts the size of a pattern resolition against storage")
- (query [store output-pattern patterns] "Resolves a set of patterns (if not already resolved) and joins the results")
+ (query [store output-patterns patterns] "Resolves a set of patterns (if not already resolved) and joins the results")
  (assert-data [store data] "Inserts new axioms")
- (query-insert [store assertion-pattern patterns] "Resolves a set of patterns, joins them, and inserts the set of resolutions"))
+ (query-insert [store assertion-patterns patterns] "Resolves a set of patterns, joins them, and inserts the set of resolutions"))
 
 (def registered-stores (atom {}))
 

test/naga/storage/test_memory.clj

@@ -59,7 +59,7 @@
 
 (defn unordered-query
  [s op pattern]
- (into #{} (query s op pattern)))
+ (into #{} (query s [op] pattern)))
 
 (deftest test-join
  (let [s (assert-data empty-store jdata)

test/naga/storage/test_query.clj

@@ -91,3 +91,13 @@
  [?a :b ?c]
  (not= ?e ?a)]
  path4))))
+
+(deftest var-mapping
+ (let [m1 (matching-vars `[?a :rel ?c] `[?a ?b ?c] )
+ m2 (matching-vars `[?b :rel ?f] `[?a ?b ?c ?d ?e ?f])
+ m3 (matching-vars `[?b :rel ?f ?b :r2 ?e] `[?a ?b ?c ?d ?e ?f])
+ m4 (matching-vars `[?x :rel ?f ?x :r2 ?e] `[?a ?b ?c ?d ?e ?f])]
+ (is (= m1 {0 0, 2 2}))
+ (is (= m2 {0 1, 2 5}))
+ (is (= m3 {0 1, 2 5, 3 1, 5 4}))
+ (is (= m4 {2 5, 5 4}))))

test/naga/test_pabu.clj

@@ -26,7 +26,7 @@ parent(A, F) :- father(A, F).
  [(r [?b :parent ?c] :- [?a :sibling ?b] [?a :parent ?c])
  (r [?a :brother ?b] :- [?a :sibling ?b] [?b :gender :male])
  (r [?a :uncle ?c] :- [?a :parent ?b] [?b :brother ?c])
- (rule '[?a :sibling ?b] ['[?a :parent ?p] '[?b :parent ?p] (list not= '?a '?b)])
+ (rule '[[?a :sibling ?b]] ['[?a :parent ?p] '[?b :parent ?p] (list not= '?a '?b)])
  (r [?f :gender :male] :- [?a :father ?f])
  (r [?a :parent ?f] :- [?a :father ?f])])