├── src ├── chr │ └── debug.clj └── chr.clj └── README.md /src/chr/debug.clj: -------------------------------------------------------------------------------- 1 | (ns chr.debug 2 | (:require [clojure.set :as set])) 3 | 4 | (def trace-set (atom #{})) 5 | (def trace-ignore (atom #{})) 6 | (defn trace 7 | ([labels strs] 8 | (trace labels strs (last strs))) 9 | ([labels strs expr] 10 | (when (and (not-empty (set/intersection (into #{:all} labels) @trace-set)) 11 | (empty? (set/intersection (into #{} labels) @trace-ignore))) 12 | (print (last labels)) 13 | (print ", ") 14 | (doall (for [s strs] (print s ""))) 15 | (println) 16 | (flush)) 17 | expr)) 18 | 19 | ;comment out traces at the source level: 20 | #_(defmacro trace 21 | ([labels strs] (last strs)) 22 | ([labels strs expr] expr)) 23 | 24 | (def times (atom {})) 25 | 26 | (defn reset-bench [] 27 | (swap! times (fn [_] {}))) 28 | 29 | #_(defmacro bench 30 | [bench-key expression] 31 | `(let [start-time# (System/nanoTime) 32 | e# ~expression 33 | end-time# (System/nanoTime)] 34 | (swap! times update-in [~bench-key] (fn [[old-count# old-time#]] 35 | [(inc (or old-count# 0)) 36 | (+ (or old-time# 0) (* (- end-time# start-time#) 37 | 0.000001))])) 38 | e#)) 39 | 40 | (defmacro bench 41 | "commenting out all benchmark hooks at the sorce level." 42 | [bench-key expression] expression) 43 | 44 | (defmacro no-bench 45 | "comment out specific benchmark hooks at the source level." 46 | [bench-key expression] 47 | expression) 48 | 49 | (defn bench-here 50 | "add a benchmark time from the given start-time (in nanoseconds)" 51 | [bench-key start-time] 52 | (let [end-time (System/nanoTime)] 53 | (swap! times update-in [bench-key] (fn [[old-count old-time]] 54 | [(inc (or old-count 0)) 55 | (+ (or old-time 0) (* (- end-time start-time) 56 | 0.000001))])))) 57 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Quick little implementation of CHR in Clojure. Attempting to roughly follow CHR2 as described 2 | in Peter Van Weert's dissertation [Extension and Optimising Compilation of Constraint Handling Rules](https://lirias.kuleuven.be/bitstream/123456789/266875/1/thesis.pdf) 3 | 4 | Disclaimer: 5 | 6 | Set semantics is currently baked in. Propagation history is opt-in. No "aggregates" semantics 7 | yet. No optimizations to speak of. 8 | 9 | _Not tested. Don't build bridges that depend on this code._ 10 | 11 | 12 | Use the RULE macro for CHR-like definitions: 13 | -------------------------------------------- 14 | 15 | (def narrowing-rules 16 | [(rule range-lower-bound 17 | [:- [:Range m1 M1] 18 | :- [:Range m2 M2] 19 | :when (number? m1) 20 | :when (number? m2)] 21 | [[:Range (max m1 m2) M1] 22 | [:Range (max m1 m2) M2]]) 23 | (rule range-upper-bound 24 | [:- [:Range m1 M1] 25 | :- [:Range m2 M2] 26 | :when (number? M1) 27 | :when (number? M2)] 28 | [[:Range m1 (min M1 M2)] 29 | [:Range m2 (min M1 M2)]]) 30 | (rule empty-range 31 | [:- [:Range m M] 32 | :when (and (number? m) 33 | (number? M) 34 | (< M m))] 35 | [[:Error (str "Empty range: [" m "," M "]")]])]) 36 | 37 | (unwrap (awake narrowing-rules [[:Range 30 90] [:Range 49 60] [:Range 'some-unground-var 59]])) 38 | 39 | The RULE macro is just sugar; rules can be constructed directly: 40 | 41 | (def leq-rules (fresh [x y z] 42 | [{:head [[:- [:leq x x]]]} 43 | {:head [[:- [:leq x y]] 44 | [:- [:leq y x]]] 45 | :body [[:equals x y]]} 46 | {:head [[:+ [:leq x y]] 47 | [:+ [:leq y z]]] 48 | :body [[:leq x z]]}])) 49 | 50 | (defn generate-leq-facts 51 | [pairs-o-symbols] 52 | (unwrap (awake leq-rules (map (fn [[l u]] [:leq l u]) pairs-o-symbols))))` 53 | 54 | 55 | (def gcd-rules (fresh [n m] 56 | [{:head [[:- [:gcd 0]]]} 57 | {:head [[:+ [:gcd n]] 58 | [:- [:gcd m]]] 59 | :guards [(chrfn [m n] (>= m n))] 60 | :bodyfn (chrfn [m n] [[:gcd (- m n)]])}])) 61 | 62 | (defn find-gcd [n1 n2] 63 | (unwrap (awake gcd-rules [[:gcd n1] [:gcd n2]]))) 64 | 65 | -------------------------------------------------------------------------------- /src/chr.clj: -------------------------------------------------------------------------------- 1 | (ns chr 2 | (:use [chr.debug]) 3 | (:require [clojure.set :as set] 4 | [clojure.walk :as walk])) 5 | 6 | (defrecord Variable [name]) 7 | (defn variable? [x] 8 | (instance? Variable x)) 9 | 10 | (defn variable 11 | "No effort expended to make variables hygenic. 12 | Scope ranges over entire rules (head & body)." 13 | [x] 14 | (->Variable x)) 15 | 16 | (defmacro fresh 17 | [varlist & body] 18 | `(let [~@(mapcat (fn [v] [v `(variable (quote ~v))]) varlist)] 19 | ~@body)) 20 | 21 | (defn rewrite 22 | [pattern rewrite-map] 23 | (when (some #(not (instance? clojure.lang.Symbol (:name %))) (keys rewrite-map)) 24 | (trace [:rewrite :error] [pattern rewrite-map])) 25 | (no-bench 26 | :rewrite 27 | (map (fn [t] (get rewrite-map t t)) pattern))) 28 | 29 | (defn dissoc-constraint 30 | [store [term & rst]] 31 | (trace [:dissoc-constraint] 32 | ["store:" store 33 | "term:" term 34 | "rst:" rst 35 | "store Type" (type store)]) 36 | (no-bench 37 | :dissoc-constraint 38 | (if (= ::& term) 39 | (dissoc-constraint store (first rst)) 40 | (if (empty? rst) 41 | (set/difference store #{term}) 42 | (let [b (dissoc-constraint (get store term) rst)] 43 | (if (empty? b) 44 | (dissoc store term) 45 | (assoc store term b))))))) 46 | 47 | (defn impose-constraint 48 | [store constraint] 49 | (do 50 | (trace [:impose-constraint] 51 | ["on store" store "with constraint" constraint]) 52 | (if (= 1 (count constraint)) 53 | (if (= {} store) 54 | #{(first constraint)} 55 | (into store constraint)) 56 | (update-in store (drop-last constraint) set/union #{(last constraint)})))) 57 | 58 | (defn sort-guards 59 | "given a collection of variables that will be grounded, sorts into 60 | [grounded, ungrounded] guards--so you know which are possible to check." 61 | [guards grounded-variables] 62 | (no-bench 63 | :sort-guards 64 | (let [ground-set (set grounded-variables) 65 | {ground true unground false} 66 | , (group-by (fn [[args gfn]] (every? #(or (not (variable? %)) 67 | (ground-set %)) args)) 68 | guards)] 69 | [ground unground]))) 70 | 71 | (defn sort-let-binders 72 | "given a collection of variables that will be grounded, sorts into 73 | [grounded-lbs, ungrounded-lbs, newly-grounded-lvars], reflecting the additional lvars 74 | that will be ground by running these binders" 75 | [let-binders grounded-variables] 76 | (let [ground-set (set 77 | grounded-variables) 78 | {ground true unground false} 79 | , (group-by (fn [[args news gfn]] (every? #(or (not (variable? %)) 80 | (ground-set %)) args)) 81 | let-binders) 82 | newly-ground (apply set/union (map (comp set second) ground))] 83 | (if (empty? (set/difference newly-ground ground-set)) 84 | (do (trace [:sort-let-binders] [[ground unground ground-set]]) 85 | [ground unground ground-set]) 86 | (let [[g ug ngs] (sort-let-binders unground (set/union ground-set newly-ground))] 87 | [(concat ground g) ug ngs])))) 88 | 89 | (defn unwrap 90 | "Returns the sequence of constraints comprised by a given store. 91 | Nested stores are not recursively unwrapped. 92 | assert: (= some-store (reduce impose-constraint {} (unwrap some-store)))" 93 | [store] 94 | (if (set? store) 95 | (map vector store) 96 | (mapcat (fn [[k v]] (map #(vec (concat [k] %)) (unwrap v))) store))) 97 | 98 | (defn satisfies-guards? 99 | [root-store substs guards] 100 | (every? (fn [[args gfn]] (trace [:guard-call] ["store:" root-store] (apply gfn root-store (rewrite args substs)))) guards)) 101 | 102 | (defn let-bind 103 | "returns the substs map modified by the let-binder" 104 | [root-store substs let-binders] 105 | (trace [:let-bind] 106 | [substs "->" (reduce (fn [s [args _ bfn]] (merge s 107 | (let [bindings (apply bfn root-store (rewrite args s))] 108 | (when (some #(not (instance? clojure.lang.Symbol (:name %))) 109 | (keys bindings)) 110 | (trace [:let-bind :error] ["roots" root-store "current subs" s "bindings" bindings "args" args "rewritten to" (rewrite args s) "bfn" bfn]) 111 | (throw (Exception. "Bad type for variable binding. Check the let binder."))) 112 | bindings))) 113 | substs 114 | let-binders)])) 115 | 116 | (defn find-matches* 117 | "Returns a seq of substitution maps, arity of pattern must be matched." 118 | ([root-store store substs guards let-binders [term & next-terms]] 119 | (no-bench 120 | :find-matches 121 | (let [term (if (variable? term) (get substs term term) term)] 122 | (cond 123 | (vector? term) (let [[grnd-binders ungrnd-binders next-ground] (sort-let-binders let-binders (concat (keys substs) term)) 124 | [grnd-guards ungrnd-guards] (sort-guards guards next-ground)] 125 | (mapcat (fn [[k v]] 126 | (if v (mapcat (fn [submatch] 127 | (find-matches* root-store v (merge substs submatch) ungrnd-guards ungrnd-binders next-terms)) 128 | (find-matches* root-store k substs grnd-guards grnd-binders term)) 129 | (find-matches* root-store k substs grnd-guards grnd-binders term))) 130 | (if (map? store) 131 | (filter (fn [[k v]] (map? k)) store) 132 | (map (fn [s] [s nil]) (filter map? store))))) 133 | (nil? next-terms) (if (set? store) 134 | (if (variable? term) 135 | (filter 136 | #(satisfies-guards? root-store % guards) 137 | (map #(let-bind root-store (assoc substs term %) let-binders) store)) 138 | (if (contains? store term) [substs] [])) 139 | []) 140 | (= ::& term) (let [rest (first next-terms) 141 | [grnd-binders _ next-ground] (sort-let-binders let-binders (conj (keys substs) rest)) 142 | [grnd-guards _] (sort-guards guards next-ground)] 143 | (filter 144 | #(satisfies-guards? root-store % grnd-guards) 145 | (map #(let-bind root-store (assoc substs rest %) grnd-binders) (unwrap store)))) 146 | (set? store) (if (= (first next-terms) ::&) 147 | (let [rest (second next-terms)] 148 | (if (variable? term) 149 | (filter 150 | #(satisfies-guards? root-store % guards) 151 | (map #(let-bind root-store (assoc substs term % rest []) let-binders) store)) 152 | (if (contains? store term) [(let-bind root-store (assoc substs rest []) let-binders)] []))) 153 | ()) 154 | (variable? term) (if (map? store) 155 | (let [[grnd-binders ungrnd-binders next-ground] (sort-let-binders let-binders (conj (keys substs) term)) 156 | [grnd-guards ungrnd-guards] (sort-guards guards next-ground)] 157 | (mapcat (fn [[k v]] 158 | (let [next-substs (assoc substs term k)] 159 | (if (satisfies-guards? root-store next-substs grnd-guards) 160 | (find-matches* root-store 161 | v 162 | (let-bind root-store next-substs grnd-binders) 163 | ungrnd-guards 164 | ungrnd-binders 165 | next-terms) 166 | []))) 167 | store)) 168 | []) 169 | :else (find-matches* root-store (get store term) substs guards let-binders next-terms)))))) 170 | 171 | (defn find-matches 172 | ([store pattern] (find-matches* store store {} [] [] pattern)) 173 | ([store guards pattern] (find-matches* store store {} guards [] pattern)) 174 | ([store substs guards terms] 175 | (find-matches* store store substs guards [] terms)) 176 | ([root-store store substs guards let-binders terms] 177 | (find-matches* root-store store substs guards let-binders terms))) 178 | 179 | (defmacro gather-matches 180 | "lvar introduces lvar(s) to match in the pattern. 181 | Can be a single lvar, returning a seq of values for matched lvar, 182 | or a vec of lvars in which case will return a seq of tuples 183 | representing matched values." 184 | [lvar & store-guards-pattern] 185 | (if (vector? lvar) 186 | `(fresh ~lvar (map (fn [m#] (vec (map (fn [v#] (get m# v#)) ~lvar))) 187 | (find-matches ~@store-guards-pattern))) 188 | `(fresh [~lvar] (map (fn [m#] (get m# ~lvar)) 189 | (find-matches ~@store-guards-pattern))))) 190 | 191 | (defn store-values 192 | "flat list of every value in a store (not grouped by constraints)" 193 | [store] 194 | (if (map? store) 195 | (concat (keys store) (mapcat store-values (vals store))) 196 | store)) 197 | 198 | (defn store? 199 | [t] (and (map? t) 200 | (every? coll? (vals t)))) 201 | 202 | (defn find-matches-recursive 203 | "descends into nested stores to find matches." 204 | ([store pattern] (find-matches-recursive store [] pattern)) 205 | ([store guards pattern] 206 | (trace [:find-matches-recursive] ["store" store "pat" pattern "guards" guards]) 207 | (concat (find-matches store guards pattern) 208 | (mapcat #(find-matches-recursive % guards pattern) 209 | (filter store? (store-values store)))))) 210 | 211 | (defn partial-apply-chrfns 212 | "takes a collection of guards or let-binders, and grounds their 213 | argument templates according to the substitution." 214 | [guards substs] 215 | (trace [:partial-apply] [guards "with" substs]) 216 | (map (fn [[args & rst]] (vec (concat [(rewrite args substs)] rst))) guards)) 217 | 218 | (defn match-head 219 | "list of all viable [subststitutions, store-after-removal] 220 | pairs that match this collection of patterns" 221 | [root-store store substs guards let-binders [pattern & rst]] 222 | (if pattern 223 | (let [[grnd-binders ungrnd-binders next-ground] 224 | , (trace [:mh-letbinders] ["store" store "root-store" root-store "pattern" pattern "subts" substs "->" 225 | (sort-let-binders (partial-apply-chrfns let-binders substs) (concat (flatten pattern) (keys substs)))]) 226 | [grnd-guards ungrnd-guards] (sort-guards (partial-apply-chrfns guards substs) next-ground) 227 | subbed-pat (trace [:mh-rewrite] ["lvar sig:" (map variable? (rewrite pattern substs)) (bench :mh-rewrite (rewrite pattern substs))]) 228 | next-substs (bench :mh-find-matches (find-matches root-store store substs grnd-guards grnd-binders subbed-pat))] 229 | (trace [:match-head] ["Matched on " pattern "with subs" next-substs "with guards"(map first grnd-guards) ]) 230 | (when (and (empty? rst) (not (empty? ungrnd-guards))) 231 | (trace [:match-head :error] ["Some guards will not be fired:" (map first guards) "with substs:" next-substs "choice informed by " next-ground])) 232 | (mapcat (fn [sb] (match-head root-store 233 | (bench :mh-dissoc (dissoc-constraint store (rewrite pattern sb))) 234 | sb ungrnd-guards ungrnd-binders rst)) 235 | next-substs)) 236 | [[substs store]])) 237 | 238 | (defn matching-rule-seq 239 | "doesn't filter against propagation history. 240 | returns a seq of [fired-rule, subs, next-store] tuples." 241 | [store rules active-constraint] 242 | (for [rule rules 243 | [_op pattern] (:head rule) 244 | :let [[grnd-binders ungrnd-binders newly-ground] 245 | , (bench :sort-guards 246 | (do 247 | (trace [:matching-rule-seq] ["initial binders with" pattern "variable sig:" (map variable? pattern) "on store" store "with AC" active-constraint]) 248 | (sort-let-binders (:let-binders rule) pattern))) 249 | [grnd-guards ungrnd-guards] (bench :sort-guards 250 | (sort-guards (:guards rule) newly-ground)) 251 | _ (trace [:matching-rule-seq] ["Unground guards" (map first ungrnd-guards)])] 252 | next-substs (bench :find-matches 253 | (find-matches store (impose-constraint {} active-constraint) {} grnd-guards grnd-binders pattern)) 254 | [sibling-substs s0] (trace [:awake :search] 255 | ["subs" next-substs 256 | "on pattern:" pattern 257 | "with grnd-guards" grnd-guards] 258 | (bench :match-head 259 | (match-head store 260 | store 261 | next-substs 262 | ungrnd-guards 263 | ungrnd-binders 264 | (filter #(not= pattern %) 265 | (map second (:head rule))))))] 266 | [rule sibling-substs s0])) 267 | 268 | (defn fire-rule 269 | [fired-rule substs store] 270 | (trace [:fire-rule] [(:name fired-rule) "args:" substs "store" store ]) 271 | (concat (map #(rewrite % substs) (:body fired-rule)) 272 | (when-let [[args bfn] (:bodyfn fired-rule)] 273 | (apply bfn store (rewrite args substs))))) 274 | 275 | (defn group-pairs 276 | "like group-by, except groups by first elt as the keys, 277 | and a seq of second elts as values." 278 | [seq-of-pairs] 279 | (into {} 280 | (map (fn [[k v]] [k (map second v)]) 281 | (group-by first seq-of-pairs)))) 282 | 283 | (def rule-propagation-limit (atom 10000)) 284 | (def propagations (atom 0)) 285 | 286 | (defn awake 287 | ([rules initial-constraints] 288 | (do (reset! propagations 0) 289 | (awake {} rules (first initial-constraints) (rest initial-constraints) #{} nil))) 290 | ([rules store initial-constraints] 291 | (do (reset! propagations 0) 292 | (awake store rules (first initial-constraints) (rest initial-constraints) #{} nil))) 293 | ([store rules active-constraint queued-constraints prop-history continued-rule-matches] 294 | (if active-constraint 295 | (let [_ (when (> (swap! propagations inc) @rule-propagation-limit) 296 | (throw (Exception. "Rule propagation overflow."))) 297 | t1 (System/nanoTime) 298 | [[fired-rule substs next-store new-constraints] & next-rule-matches] 299 | , (filter 300 | (fn [[fired-rule substs next-store new-constraints]] 301 | (let [{kept :+ removed :-} (group-pairs (map (fn [[op pat]] [op (rewrite pat substs)]) 302 | (:head fired-rule)))] 303 | (and (not= (into #{} (concat kept removed)) 304 | (into #{} (concat kept new-constraints))) 305 | (if (:tabled fired-rule) 306 | (not (prop-history [fired-rule substs new-constraints])) 307 | true)))) 308 | (map (fn [[fired-rule substs next-store]] 309 | [fired-rule substs next-store (fire-rule fired-rule substs next-store)]) 310 | (or continued-rule-matches 311 | (matching-rule-seq store rules active-constraint))))] 312 | (if (and (empty? (bench :find-matches (find-matches store [] active-constraint))) 313 | fired-rule) 314 | (let [_ (bench-here :awake-found t1) 315 | t2 (System/nanoTime) 316 | _ (trace [:awake] [(map (fn [[op pat]] [op (rewrite pat substs)]) (:head fired-rule))]) 317 | next-history (if (:tabled fired-rule) 318 | (into prop-history [[fired-rule substs new-constraints]]) 319 | prop-history) 320 | {kept-awake [:+ true], 321 | kept-asleep [:+ false]} 322 | , (group-pairs (map (fn [[op pat]] 323 | (let [t (rewrite pat substs)] 324 | [[op (= t active-constraint)] t])) 325 | (:head fired-rule))) 326 | [next-active & next-queued] (concat new-constraints 327 | kept-awake 328 | queued-constraints)] 329 | (trace [:awake :firing] [(:name fired-rule) "on store:" store "::"active-constraint"::" queued-constraints 330 | "kept-awake:" kept-awake "kept-asleep:" kept-asleep "creating" new-constraints "with subs:" substs]) 331 | (bench-here (:name fired-rule) t2) 332 | #_"If no constraints to be removed, maintain same store and position within the iterator." 333 | (if (empty? (filter (fn [[op _]] (= op :-)) (:head fired-rule))) 334 | (recur store 335 | rules active-constraint (doall (concat new-constraints queued-constraints)) next-history (or next-rule-matches [])) ;must distinguish between empty and nil, nil means don't use, empty means none left- 336 | (recur (reduce impose-constraint next-store kept-asleep) 337 | rules next-active next-queued next-history nil))) 338 | (do 339 | (bench-here :awake-fail t1) 340 | (trace [:awake :awake-fail] ["store" store "active c:" active-constraint "::" queued-constraints]) 341 | (recur (impose-constraint store active-constraint) 342 | rules 343 | (first queued-constraints) 344 | (rest queued-constraints) 345 | prop-history 346 | nil)))) 347 | store))) 348 | 349 | (defmacro chrfn 350 | "chrfns must be of the form 351 | (chrfn name? [store arg1 ...argn]) where store is bound to 352 | the current state of the constraint store. 353 | becomes [required-lvars, (fn [store required] ...)] tuple" 354 | {:forms '[(chrfn name? [store params*] exprs*)]} 355 | [args-or-name & rst] 356 | (if (vector? args-or-name) 357 | `[~(vec (drop 1 args-or-name)) (fn ~args-or-name ~@rst)] 358 | (let [[args & body] rst] 359 | `[~(vec (drop 1 args)) (fn ~args-or-name ~args ~@body)]))) 360 | 361 | (defn let-binder* 362 | "convert a normal let binding into a tuple holding afunction that returns a binding map. 363 | a let binder is a [required-lvars, provided-lvars, (fn [store required] ...)] tuple" 364 | [name argform new-vars bindform expr] 365 | (let [new-var-aliases (map #(gensym (str % "-")) new-vars)] 366 | `[~(vec (drop 1 argform)) 367 | ~(vec new-vars) 368 | (fn ~name ~argform 369 | (let [~@(mapcat (fn [alias v] [alias v]) new-var-aliases new-vars) 370 | ~bindform ~expr] 371 | (hash-map ~@(interleave new-var-aliases new-vars))))])) 372 | 373 | (defmacro rule 374 | ([head] 375 | `(rule ~(symbol (str "rule-" (mod (hash head) 10000))) ~head)) 376 | ([head body] 377 | (if (vector? head) 378 | `(rule ~(symbol (str "rule-" (mod (hash [head body]) 10000))) ~head ~body) 379 | `(rule ~head ~body []))) 380 | ([name head body] 381 | (let [occurrences (vec (map (fn [[op pat]] [op (walk/postwalk 382 | (fn [t] (get {'& ::& 383 | '_ (variable (gensym "_"))} t t)) 384 | pat)]) 385 | (filter (fn [[op pat]] (#{:- :+} op)) (partition 2 head)))) 386 | guards (vec (map second (filter (fn [[op pat]] (= :when op)) (partition 2 head)))) 387 | let-bindings (vec (mapcat #(partition 2 (second %)) 388 | (filter (fn [[op pat]] (= :let op)) 389 | (partition 2 head)))) 390 | store-alias (or (last (map second (filter (fn [[op pat]] (= :store op)) (partition 2 head)))) 391 | 'store) 392 | tabled? (or (:tabled (meta name)) (:tabled (meta head)) (:tabled (meta body))) 393 | variables (into #{} (for [pattern (concat (map second occurrences) 394 | (map first let-bindings)) 395 | term ((fn gather [f] (cond (symbol? f) #{f} 396 | (coll? f) (apply set/union (map gather f)) 397 | :else nil)) pattern)] term)) 398 | collect-vars (fn [form] 399 | ((fn gather [f] (cond (variables f) #{f} 400 | (coll? f) (apply set/union (map gather f)) 401 | :else nil)) form))] 402 | `(fresh ~(vec variables) 403 | {:name (quote ~name) 404 | :head ~occurrences 405 | :guards [~@(map (fn [g] `(chrfn ~name [~store-alias ~@(collect-vars g)] ~g)) guards)] 406 | :let-binders [~@(map (fn [[bindform expr]] 407 | (let-binder* name 408 | (vec (concat [store-alias] (collect-vars expr))) 409 | (collect-vars bindform) 410 | bindform expr)) 411 | let-bindings)] 412 | :tabled ~tabled? 413 | :bodyfn (chrfn ~name [~store-alias ~@(collect-vars body)] ~body)})))) 414 | 415 | ;---------------- Examples --------------------- 416 | 417 | (def leq-rules (fresh [x y z a b eq eq1 eq2 c d] 418 | [{:name :Reflexivity 419 | :head [[:- [:leq d d]]]} 420 | 421 | {:name :Antisymmetry 422 | :head [[:- [:leq x y]] 423 | [:- [:leq y x]]] 424 | :bodyfn (chrfn [_ x y] (if (< (hash x) (hash y)) 425 | [[:equivclass x y]] 426 | [[:equivclass y x]]))} 427 | 428 | #_"Herbrand equality:" 429 | {:name :Eq-rewrite1 430 | :head [[:- [:leq x b]] 431 | [:+ [:equivclass eq x]]] 432 | :body [[:leq eq b]]} 433 | {:name :Eq-rewrite2 434 | :head [[:- [:leq b x]] 435 | [:+ [:equivclass eq x]]] 436 | :body [[:leq b eq]]} 437 | {:name :Eq-reflexivity 438 | :head [[:- [:equivclass d d]]]} 439 | {:name :Eq-transitivity 440 | :head [[:- [:equivclass y x]] 441 | [:+ [:equivclass eq y]]] 442 | :body [[:equivclass eq x]]} 443 | {:name :Eq-simplification 444 | :head [[:- [:equivclass eq1 x]] 445 | [:- [:equivclass eq2 x]]] 446 | :bodyfn (chrfn [_ x eq1 eq2] [[:equivclass (if (< (hash eq1) (hash eq2)) eq1 eq2) x]])} 447 | 448 | {:name :Transitivity 449 | :head [[:+ [:leq x y]] 450 | [:+ [:leq y z]]] 451 | :body [[:leq x z]]}])) 452 | 453 | (defn solve-leq-chain 454 | "all variables equal on x1 <= x2 <= ... xn <= x1" 455 | [length] 456 | (awake leq-rules (map (fn [[l u]] [:leq l u]) 457 | (conj (map vector (range (dec length)) (drop 1 (range))) 458 | [(dec length) 0])))) 459 | 460 | 461 | (def gcd-rules (fresh [n m] 462 | [{:head [[:- [:gcd 0]]]} 463 | {:head [[:+ [:gcd n]] 464 | [:- [:gcd m]]] 465 | :guards [(chrfn [_ m n] (>= m n))] 466 | :bodyfn (chrfn [_ m n] [[:gcd (- m n)]])}])) 467 | 468 | (defn find-gcd [n1 n2] 469 | (unwrap (awake gcd-rules [[:gcd n1] [:gcd n2]]))) 470 | --------------------------------------------------------------------------------