Skip to content

Commit

Permalink
:concurrent & other
Browse files Browse the repository at this point in the history
  • Loading branch information
@rasom
rasom committed Mar 11, 2016
1 parent 3926a91 commit bbd3310
Show file tree
Hide file tree
Showing 9 changed files with 298 additions and 168 deletions.
155 changes: 87 additions & 68 deletions src/nal/deriver/matching.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,7 +9,7 @@
[set-functions :refer [f-map not-empty-diff? not-empty-inter?]]
[substitution :refer [munification-map substitute]]
[preconditions :refer [sets compound-precondition get-terms
implications-and-equivalences
implications-and-equivalences abs
preconditions-transformations]]
[normalization :refer [commutative-ops sort-commutative reducible-ops]
:as n]
Expand All @@ -22,42 +22,37 @@
`substitute `sets `some `deref `do `vreset! `volatile! `fn `mapv `if
`sort-commutative `n/reduce-ext-inter `n/reduce-symilarity `complement
`n/reduce-int-dif `n/reduce-and `n/reduce-ext-dif `n/reduce-image
`n/reduce-int-inter `n/reduce-neg `n/reduce-or `nil? `not `or
`implications-and-equivalences `get-terms `empty? `intersection
})
`n/reduce-int-inter `n/reduce-neg `n/reduce-or `nil? `not `or `abs
`implications-and-equivalences `get-terms `empty? `intersection})

(defn quote-operators
[statement]
(walk statement
(reserved-operators el) el
(and (symbol? el) (or (operator? el) (#{'Y 'X} el))) `'~el
(and (coll? el) (= 'quote (first el))
(= 'quote (first (second el))))
`(quote ~(second (second el)))
(and (coll? el) (= \a (first (str (first el)))))
(concat '() el)
(and (coll? el)
((complement map?) el)
(let [f (first el)]
(and
(not (reserved-operators :el))
(symbol? :el)
(or (operator? :el) (#{'Y 'X} :el))) `'~:el
(and (coll? :el)
((complement map?) :el)
(let [f (first :el)]
(and (not (reserved-operators f))
(not (fn? f)))))
(vec el)))
(vec :el)))

(defn form-conclusion
"Formation of cocnlusion in terms of task and truth/desire functions"
[{:keys [t1 t2 task-type]}
{c :statement tf :t-function pj :p/judgement df :d-function}]
(let [conclusion-type (if pj :judgement task-type)
conclusion {:statement c
:task-type conclusion-type}
conclusion (if (= :judgement conclusion-type)
(assoc conclusion :truth (list tf t1 t2))
conclusion)
conclusion (if (= :goal conclusion-type)
(assoc conclusion :desire (list df t1 t2))
conclusion)]
conclusion))
:task-type conclusion-type}]
(case conclusion-type
:judgement (assoc conclusion :truth (list tf t1 t2))
:goal (assoc conclusion :desire (list df t1 t2))
conclusion)))

(defn traverse-node
"Generates code for precondition node."
[vars result {:keys [conclusions children condition]}]
`(when ~(quote-operators condition)
~(when-not (zero? (count conclusions))
Expand All @@ -66,30 +61,40 @@
(quote-operators conclusions)))))
~@(map (fn [n] (traverse-node vars result n)) children)))

(defn traverse [vars tree]
(defn traversal
"Walk through preconditions tree and generates code for matcher."
[vars tree]
(let [results (gensym)]
`(let [~results (volatile! [])]
~(traverse-node vars results tree)
@~results)))

(defn replace-occurences
"Reblaces occurrences keywords from matcher's code by generated symbols."
[code]
(let [t-occurence (gensym) b-occurence (gensym)]
(walk code
(= :el :t-occurence) t-occurence
(= :el :b-occurence) b-occurence)))

