quest rules

src/nal/deriver.clj

@@ -8,8 +8,7 @@
 (defn get-matcher [rules p1 p2]
   (let [matchers (->> (mall-paths p1 p2)
                       (filter rules)
-                      (map rules)
-                      (map (fn [el] (:matcher el))))]
+                      (map rules))]
     (case (count matchers)
       0 (constantly [])
       1 (first matchers)

src/nal/deriver/matching.clj

@@ -19,7 +19,7 @@
   #{`= `not= `seq? `first `and `let `pos? `> `>= `< `<= `coll? `set `quote
     `count 'aops `- `not-empty-diff? `not-empty-inter? `walk `munification-map
     `substitute `sets `some `deref `do `vreset! `volatile! `fn `mapv `if
-    `sort-commutative `n/reduce-ext-inter `n/reduce-symilarity `complement
+    `sort-commutative `n/reduce-ext-inter `n/reduce-similarity `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 `abs
     `implications-and-equivalences `get-terms `empty? `intersection
@@ -67,19 +67,24 @@
 (defn traverse-node
   "Generates code for precondition node."
   [vars result {:keys [conclusions children condition]}]
-  `(when ~(quote-operators condition)
-     ~(when-not (zero? (count conclusions))
-        `(vswap! ~result concat
-                 ~@(set (map #(mapv (partial form-conclusion vars) %)
-                             (quote-operators conclusions)))))
-     ~@(map (fn [n] (traverse-node vars result n)) children)))
+  (let [conclusions (remove
+                      nil?
+                      [(when-not (zero? (count conclusions))
+                         `(vswap! ~result concat
+                                  ~@(set (map #(mapv (partial form-conclusion vars) %)
+                                              (quote-operators conclusions)))))])
+        children (mapcat (fn [n] (traverse-node vars result n)) children)]
+    (if (true? condition)
+      (concat conclusions children)
+      [`(when ~(quote-operators condition)
+          ~@(concat conclusions children))])))
 
 (defn traversal
   "Walk through preconditions tree and generates code for matcher."
   [vars tree]
   (let [results (gensym)]
     `(let [~results (volatile! [])]
-       ~(traverse-node vars results tree)
+       ~@(traverse-node vars results tree)
        @~results)))
 
 (defn replace-occurrences
@@ -340,6 +345,5 @@
                     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)])))
+                [k (eval match-fn-code)])))
        (into {})))

src/nal/deriver/normalization.clj

@@ -111,7 +111,7 @@
     [_ ['ext-set & l1] ['ext-set & l2]] (diff 'ext-set l1 l2)
     :else st))
 
-(defn reduce-symilarity
+(defn reduce-similarity
   [st]
   (m/match st
     ['<-> ['ext-set s] ['ext-set p]] ['<-> s p]
@@ -169,7 +169,7 @@
    '|         `reduce-int-inter
    '-         `reduce-ext-dif
    'int-dif   `reduce-int-dif
-   '<->       `reduce-symilarity
+   '<->       `reduce-similarity
    '*         `reduce-production
    'int-image `reduce-image
    'ext-image `reduce-image
@@ -185,7 +185,7 @@
       | (reduce-int-inter st)
       - (reduce-ext-dif st)
       int-dif (reduce-int-dif st)
-      <-> (reduce-symilarity st)
+      <-> (reduce-similarity st)
       * (reduce-production st)
       int-image (reduce-image st)
       ext-image (reduce-image st)

src/nal/deriver/rules.clj

@@ -57,6 +57,12 @@
   [{:keys [pre]}]
   (some #{:question?} pre))
 
+(defn quest?
+  "Return true if rule allows only quest as task."
+  [{:keys [pre] [{post :post}] :conclusions}]
+  (and (some #{:question?} pre)
+       (every? #(not (#{:p/judgement} %)) post)))
+
 (defn goal?
   "Return true if rule allows only goal as task."
   [{pre :pre [{post :post}] :conclusions}]
@@ -134,10 +140,13 @@
                           allow-backward? expand-backward-rules)
           judgement-rules# (check-duplication (filter judgement? rules))
           question-rules# (check-duplication (filter question? rules))
-          goal-rules# (check-duplication (filter goal? rules))]
-      (println "Q rules:" (count question-rules#))
-      (println "J rules:" (count judgement-rules#))
-      (println "G rules:" (count goal-rules#))
+          goal-rules# (check-duplication (filter goal? rules))
+          quest-rules# (check-duplication (filter quest? rules))]
+      (println "Beliefs rules:" (count judgement-rules#))
+      (println "Questions rules:" (count question-rules#))
+      (println "Goal rules:" (count goal-rules#))
+      (println "Quests rules:" (count quest-rules#))
       {:judgement (rules-map judgement-rules# :judgement)
        :question  (rules-map question-rules# :question)
-       :goal      (rules-map goal-rules# :goal)})))
+       :goal      (rules-map goal-rules# :goal)
+       :quest     (rules-map quest-rules# :quest)})))

src/nal/deriver/truth.clj

@@ -108,6 +108,8 @@
 
 (defn t-identity [p1 _] p1)
 
+(defn d-identity [p1 _] p1)
+
 (defn belief-identity [p1 p2] (when p2 p1))
 
 (defn belief-structural-deduction [_ p2]
@@ -166,6 +168,6 @@
    :d/deduction         intersection
    :d/weak              desire-weak
    :d/induction         desire-induction
-   :d/identity          identity
+   :d/identity          d-identity
    :d/negation          negation
    :d/structural-strong desire-structural-strong})