(defn match-rules
[pattern rules task-type]
"Generates code of function that will match premises. Generated function
should be called with task and beleif as arguments."
[rules pattern task-type]
(let [t1 (gensym) t2 (gensym)
task (gensym) belief (gensym)
t-occurence (gensym) b-occurence (gensym)
truth-kw (if (= :goal task-type) :desire :truth)]
(walk `(fn [{p1# :statement ~t1 ~truth-kw :t-occurence :occurence :as ~task}
{p2# :statement ~t2 :truth :b-occurence :occurence :as ~belief}]
(match [p1# p2#] ~(quote-operators pattern)
~(traverse {:t1 t1
:t2 t2
:task task
:belief belief
:task-type task-type}
rules)
:else nil))
(= :el :t-occurence) t-occurence
(= :el :b-occurence) b-occurence)))
(replace-occurences
`(fn [{p1# :statement ~t1 ~truth-kw :t-occurence :occurence :as ~task}
{p2# :statement ~t2 :truth :b-occurence :occurence :as ~belief}]
(match [p1# p2#] ~(quote-operators pattern)
~(traversal {:t1 t1
:t2 t2
:task task
:belief belief
:task-type task-type}
rules)
:else nil)))))

(defn find-and-replace-symbols
"Replaces all terms in statemnt to placeholders that will be used in pattern
Expand All @@ -112,7 +117,9 @@
s))]
[@sym-map result]))

(defn main-pattern [premise]
(defn symbols->placeholders
"Replaces "
[premise]
(second (find-and-replace-symbols premise "x")))

(defn symbol-ordering-keyfn
Expand Down Expand Up @@ -153,20 +160,30 @@

(defn get-desire-fn [post] (find-kv-by-prefix ":d/" post))

(defn get-aliases
"Filter map of symbols and keep only aliases of symbol that have lower
order-key (to avoid preconditions with swapped symbols, like (= x1 x2)
(= x2 x1)."
[symbols-map alias]
(let [sym (symbols-map alias)]
(->> (dissoc symbols-map alias)
(filter (fn [[a v]]
(and (< (symbol-ordering-keyfn alias)
(symbol-ordering-keyfn a))
(= v sym))))
keys)))

(defn aliases->conditins
[symbols-map alias]
(mapcat #(list `= alias %) (get-aliases symbols-map alias)))

(defn check-conditions [syms]
(filter not-empty
(keep
(fn [[alias sym]]
(let [aliases (filter (fn [[a v]]
(and (< (symbol-ordering-keyfn alias)
(symbol-ordering-keyfn a)) (= v sym)))
(dissoc syms alias))]
(mapcat (fn [[a]] `(= ~alias ~a)) aliases)))
syms)))
(->> (keys syms)
(keep (partial aliases->conditins syms))
(filter not-empty)))

(defn commutative? [st]
(and (coll? st)
(some commutative-ops st)))
(and (coll? st) (some commutative-ops st)))

(defn check-commutative [conclusion]
(if (commutative? conclusion)
Expand Down Expand Up @@ -213,16 +230,14 @@
(if-not (#{`munification-map `not-empty-diff?} f)
(concat (list f) (sort-placeholders tail))
el)))]
{:conclusion {:statement (-> conclusion
(preconditions-transformations preconditions)
(replace-symbols sym-map)
check-commutative
check-reduction)
:t-function (t/tvtypes (get-truth-fn post))
:t-function-n (get-truth-fn post)
:d-function (t/dvtypes (get-desire-fn post))
:d-function-n (get-desire-fn post)
:p/judgement (some #{:p/judgment} post)}
{:conclusion {:statement (-> conclusion
(preconditions-transformations preconditions)
(replace-symbols sym-map)
check-commutative
check-reduction)
:t-function (t/tvtypes (get-truth-fn post))
:d-function (t/dvtypes (get-desire-fn post))
:p/judgement (some #{:p/judgement} post)}
:conditions (walk (concat (check-conditions sym-map) pre)
(and (coll? el) (= \a (first (str (first el)))))
(concat '() el)
Expand Down Expand Up @@ -279,22 +294,26 @@
[conds cpm]
(map (fn [[cnds k]] [(sort-by cpm cnds) k]) conds))

(defn gen-rules [pattern rules]
(let [main (main-pattern pattern)
rules (mapcat (fn [{:keys [p1 p2 conclusions pre]}]
(defn gen-rules
"Prepeares data for generation of conditions tree and then generates tree."
[main-pattern rules]
(let [rules (mapcat (fn [{:keys [p1 p2 conclusions pre]}]
(map #(vector [p1 p2] % pre) conclusions))
rules)
cond-conclusions-m (conditions->conclusions-map main rules)
cond-conclusions-m (conditions->conclusions-map main-pattern rules)
cpm (conds-priorities-map cond-conclusions-m)
sorted-conds (sort-conds cond-conclusions-m cpm)]
(generate-tree sorted-conds)))

(defn generate-matching [rules task-type]
(defn generate-matching
"Generates code for rule matcher."
[rules task-type]
(->> rules
(map (fn [[k {:keys [pattern rules] :as v}]]
(let [match-fn-code (match-rules (main-pattern pattern)
(gen-rules pattern rules)
task-type)]
(let [main-pattern (symbols->placeholders pattern)
match-fn-code (-> main-pattern
(gen-rules rules)
(match-rules main-pattern task-type))]
[k (assoc v :matcher (eval match-fn-code)
:matcher-code match-fn-code)])))
(into {})))
8 changes: 4 additions & 4 deletions src/nal/deriver/normalization.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -63,18 +63,18 @@
(if (coll? conclusions)
(let [f (first conclusions)]
(if (commutative-ops f)
(into [] (conj (sort-by hash (drop 1 conclusions)) f))
(vec (conj (sort-by hash (drop 1 conclusions)) f))
conclusions))
conclusions))

;https://gist.github.com/TonyLo1/a3f8e05458c5e90c2e72
(defn union
([c1 c2] (sort-by hash (set (concat c1 c2))))
([op c1 c2] (into [] (conj (union c1 c2) op))))
([op c1 c2] (vec (conj (union c1 c2) op))))

(defn diff
([c1 c2] (into '() (set/difference (set c1) (set c2))))
([op c1 c2] (into [] (conj (diff c1 c2) op))))
([op c1 c2] (vec (conj (diff c1 c2) op))))

(defn reduce-ext-inter
[st]
Expand Down Expand Up @@ -121,7 +121,7 @@
(defn reduce-production
[st]
(m/match st
['* ['* & l1] & l2] (into [] (conj (concat l1 l2) '*))
['* ['* & l1] & l2] (vec (conj (concat l1 l2) '*))
:else st))

(defn reduce-image
Expand Down
20 changes: 13 additions & 7 deletions src/nal/deriver/preconditions.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,12 +5,13 @@
[nal.deriver.utils :refer [walk]]
[nal.deriver.substitution :refer [substitute munification-map]]
[nal.deriver.terms-permutation :refer [implications equivalences]]
[clojure.set :refer [union intersection]]))
[clojure.set :refer [union intersection]]
[narjure.defaults :refer [duration]]))

(defn abs [^long n] (Math/abs n))

;TODO preconditions
;:shift-occurrence-forward :shift-occurrence-backward
;:no-common-subterm
;:measure-time :concurrent
(defmulti compound-precondition
"Expands compound precondition to clojure sequence
that will be evaluted later"
Expand All @@ -20,7 +21,7 @@

(defmethod compound-precondition :!=
[[_ & args]]
[(concat (list `not=) args)])
[`(not= ~@args)])

(defn check-set [set-type arg]
`(and (coll? ~arg) (= ~set-type (first ~arg))))
Expand Down Expand Up @@ -85,7 +86,12 @@
(defmethod compound-precondition :measure-time
[_]
[`(not= :eternal :t-occurence)
`(not= :eternal :b-occurence)])
`(not= :eternal :b-occurence)
`(<= ~duration (abs (- :t-occurence :b-occurence)))])

(defmethod compound-precondition :concurrent
[_]
[`(> ~duration (abs (- :t-occurence :b-occurence)))])

;-------------------------------------------------------------------------------
(defmulti precondition-transformation (fn [arg1 _] (first arg1)))
Expand All @@ -94,7 +100,7 @@

(defn sets-transformation
[[cond-name el1 el2 el3] conclusion]
(walk conclusion (= el el3)
(walk conclusion (= :el el3)
`(~(f-map cond-name) ~el1 ~el2)))

(doall (map
Expand Down Expand Up @@ -122,7 +128,7 @@
(defmethod precondition-transformation :measure-time
[[_ arg] conclusion]
(let [mt (gensym)]
(walk `(let [k# 1 ~arg (- :t-occurence :b-occurence)]
(walk `(let [~arg (abs (- :t-occurence :b-occurence))]
~(walk conclusion
(= :el arg) [:interval arg]))
(= :el arg) mt)))
Expand Down
2 changes: 1 addition & 1 deletion src/nal/deriver/truth.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -113,7 +113,7 @@
(defn belief-structural-deduction [_ p2]
(when p2 (deduction p2 [1 d/judgement-confidence])))

(defn belief-structural-difference [p1 p2]
(defn belief-structural-difference [_ p2]
(when p2
(let [[^double f ^double c] (deduction p2 [1 d/judgement-confidence])]
[(- 1 f) c])))
Expand Down
Loading

0 comments on commit bbd3310

Please sign in to comment.