From 5f0a613d4f59ba7487056488fc192402e06a6973 Mon Sep 17 00:00:00 2001 From: Kirill Chernyshov Date: Thu, 11 Jun 2020 13:11:44 +0200 Subject: [PATCH 01/15] Big refactoring to formalize internals --- dev/example/graph.cljc | 44 ++-- dev/example/poker_hand.cljc | 147 ++++++++---- src/matchete/core.cljc | 439 ++++++++++++++-------------------- src/matchete/logic.cljc | 242 +++++++++++++++++++ test/matchete/core_test.cljc | 303 ----------------------- test/matchete/logic_test.cljc | 228 ++++++++++++++++++ 6 files changed, 770 insertions(+), 633 deletions(-) create mode 100644 src/matchete/logic.cljc delete mode 100644 test/matchete/core_test.cljc create mode 100644 test/matchete/logic_test.cljc diff --git a/dev/example/graph.cljc b/dev/example/graph.cljc index 79f50a0..97350bb 100644 --- a/dev/example/graph.cljc +++ b/dev/example/graph.cljc @@ -1,5 +1,5 @@ (ns example.graph - (:require [matchete.core :as m])) + (:require [matchete.logic :as logic])) (def city-to-city-distance #{["Berlin" #{["New York" 14] ["London" 2] ["Tokyo" 14] ["Vancouver" 13]}] @@ -8,33 +8,29 @@ ["Tokyo" #{["Berlin" 14] ["New York" 18] ["London" 15] ["Vancouver" 12]}] ["Vancouver" #{["Berlin" 13] ["New York" 6] ["London" 10] ["Tokyo" 12]}]}) -;; generates pattern like this: -;; '#{[(cat ?0 !path) #{[?1 $sum]}] -;; [(cat ?1 !path) #{[?2 $sum]}] -;; [(cat ?2 !path) #{[?3 $sum]}] -;; [(cat ?3 !path) #{[?4 $sum]}] -;; [(cat ?4 !path) #{[?0 $sum]}]} +(def calculate-distance + (reify logic/Pattern + (matches [_ preconditions data] + (list (update preconditions :?distance (fnil + 0) data))))) -(defn generate-pattern [cities-count] +(defn generate-matcher [cities-count] (let [l (range cities-count)] - (into #{} - (map (fn [[n1 n2]] - [(list 'cat (symbol (str "?" n1)) '!path) - #{[(symbol (str "?" n2)) '$sum]}])) - (take cities-count (map vector (cycle l) (rest (cycle l))))))) + (logic/matcher + (into #{} + (map (fn [[n1 n2]] + [(keyword (str "?" n1)) + #{[(keyword (str "?" n2)) calculate-distance]}])) + (take cities-count (map vector (cycle l) (rest (cycle l)))))))) (defn shortest-path {:test #(do (assert - (= 46 (first (shortest-path city-to-city-distance)))))} - [db] - (let [{:syms [?distance !path]} + (= 46 (shortest-path city-to-city-distance "Berlin"))))} + [db start] + (let [{:keys [?distance]} (first - (sort-by #(get % '?distance) - (m/matches (generate-pattern (count db)) - {'?0 (ffirst db)} - ;; Let's use rule as a reduce to calculate a distance walked so far - {'$sum (fn [matches _rules data] - (list (update matches '?distance (fnil + 0) data)))} - db)))] - [?distance !path])) + (sort-by :?distance + (logic/matches (generate-matcher (count db)) + {:?0 start} + db)))] + ?distance)) diff --git a/dev/example/poker_hand.cljc b/dev/example/poker_hand.cljc index 8c54181..995613d 100644 --- a/dev/example/poker_hand.cljc +++ b/dev/example/poker_hand.cljc @@ -1,38 +1,79 @@ (ns example.poker-hand - (:require [matchete.core :as m])) + (:require [matchete.logic :as logic])) -;; == helpers == +(defn card [P] + (logic/matcher P)) -(defn card-comparator [card-a card-b] - (if (some m/pattern? [card-a card-b]) - 1 - (compare card-a card-b))) +(defn hand-pattern [pattern] + (logic/matcher (into #{} (map card) pattern))) -;; === rules === +(defn match? [matcher hand] + (logic/match? matcher hand)) -(def rules - {'%plus (fn [s m] - (fn [matches _ data] - (cond - (and (contains? matches s) - (= data (+ m (get matches s)))) - (list matches) +(defn p+ [lvar n] + (reify logic/Pattern + (matches [_ preconditions m] + (cond + (and (contains? preconditions lvar) + (= m (+ n (get preconditions lvar)))) + (list preconditions) - (and (not (contains? matches s)) - (> data m)) - (list (assoc matches s (- data m)))))) - '$high-card (fn [{[_ rank' :as card'] :card} _ [_ rank :as card]] - (list {:card (cond - (nil? card') - card + (and (not (contains? preconditions lvar)) + (> m n)) + (list (assoc preconditions lvar (- m n))))))) - (> rank rank') - card +(defn high-card-> [lvar] + (reify logic/Pattern + (matches [_ {[_ rank' :as card'] lvar} [_ rank :as card]] + (list {lvar (cond + (nil? card') + card - :else - card')}))}) + (> rank rank') + card -;; ============= + :else + card')})))) + +(let [p (hand-pattern [[:?s 14] [:?s 13] [:?s 12] [:?s 11] [:?s 10]])] + (defn royal-flush? [hand] + (logic/match? p hand))) + +(let [p (hand-pattern [[:?s :?n] [:?s (p+ :?n 1)] [:?s (p+ :?n 2)] [:?s (p+ :?n 3)] [:?s (p+ :?n 4)]])] + (defn straight-flush? [hand] + (logic/match? p hand))) + +(let [p (hand-pattern [[:_ :?n] [:_ :?n] [:_ :?n] [:_ :?n] :_])] + (defn four-of-a-kind? [hand] + (logic/match? p hand))) + +(let [p (hand-pattern [[:_ :?m] [:_ :?m] [:_ :?m] [:_ :?n] [:_ :?n]])] + (defn full-house? [hand] + (logic/match? p hand))) + +(let [p (hand-pattern [[:?s :_] [:?s :_] [:?s :_] [:?s :_] [:?s :_]])] + (defn flush? [hand] + (logic/match? p hand))) + +(let [p (hand-pattern [[:_ :?n] [:_ (p+ :?n 1)] [:_ (p+ :?n 2)] [:_ (p+ :?n 3)] [:_ (p+ :?n 4)]])] + (defn straight? [hand] + (logic/match? p hand))) + +(let [p (hand-pattern [[:_ :?n] [:_ :?n] [:_ :?n] :_ :_])] + (defn three-of-a-kind? [hand] + (logic/match? p hand))) + +(let [p (hand-pattern [[:_ :?n] [:_ :?n] [:_ :?m] [:_ :?m] :_])] + (defn two-pair? [hand] + (logic/match? p hand))) + +(let [p (hand-pattern [[:_ :?n] [:_ :?n] :_ :_ :_])] + (defn one-pair? [hand] + (logic/match? p hand))) + +(let [p (hand-pattern (repeatedly 5 #(high-card-> :?card)))] + (defn high-card [hand] + (:?card (first (logic/matches p hand))))) (defn poker-hand {:test #(do @@ -64,36 +105,42 @@ (= (poker-hand #{[:♠ 5] [:♦ 11] [:♠ 6] [:♠ 7] [:♠ 8]}) [:♦ 11])))} [hand] - (letfn [(match? [pattern hand] - (m/match? pattern rules hand))] - (condp match? hand - '#{[?s 14] [?s 13] [?s 12] [?s 11] [?s 10]} - "Royal flush" + (cond + (royal-flush? hand) + "Royal flush" + + (straight-flush? hand) + "Straight flush" + + (four-of-a-kind? hand) + "Four of a kind" + + (full-house? hand) + "Full house" - '#{[?s ?n] [?s (%plus ?n 1)] [?s (%plus ?n 2)] [?s (%plus ?n 3)] [?s (%plus ?n 4)]} - "Straight flush" + (flush? hand) + "Flush" - (sorted-set-by card-comparator '[_ ?n] '[_ ?n] '[_ ?n] '[_ ?n] '_) - "Four of a kind" + (straight? hand) + "Straight" - (sorted-set-by card-comparator '[_ ?m] '[_ ?m] '[_ ?m] '[_ ?n] '[_ ?n]) - "Full house" + (three-of-a-kind? hand) + "Three of a kind" - (sorted-set-by card-comparator '[?s _] '[?s _] '[?s _] '[?s _] '[?s _]) - "Flush" + (two-pair? hand) + "Two pair" - '#{[_ ?n] [_ (%plus ?n 1)] [_ (%plus ?n 2)] [_ (%plus ?n 3)] [_ (%plus ?n 4)]} - "Straight" + (one-pair? hand) + "One pair" - (sorted-set-by card-comparator '[_ ?n] '[_ ?n] '[_ ?n] '_ '_) - "Three of a kind" + :else + (high-card hand))) - (sorted-set-by card-comparator '[_ ?n] '[_ ?n] '[_ ?m] '[_ ?m] '_) - "Two pair" +(comment - (sorted-set-by card-comparator '[_ ?n] '[_ ?n] '_ '_ '_) - "One pair" + (time + (dotimes [_ 100] + (poker-hand #{[:♠ 10] [:♠ 11] [:♠ 12] [:♠ 13] [:♠ 14]}) + (poker-hand #{[:♠ 5] [:♦ 11] [:♠ 6] [:♠ 7] [:♠ 8]}))) - (-> (m/matches (sorted-set-by card-comparator '$high-card '$high-card '$high-card '$high-card '$high-card) rules hand) - first - :card)))) + ) diff --git a/src/matchete/core.cljc b/src/matchete/core.cljc index 32d8f4a..591b1cb 100644 --- a/src/matchete/core.cljc +++ b/src/matchete/core.cljc @@ -1,165 +1,165 @@ (ns matchete.core - (:refer-clojure :exclude [cat]) - (:require [clojure.math.combinatorics :as combo])) + (:refer-clojure :exclude [not conj disj]) + (:require [clojure.math.combinatorics :as combo] + [clojure.string :as string] + [#?(:clj clojure.core :cljs cljs.core) :as cc])) -(defn- symbol-type [s] - (when (symbol? s) - (case (first (name s)) - \? ::binding - \! ::memo-binding - \$ ::rule - \% ::dynamic-rule - \_ ::placeholder - nil))) - -(defn binding? [P] - (= ::binding (symbol-type P))) - -(defn memo-binding? [P] - (= ::memo-binding (symbol-type P))) - -(defn rule? [P] - (= ::rule (symbol-type P))) - -(defn dynamic-rule? [P] - (= ::dynamic-rule (symbol-type P))) - -(defn placeholder? [P] - (= ::placeholder (symbol-type P))) - -(defn matcher? [F] - (::matcher? (meta F))) - -(defn- wrap-meta [f] - (with-meta f {::matcher? true})) +;; TODO extend matcher's metadata with to-edn function (declare matcher* match?) -(defn cat [& PS] +(defn conj + "conj[unction] of multiple patterns." + [& PS] (let [MS (map matcher* PS)] - (wrap-meta - (fn [matches rules data] - (reduce - (fn [ms M] - (or (seq (mapcat #(M % rules data) ms)) (reduced ()))) - (list matches) - MS))))) + (with-meta + (fn [matches data] + (reduce + (fn [ms M] + (or (seq (mapcat #(M % data) ms)) (reduced ()))) + (list matches) + MS)) + {::matcher? true}))) -(defn alt [& PS] +(defn disj + "disj[unction] of multiple patterns." + [& PS] (let [MS (map matcher* PS)] - (wrap-meta - (fn [matches rules data] - (reduce - (fn [ms M] - (if-let [ms (seq (M matches rules data))] - (reduced ms) - ms)) - () - MS))))) - -(defn not! [P] + (with-meta + (fn [matches data] + (reduce + (fn [ms M] + (if-let [ms (seq (M matches data))] + (reduced ms) + ms)) + () + MS)) + {::matcher? true}))) + +(defn not [P] (let [M (matcher* P)] - (wrap-meta - (fn [matches rules data] - (when-not (match? M matches rules data) - (list matches)))))) + (with-meta + (fn [matches data] + (when-not (match? M matches data) + (list matches))) + {::matcher? true}))) (defn each ([P] (let [M (matcher* P)] - (wrap-meta - (fn [matches rules data] - (when (sequential? data) - (reduce - (fn [ms [M data]] - (mapcat #(M % rules data) ms)) - (list matches) - (map vector (repeat (count data) M) data))))))) + (with-meta + (fn [matches data] + (when (sequential? data) + (reduce + (fn [ms [M data]] + (mapcat #(M % data) ms)) + (list matches) + (map vector (repeat (count data) M) data)))) + {::matcher? true}))) ([index-P value-P] (let [M (each [index-P value-P])] - (wrap-meta - (fn [matches rules data] - (M matches rules (map-indexed vector data))))))) + (with-meta + (fn [matches data] + (M matches (map-indexed vector data))) + {::matcher? true})))) (defn scan ([P] (let [M (matcher* P)] - (wrap-meta - (fn [matches rules data] - (when ((some-fn sequential? map? set?) data) - (mapcat #(M matches rules %) data)))))) + (with-meta + (fn [matches data] + (when (sequential? data) + (mapcat #(M matches %) data))) + {::matcher? true}))) ([index-P value-P] (let [M (matcher* [index-P value-P])] - (wrap-meta - (fn [matches rules data] - (cond - (sequential? data) - (apply concat - (map-indexed - (fn [i v] - (M matches rules [i v])) - data)) - - ((some-fn map? set?) data) - (mapcat #(M matches rules %) data))))))) - -(defn def-rule [name P] - (let [M (matcher* P)] - (wrap-meta - (fn f [matches rules data] - (M matches (assoc rules name f) data))))) - -(defn dynamic-rule-matcher [[name & args]] - (wrap-meta - (fn [matches rules data] - (if-let [rule (get rules name)] - ((apply rule args) matches rules data) - (throw (ex-info "Undefined rule" {:rule name})))))) + (with-meta + (fn [matches data] + (when (sequential? data) + (apply concat + (map-indexed + (fn [i v] + (M matches [i v])) + data)))) + {::matcher? true})))) + +(defn- logic-var? [P] + (and (keyword? P) (some #(string/starts-with? (name P) %) ["?" "!" "_"]))) + +(defn pattern? [P] + (or (logic-var? P) + ((some-fn ::matcher? ::matcher-maker?) (meta P)) + (and ((some-fn map? sequential? set?) P) + (some pattern? P)))) -(def combinator - {'cat cat - 'alt alt - 'not! not! - 'each each - 'scan scan - 'def-rule def-rule}) - -(def control-symbol? - (set (keys combinator))) - -(defn control-sequence? [s] - (boolean - (and (sequential? s) - (control-symbol? (first s))))) +(defn- binding-matcher [P] + (with-meta + (fn [matches data] + (if (contains? matches P) + (if (= data (get matches P)) + (list matches) + ()) + (list (assoc matches P data)))) + {::matcher? true})) + +(defn- memo-binding-matcher [P] + (with-meta + (fn [matches data] + (list (update matches P (fnil cc/conj []) data))) + {::matcher? true})) + +(defn- placeholder-matcher [P] + (if (> (count (name P)) 1) + (binding-matcher P) + (with-meta + (fn [matches _data] + (list matches)) + {::matcher? true}))) + +(defn- data-matcher [D] + (with-meta + (fn [matches data] + (if (= data D) + (list matches) + ())) + {::matcher? true})) -(defn pattern? [o] - (boolean - (or (symbol-type o) - (matcher? o) - (control-sequence? o) - (and ((some-fn map? sequential?) o) (some pattern? o))))) +(defn- seq-matcher [PS] + (let [MS (map matcher* PS)] + (with-meta + (fn [matches data] + (when (and (sequential? data) + (<= (count MS) (count data))) + (reduce-kv + (fn [matches M d] + (mapcat #(M % d) matches)) + (list matches) + (zipmap MS data)))) + {::matcher? true}))) (defn- simple-map-matcher [P] (let [M (reduce-kv #(assoc %1 %2 (matcher* %3)) {} P)] - (wrap-meta - (fn [matches rules data] + (with-meta + (fn [matches data] (reduce-kv (fn [ms k M] (or (and (contains? data k) - (seq (mapcat #(M % rules (get data k)) ms))) + (seq (mapcat #(M % (get data k)) ms))) (reduced ()))) (list matches) - M))))) + M)) + {::matcher? true}))) (defn- complex-map-matcher [P] (let [M (matcher* (seq P))] - (wrap-meta - (fn [matches rules data] - (when (>= (count data) - (count P)) - (mapcat #(M matches rules %) - (filter (fn [comb] (apply distinct? (map first comb))) - (combo/selections data (count P))))))))) + (with-meta + (fn [matches data] + (when (>= (count data) + (count P)) + (mapcat #(M matches %) + (filter (fn [comb] (apply distinct? (map first comb))) + (combo/selections data (count P)))))) + {::matcher? true}))) (defn- map-matcher [P] (let [{simple-keys false complex-keys true} (group-by pattern? (keys P)) @@ -167,85 +167,36 @@ simple-M (simple-map-matcher simple-P) complex-P (not-empty (select-keys P complex-keys)) complex-M (when complex-P (complex-map-matcher complex-P))] - (wrap-meta - (fn [matches rules data] - (when (map? data) - (let [simple-data (select-keys data simple-keys) - complex-data (apply (partial dissoc data) simple-keys) - matches' (simple-M matches rules simple-data)] - (if (and complex-M (seq matches')) - (mapcat #(complex-M % rules complex-data) matches') - matches'))))))) - -(defn- flex-seq-matcher [exact-MS tail-M] - (wrap-meta - (fn [matches rules data] - (when (and (sequential? data) - (<= (count exact-MS) (count data))) - (let [res (reduce - (fn [ms [M data]] - (mapcat #(M % rules data) ms)) - (list matches) - (map vector exact-MS data))] - (mapcat #(tail-M % rules (drop (count exact-MS) data)) res)))))) - -(defn- exact-seq-matcher [exact-MS] - (wrap-meta - (fn [matches rules data] - (when (and (sequential? data) - (= (count exact-MS) (count data))) - (reduce - (fn [ms [M data]] - (mapcat #(M % rules data) ms)) - (list matches) - (map vector exact-MS data)))))) - -(defn- seq-matcher [P] - (let [[exact-P tail-P] (split-with (partial not= '&) P) - exact-MS (map matcher* exact-P) - tail-M (when (seq tail-P) - (when-not (= 2 (count tail-P)) - (throw (ex-info "Destructuring of a sequence tail must be a single pattern" {:pattern (rest tail-P)}))) - (matcher* (second tail-P)))] - (if (seq tail-P) - (flex-seq-matcher exact-MS tail-M) - (exact-seq-matcher exact-MS)))) - -(defn set->map-pattern [P] + (with-meta + (fn [matches data] + (when (map? data) + (let [simple-data (select-keys data simple-keys) + complex-data (apply (partial dissoc data) simple-keys) + matches' (simple-M matches simple-data)] + (if (and complex-M (seq matches')) + (mapcat #(complex-M % complex-data) matches') + matches')))) + {::matcher? true}))) + +(defn- set->map-pattern [P] (let [{simple false complex true} (group-by pattern? P)] (merge - (into {} - (map #(vector % %)) - simple) - (into {} (map #(vector (gensym "__") %)) complex)))) + (into {} (map (fn [v] [v v])) simple) + (into {} (map (fn [v] [(keyword (gensym "_")) v])) complex)))) (defn- set-matcher [P] (let [m (set->map-pattern P) - M (matcher* m)] - (wrap-meta - (fn [matches rules data] - (when (set? data) - (M matches rules (into {} (map #(vector % %)) data))))))) - -(defn- binding-matcher [P] - (wrap-meta - (fn [matches _rules data] - (if (contains? matches P) - (if (= data (get matches P)) - (list matches) - ()) - (list (assoc matches P data)))))) - -(defn clean-matches [matches] - (into {} - (filter #(not (placeholder? (first %)))) - matches)) + M (map-matcher m)] + (with-meta + (fn [matches data] + (when (set? data) + (M matches (into {} (map (fn [v] [v v])) data)))) + {::matcher? true}))) (defn- matcher* [P] (cond - (and (fn? P) - (::matcher? (meta P))) + (::matcher? (meta P)) P (set? P) @@ -255,71 +206,47 @@ (map-matcher P) (sequential? P) - (cond - (control-symbol? (first P)) - (apply (combinator (first P)) (rest P)) - - (dynamic-rule? (first P)) - (dynamic-rule-matcher P) - - :else - (seq-matcher P)) - - (symbol-type P) - (case (symbol-type P) - ::placeholder - (if (> (count (name P)) 1) - (binding-matcher P) - (wrap-meta - (fn [matches _rules _data] - (list matches)))) - - ::rule - (wrap-meta - (fn [matches rules data] - (if-let [M (get rules P)] - (M matches rules data) - (throw (ex-info "Undefined rule" {:rule P}))))) + (seq-matcher P) - ::binding - (binding-matcher P) - - ::memo-binding - (wrap-meta - (fn [matches _rules data] - (list (update matches P (fnil conj []) data))))) + (logic-var? P) + (case (first (name P)) + \? (binding-matcher P) + \! (memo-binding-matcher P) + \_ (placeholder-matcher P)) :else - (wrap-meta - (fn [matches _rules data] - (if (= data P) - (list matches) - ()))))) + (data-matcher P))) + +(defn clean-matches [matches] + (reduce-kv + (fn [m k v] + (if (= \_ (first (name k))) + m + (assoc m k v))) + {} + matches)) (defn matcher [P] (let [M (matcher* P)] - (wrap-meta - (fn f - ([data] (f {} {} data)) - ([matches data] (f matches {} data)) - ([matches rules data] - (sequence - (map clean-matches) - (M matches rules data))))))) + (with-meta + (fn f + ([data] (f {} data)) + ([matches data] + (sequence + (map clean-matches) + (M matches data)))) + {::matcher? true}))) (defn matches - ([pattern data] (matches pattern {} {} data)) - ([pattern rules data] (matches pattern {} rules data)) - ([pattern init-matches rules data] - (let [rules (reduce-kv #(assoc %1 %2 (if (fn? %3) %3 (matcher %3))) {} rules)] - (sequence - (map clean-matches) - (if (fn? pattern) - (pattern init-matches rules data) - ((matcher pattern) init-matches rules data)))))) + ([pattern data] (matches pattern {} data)) + ([pattern init-matches data] + (sequence + (map clean-matches) + (if (fn? pattern) + (pattern init-matches data) + ((matcher pattern) init-matches data))))) (defn match? - ([pattern data] (match? pattern {} {} data)) - ([pattern rules data] (match? pattern {} rules data)) - ([pattern init-matches rules data] - (boolean (seq (matches pattern init-matches rules data))))) + ([pattern data] (match? pattern {} data)) + ([pattern init-matches data] + (boolean (seq (matches pattern init-matches data))))) diff --git a/src/matchete/logic.cljc b/src/matchete/logic.cljc new file mode 100644 index 0000000..047e29b --- /dev/null +++ b/src/matchete/logic.cljc @@ -0,0 +1,242 @@ +(ns matchete.logic + (:refer-clojure :exclude [not conj disj var?]) + (:require [clojure.math.combinatorics :as combo] + [clojure.string :as string] + [#?(:clj clojure.core :cljs cljs.core) :as cc])) + +(defn- var? [P] + (and (keyword? P) (some #(string/starts-with? (name P) %) ["?" "!" "_"]))) + +(defprotocol Pattern + (matches [this data] [this precondition data])) + +(defprotocol Matcher + (match? [this data] [this precondition data])) + +(defn pattern? [P] + (or (satisfies? Pattern P) + (var? P) + (and ((some-fn map? sequential? set?) P) + (some pattern? P)))) + +(declare matcher pattern*) + +(defn conj + "conj[unction] of multiple patterns." + [& patterns] + (let [MS (mapv pattern* patterns)] + (reify Pattern + (matches [_ precondition data] + (reduce + (fn [ms M] + (or + (seq (mapcat #(matches M % data) ms)) + (reduced ()))) + (list precondition) + MS))))) + +(defn disj + "disj[unction] of multiple patterns." + [& patterns] + (let [MS (mapv pattern* patterns)] + (reify Pattern + (matches [_ precondition data] + (reduce + (fn [ms M] + (if-let [ms (seq (matches M precondition data))] + (reduced ms) + ms)) + () + MS))))) + +(defn not [pattern] + (let [M (matcher pattern)] + (reify Pattern + (matches [_ preconditions data] + (when-not (match? M preconditions data) + (list preconditions)))))) + +(defn each + ([item-pattern] + (let [M (pattern* item-pattern)] + (reify Pattern + (matches [_ preconditions data] + (when (sequential? data) + (reduce + (fn [ms [M data]] + (mapcat #(matches M % data) ms)) + (list preconditions) + (map vector (repeat (count data) M) data))))))) + ([index-pattern item-pattern] + (let [M (each [index-pattern item-pattern])] + (reify Pattern + (matches [_ preconditions data] + (matches M preconditions (map-indexed vector data))))))) + +(defn scan + ([item-pattern] + (let [M (pattern* item-pattern)] + (reify Pattern + (matches [_ preconditions data] + (when ((some-fn sequential? map? set?) data) + (mapcat #(matches M preconditions %) data)))))) + ([index-pattern item-pattern] + (let [M (pattern* [index-pattern item-pattern])] + (reify Pattern + (matches [_ preconditions data] + (when ((some-fn sequential? map? set?) data) + (cond + (sequential? data) + (apply concat + (map-indexed + (fn [i v] + (matches M preconditions [i v])) + data)) + + (map? data) + (mapcat (fn [[k v]] (matches M preconditions [k v])) data) + + (set? data) + (mapcat (fn [v] (matches M preconditions [v v])) data)))))))) + +(defn- simple-map-pattern [P] + (let [M (reduce-kv #(assoc %1 %2 (pattern* %3)) {} P)] + (reify Pattern + (matches [_ preconditions data] + (reduce-kv + (fn [ms k M] + (or (and (contains? data k) + (seq (mapcat #(matches M % (get data k)) ms))) + (reduced ()))) + (list preconditions) + M))))) + +(defn- complex-map-pattern [P] + (let [M (pattern* (seq P))] + (reify Pattern + (matches [_ preconditions data] + (when (>= (count data) + (count P)) + (mapcat #(matches M preconditions %) + (filter (fn [comb] (apply distinct? (map first comb))) + (combo/selections data (count P))))))))) + +(defn- map-pattern [P] + (let [{simple-keys false complex-keys true} (group-by pattern? (keys P)) + simple-P (select-keys P simple-keys) + simple-M (simple-map-pattern simple-P) + complex-P (not-empty (select-keys P complex-keys)) + complex-M (when complex-P (complex-map-pattern complex-P))] + (reify Pattern + (matches [_ preconditions data] + (when (map? data) + (let [simple-data (select-keys data simple-keys) + complex-data (apply (partial dissoc data) simple-keys) + preconditions' (matches simple-M preconditions simple-data)] + (if (and complex-M (seq preconditions')) + (mapcat #(matches complex-M % complex-data) preconditions') + preconditions'))))))) + +(defn- set->map-pattern [prefix P] + (let [{simple false + complex true} (group-by pattern? P)] + (merge + (into {} (map (fn [v] [v v])) simple) + (into {} (map (fn [v] [(keyword (gensym prefix)) v])) complex)))) + +(defn- set-pattern [P] + (let [key-prefix (str (name (gensym "_")) "_") + M (map-pattern (set->map-pattern key-prefix P))] + (reify Pattern + (matches [_ preconditions data] + (when (set? data) + (sequence + (map #(into {} + (filter (fn [[k _]] + (cc/not (string/starts-with? (name k) key-prefix)))) + %)) + (matches M preconditions (into {} (map (fn [v] [v v])) data)))))))) + +(defn- seq-pattern [patterns-list] + (let [MS (mapv pattern* patterns-list)] + (reify Pattern + (matches [_ preconditions data] + (when (and (sequential? data) + (<= (count MS) (count data))) + (reduce-kv + (fn [preconditions M d] + (mapcat #(matches M % d) preconditions)) + (list preconditions) + (zipmap MS data))))))) + +(defn- binding-pattern [P] + (reify Pattern + (matches [_ precondition data] + (if (contains? precondition P) + (if (= data (get precondition P)) + (list precondition) + ()) + (list (assoc precondition P data)))))) + +(defn- memo-binding-pattern [P] + (reify Pattern + (matches [_ precondition data] + (list (update precondition P (fnil cc/conj []) data))))) + +(defn- placeholder-pattern [P] + (if (> (count (name P)) 1) + (binding-pattern P) + (reify Pattern + (matches [_ precondition _data] + (list precondition))))) + +(defn- data-pattern [value] + (reify + Pattern + (matches [_ precondition data] + (when (= data value) + (list precondition))))) + +(defn- pattern* [P] + (cond + (satisfies? Pattern P) P + + (set? P) + (set-pattern P) + + (map? P) + (map-pattern P) + + (sequential? P) + (seq-pattern P) + + (var? P) + (case (first (name P)) + \? (binding-pattern P) + \! (memo-binding-pattern P) + \_ (placeholder-pattern P)) + + :else (data-pattern P))) + +(defn clean-matches [matches] + (reduce-kv + (fn [m k v] + (if (= \_ (first (name k))) + m + (assoc m k v))) + {} + matches)) + +(defn matcher [pattern] + (let [P (pattern* pattern)] + (reify + Matcher + (match? [this data] + (match? this {} data)) + (match? [this precondition data] + (boolean (seq (matches this precondition data)))) + Pattern + (matches [this data] + (matches this {} data)) + (matches [this precondition data] + (matches P precondition data))))) diff --git a/test/matchete/core_test.cljc b/test/matchete/core_test.cljc deleted file mode 100644 index 90e47ab..0000000 --- a/test/matchete/core_test.cljc +++ /dev/null @@ -1,303 +0,0 @@ -(ns matchete.core-test - (:require [matchete.core :as sut] - [example.poker-hand :as ph] - [example.graph :as g] - [clojure.string :as string] - #?(:clj [clojure.test :refer [deftest is are]] - :cljs [cljs.test :refer [deftest is are] :include-macros true])) - #?(:clj (:import (clojure.lang ExceptionInfo)))) - -(deftest core-test - (is (= ['{?x :x - ?y :y - ?obj {:x :x - :y :y} - ?k 1 - ?v 1} - '{?x :x - ?y :y - ?obj {:x :x - :y :y} - ?k 4 - ?v 4}] - (sut/matches - '[1 "qwe" ?x - {:x ?x - :collections [1 2 3 ?x]} - [1 2 3 & _] - [1 2 3 4] - (cat ?obj {:x ?x - :y ?y}) - (alt 1 ?x) - {?k ?v} - #{1 2 3} - _] - [1 "qwe" :x - {:x :x - :collections [1 2 3 :x]} - [1 2 3 4] - [1 2 3 4] - {:x :x - :y :y} - :x - {1 1 - 4 4} - #{1 2 3} - :not-bind])))) - -(deftest memo-binding - (is (= ['{!foo [1 3] - !bar [2 4]}] - (sut/matches '[!foo !bar !foo !bar] - [1 2 3 4]))) - (is (= '({!path [:x :x], ?node 1} - {!path [:x :y], ?node []} - {!path [:x :x], ?node 1}) - (sut/matches '{:foo (scan {!path {!path ?node}})} - {:foo [{:x {:x 1 :y []}} {:x {:x 1}}]})))) - -(deftest pattern? - (is (not (sut/pattern? {:foo 1 :bar 2}))) - (is (sut/pattern? (with-meta (fn []) {::sut/matcher? true})))) - -(deftest scan-pattern - (is (empty? (sut/matches '(scan {:foo ?x}) - [{:bar 1} {:bar 2}]))) - (is (empty? (sut/matches '(scan {:foo ?x}) - {:foo 1}))) - (is (= ['{?x 1}] - (sut/matches '(scan {:foo ?x}) - [{:foo 1}]))) - (is (= ['{?x 1} - '{?x 2}] - (sut/matches '(scan {:foo ?x}) - [{:foo 1} - {} - {:foo 2}]))) - (is (= #{'{?x 1} '{?x 2}} - (set (sut/matches '(scan {:foo ?x}) - #{{:foo 1} - {} - {:foo 2}})))) - (is (= #{'{?x 1 ?y 3 ?z 2} - '{?x 1 ?y 3 ?z 4}} - (set ((sut/matcher '#{?x ?y ?z}) - '{?x 1 - ?y 3} - #{1 2 3 4}))))) - -(deftest scan-indexed-pattern - (is (empty? (sut/matches '(scan ?index ?data) - []))) - (is (empty? (sut/matches '(scan ?index ?data) - {}))) - (is (empty? (sut/matches '(scan ?index ?data) - 42))) - (is (= #{'{?index 1 ?data 2} - '{?index 0 ?data 1} - '{?index 2 ?data 3}} - (set (sut/matches '(scan ?index ?data) - [1 2 3])) - (set (sut/matches '(scan ?index ?data) - {0 1 - 1 2 - 2 3}))))) - -(deftest each-test - (let [rules {'$even? (fn [matches _ n] - (when ((every-pred number? even?) n) - (list matches))) - '$odd? (fn [matches _ n] - (when ((every-pred number? odd?) n) - (list matches)))}] - (is (= ['{!odd [1 3], !even [2]}] - (sut/matches '(each (alt (cat $even? !even) - (cat $odd? !odd))) - rules - [1 2 3]))))) - -(deftest each-indexed-test - (let [rules {'$max (fn [{:syms [?max-element ?current-index] :as matches} _ n] - (list (if (and ?max-element - (> ?max-element n)) - (select-keys matches ['?max-element '?max-index]) - {'?max-element n - '?max-index ?current-index})))} - sample (shuffle (range 100))] - (is (= [{'?max-element 99 '?max-index (ffirst (filter (fn [[_ v]] (= v 99)) - (map-indexed vector sample)))}] - (sut/matches '(each ?current-index $max) rules sample))))) - -(deftest rule-tests - (is (= #{'{!path [:array 1 :x]} - '{!path [:foo :bar :baz]}} - (set (sut/matches '(scan !path - (scan !path - (scan !path 42))) - {:foo {:bar {:baz 42 - :zab 24}} - :array [{:x 1} - {:x 42}]})) - (set (sut/matches '(def-rule $path-to-42 - (scan !path (alt $path-to-42 42))) - {:foo {:bar {:baz 42 - :zab 24}} - :array [{:x 1} - {:x 42}]})) - (set ((sut/matcher '$path-to-42) - {} {'$path-to-42 (sut/matcher '(scan !path (alt $path-to-42 42)))} - {:foo {:bar {:baz 42 - :zab 24}} - :array [{:x 1} - {:x 42}]})) - - (set (sut/matches '$path-to-42 - '{$path-to-42 (scan !path (alt $path-to-42 42))} - {:foo {:bar {:baz 42 - :zab 24}} - :array [{:x 1} - {:x 42}]})))) - - (is (= #{'{!path [:array 1 :x], ?node 42} - '{!path [:foo :bar :zab], ?node 24} - '{!path [:array 1 :y 3], ?node 4} - '{!path [:array 1 :y 1], ?node 2} - '{!path [:foo :bar :baz], ?node 42}} - (set ((sut/matcher '$path-to-even) - {} {'$path-to-even (sut/matcher '(scan !path (alt $path-to-even (cat $even? ?node)))) - '$even? ^::sut/matcher? (fn [matches _rules data] - (when (and (number? data) (even? data)) - (list matches)))} - {:foo {:bar {:baz 42 - :zab 24}} - :array [{:x 1} - {:x 42 - :y [1 2 3 4]}]})))) - - (is (thrown-with-msg? ExceptionInfo - #"Undefined rule" - (sut/matches '(scan $rule) - [1 2 3]))) - - (is (thrown-with-msg? ExceptionInfo - #"Undefined rule" - (sut/matches '(scan (%plus 1 ?n)) - [1 2 3]))) - - (try - (sut/matches '(scan $rule) - [1 2 3]) - (catch ExceptionInfo e - (is (= {:rule '$rule} - (ex-data e)))))) - -(deftest failed-binding - (is (not (sut/match? '{:x ?x - :y ?x} - {:x 1 - :y 2}))) - (is (not (sut/match? '[1 2 3 & _] - {:x 1})))) - -(deftest failed-and - (is (not (sut/match? '{:x ?x - :y (and ?y ?x)} - {:x 1 - :y 2})))) - -(deftest failed-seq - (is (not (sut/match? '[1 2 3] - {:x 1})))) - -(deftest failed-map - (is (not (sut/match? '{:x 1 - :y 2} - {:x 1})))) - -(deftest pattern-as-a-key - (is (= ['{?key :foo}] - (sut/matches '{?key 1} - {:foo 1})))) - -(deftest precompiled-matcher - (let [M (sut/matcher '{?x ?y - ?z ?v})] - (is (= ['{?x :x, ?y 1, ?z :y, ?v 2} - '{?x :x, ?y 1, ?z :z, ?v 3} - '{?x :y, ?y 2, ?z :x, ?v 1} - '{?x :y, ?y 2, ?z :z, ?v 3} - '{?x :z, ?y 3, ?z :x, ?v 1} - '{?x :z, ?y 3, ?z :y, ?v 2}] - (sut/matches M {:x 1 :y 2 :z 3}))))) - -(deftest functional-form - (let [find-leafs (sut/matcher - (sut/def-rule '$find-leafs - (sut/alt (sut/scan '!path '$find-leafs) '?node)))] - (are [x y] (= x (find-leafs y)) - '({?node 1}) 1 - - '({?node nil}) nil - - '({!path [:x], ?node 1} - {!path [:y 0], ?node 2} - {!path [:y 1], ?node 3} - {!path [:y 2], ?node 4}) - {:x 1 :y [2 3 4]}))) - -(deftest poker-hand - (are [hand res] (= (ph/poker-hand hand) res) - #{[:♣ 10] [:♣ 14] [:♣ 12] [:♣ 13] [:♣ 11]} "Royal flush" - - #{[:♠ 5] [:♠ 6] [:♠ 7] [:♠ 8] [:♠ 9]} "Straight flush" - - #{[:♠ 5] [:♦ 5] [:♠ 7] [:♣ 5] [:♥ 5]} "Four of a kind" - - #{[:♠ 5] [:♦ 5] [:♠ 7] [:♣ 5] [:♥ 7]} "Full house" - - #{[:♠ 5] [:♠ 6] [:♠ 7] [:♠ 13] [:♠ 9]} "Flush" - - #{[:♠ 5] [:♣ 6] [:♠ 7] [:♠ 8] [:♠ 9]} "Straight" - - #{[:♠ 5] [:♦ 5] [:♠ 7] [:♣ 5] [:♥ 8]} "Three of a kind" - - #{[:♠ 5] [:♦ 10] [:♠ 7] [:♣ 5] [:♥ 10]} "Two pair" - - #{[:♠ 5] [:♦ 10] [:♠ 7] [:♣ 5] [:♥ 8]} "One pair" - - #{[:♠ 8] [:♠ 5] [:♠ 6] [:♦ 11] [:♠ 7]} [:♦ 11])) - -(deftest graph - (is (= 46 (first (g/shortest-path g/city-to-city-distance))))) - -(deftest not-pattern - (letfn [(matches [data] - (sut/matches '{:foo ?foo - :bar (cat ?bar (not! (%starts-with "__")))} - {'%starts-with (fn [pref] - (fn [matches _ data] - (when (string/starts-with? data pref) - (list matches))))} - data))] - (are [data res] (= res (matches data)) - {:foo 1 :bar "qwe"} ['{?bar "qwe" ?foo 1}] - - {:foo 1 :bar "__qwe"} []))) - -(deftest placeholders-removed - (is (= ['{?bar 2}] - (sut/matches '[_foo _foo ?bar] - [1 1 2]))) - (is (= [] - (sut/matches '[_foo _foo ?bar] - [1 2 3])))) - -(deftest incorrect-tail-pattern - (is (thrown-with-msg? ExceptionInfo - #"Destructuring of a sequence tail must be a single pattern" - (sut/matcher '[?x & ?y ?z]))) - (try - (sut/matcher '[?x & ?y ?z]) - (catch ExceptionInfo e - (is (= {:pattern '(?y ?z)} - (ex-data e)))))) diff --git a/test/matchete/logic_test.cljc b/test/matchete/logic_test.cljc new file mode 100644 index 0000000..e18d596 --- /dev/null +++ b/test/matchete/logic_test.cljc @@ -0,0 +1,228 @@ +(ns matchete.logic-test + (:require [matchete.logic :as logic] + [example.poker-hand :as ph] + [example.graph :as g] + #?(:clj [clojure.test :refer [deftest is are]] + :cljs [cljs.test :refer [deftest is are] :include-macros true]))) + +(deftest core-test + (is (= [{:?x :x + :?y :y + :?obj {:x :x + :y :y} + :?k 1 + :?v 1} + {:?x :x + :?y :y + :?obj {:x :x + :y :y} + :?k 4 + :?v 4}] + (logic/matches (logic/matcher [1 "qwe" :?x + {:x :?x + :collections [1 2 3 :?x]} + [1 2 3] + [1 2 3 4] + (logic/conj :?obj {:x :?x + :y :?y}) + (logic/disj 1 :?x) + {:?k :?v} + #{1 2 3} + :_]) + [1 "qwe" :x + {:x :x + :collections [1 2 3 :x]} + [1 2 3 4] + [1 2 3 4] + {:x :x + :y :y} + :x + {1 1 + 4 4} + #{1 2 3} + :not-bind])))) + +(deftest set-pattern + (is (= [] + (logic/matches (logic/matcher #{:?x :?y 42}) + #{1 2 3}))) + (is (= [{:?x 1, :?y 3} + {:?x 1, :?y 2} + {:?x 3, :?y 1} + {:?x 3, :?y 2} + {:?x 2, :?y 1} + {:?x 2, :?y 3}] + (logic/matches (logic/matcher #{:?x :?y 42}) + #{1 2 3 42})))) + +(deftest not-pattern + (is (= [] + (logic/matches (logic/matcher (logic/each (logic/not 42))) + [1 2 3 42]))) + (is (= [{}] + (logic/matches (logic/matcher (logic/each (logic/not 42))) + [1 2 3 4])))) + +(deftest no-match + (is (every? empty? + [(logic/matches (logic/matcher [:?x :?x]) [1 2]) + (logic/matches (logic/matcher (logic/conj :?x 42)) 43) + (logic/matches (logic/matcher [1 2 3]) "qwe")]))) + +(deftest placeholders + (is (= [{:_user-name "Bob", :?recipient 2} + {:_user-name "Bob", :?recipient 3}] + (logic/matches (logic/matcher {:id :_ + :name :_user-name + :messages (logic/scan {:author :_user-name + :dest :?recipient})}) + {:id 1 + :name "Bob" + :messages [{:author "Bob" + :dest 2} + {:author "Alise" + :dest 1} + {:author "Bob" + :dest 3}]})))) + +(deftest memo-binding + (is (= [{:!foo [1 3] + :!bar [2 4]}] + (logic/matches (logic/matcher [:!foo :!bar :!foo :!bar]) + [1 2 3 4]))) + (is (= [{:!path [:x :x] + :?node 1} + {:!path [:x :y] + :?node []} + {:!path [:x :x] + :?node 1}] + (logic/matches (logic/matcher {:foo (logic/scan {:!path {:!path :?node}})}) + {:foo [{:x {:x 1 :y []}} {:x {:x 1}}]})))) + +(deftest pattern? + (is (not (logic/pattern? {:foo 1 :bar 2}))) + (is (logic/pattern? (reify logic/Pattern + (matches [_ _ _])))) + (is (logic/pattern? {:?foo 1})) + (is (logic/pattern? {(logic/conj 42 :?x) "qwe"}))) + +(deftest scan-pattern + (is (empty? (logic/matches (logic/matcher (logic/scan {:foo :?x})) + [{:bar 1} {:bar 2}]))) + (is (empty? (logic/matches (logic/matcher (logic/scan {:foo :?x})) + {:foo 1}))) + (is (= [{:?x 1}] + (logic/matches (logic/matcher (logic/scan {:foo :?x})) + [{:foo 1}]))) + (is (= [{:?x 1} + {:?x 2}] + (logic/matches (logic/matcher (logic/scan {:foo :?x})) + [{:foo 1} + {} + {:foo 2}])))) + +(deftest scan-indexed-pattern + (is (empty? (logic/matches (logic/matcher (logic/scan :?index :?data)) + []))) + (is (empty? (logic/matches (logic/matcher (logic/scan :?index :?data)) + {}))) + (is (empty? (logic/matches (logic/matcher (logic/scan :?index :?data)) + 42))) + (is (= [{:?index 0 + :?data 1} + {:?index 1 + :?data 2} + {:?index 2 + :?data 3}] + (logic/matches (logic/matcher (logic/scan :?index :?data)) + [1 2 3])))) + +(deftest each-test + (is (= [#:user{:!ids [1 2 3]}] + (logic/matches (logic/matcher {:users (logic/each {:id :user/!ids})}) + {:users [{:id 1 + :name "Alise"} + {:id 2} + {:id 3 + :name "Bob"}]})))) + +(deftest each-indexed-test + (is (= [#:user{:!ids [0 1 2]}] + (logic/matches (logic/matcher {:users (logic/each :user/!ids {:id :_})}) + {:users [{:id 1 + :name "Alise"} + {:id 2} + {:id 3 + :name "Bob"}]})))) + +(deftest failed-binding + (is (not (logic/match? (logic/matcher {:x :?x :y :?x}) {:x 1 :y 2}))) + (is (not (logic/match? (logic/matcher [1 2 3]) {:x 1}))) + (is (not (logic/match? (logic/matcher {:x :?x}) {:?x 1} {:x 2})))) + +(deftest failed-conjn + (is (not (logic/match? (logic/matcher {:x :?x + :y (logic/conj :?y :?x)}) + {:x 1 + :y 2})))) + +(deftest failed-seq + (is (not (logic/match? (logic/matcher [1 2 3]) + {:x 1})))) + +(deftest failed-map + (is (not (logic/match? (logic/matcher {:x 1 + :y 2}) + {:x 1})))) + +(deftest aggregate-rule + (letfn [(minimum [s] + (reify logic/Pattern + (matches [_ preconditions n] + (let [prev-min (get preconditions s n)] + (list (assoc preconditions s (min prev-min n)))))))] + (is (= [{:?min-n 1}] + (logic/matches (logic/matcher (repeat 3 (minimum :?min-n))) + [2 3 1 0]))))) + +(declare children) + +(defn children [] + (reify logic/Pattern + (matches [_ preconditions data] + (logic/matches (logic/matcher + (logic/disj (logic/scan :!path (children)) + :?node)) + preconditions data)))) + +(deftest recursive-matcher + (is (= [{:!path [0], :?node 1} + {:!path [1 :foo 3], :?node 3} + {:!path [1 :foo 2], :?node 2} + {:!path [2], :?node 3}] + (logic/matches (logic/matcher (children)) [1 {:foo #{2 3}} 3])))) + +(deftest poker-hand + (are [hand res] (= (ph/poker-hand hand) res) + #{[:♣ 10] [:♣ 14] [:♣ 12] [:♣ 13] [:♣ 11]} "Royal flush" + + #{[:♠ 5] [:♠ 6] [:♠ 7] [:♠ 8] [:♠ 9]} "Straight flush" + + #{[:♠ 5] [:♦ 5] [:♠ 7] [:♣ 5] [:♥ 5]} "Four of a kind" + + #{[:♠ 5] [:♦ 5] [:♠ 7] [:♣ 5] [:♥ 7]} "Full house" + + #{[:♠ 5] [:♠ 6] [:♠ 7] [:♠ 13] [:♠ 9]} "Flush" + + #{[:♠ 5] [:♣ 6] [:♠ 7] [:♠ 8] [:♠ 9]} "Straight" + + #{[:♠ 5] [:♦ 5] [:♠ 7] [:♣ 5] [:♥ 8]} "Three of a kind" + + #{[:♠ 5] [:♦ 10] [:♠ 7] [:♣ 5] [:♥ 10]} "Two pair" + + #{[:♠ 5] [:♦ 10] [:♠ 7] [:♣ 5] [:♥ 8]} "One pair" + + #{[:♠ 8] [:♠ 5] [:♠ 6] [:♦ 11] [:♠ 7]} [:♦ 11])) + +(deftest graph + (is (= 46 (g/shortest-path g/city-to-city-distance "Berlin")))) From 9dfa5420b12374e4b46495bd3b6541326385d39f Mon Sep 17 00:00:00 2001 From: Kirill Chernyshov Date: Fri, 12 Jun 2020 17:05:00 +0200 Subject: [PATCH 02/15] Introduce BindingGuard to delay checks for bindings not yet present Implement IFn protocol for matcher --- src/matchete/core.cljc | 252 ---------------------------------------- src/matchete/logic.cljc | 25 +++- 2 files changed, 22 insertions(+), 255 deletions(-) delete mode 100644 src/matchete/core.cljc diff --git a/src/matchete/core.cljc b/src/matchete/core.cljc deleted file mode 100644 index 591b1cb..0000000 --- a/src/matchete/core.cljc +++ /dev/null @@ -1,252 +0,0 @@ -(ns matchete.core - (:refer-clojure :exclude [not conj disj]) - (:require [clojure.math.combinatorics :as combo] - [clojure.string :as string] - [#?(:clj clojure.core :cljs cljs.core) :as cc])) - -;; TODO extend matcher's metadata with to-edn function - -(declare matcher* match?) - -(defn conj - "conj[unction] of multiple patterns." - [& PS] - (let [MS (map matcher* PS)] - (with-meta - (fn [matches data] - (reduce - (fn [ms M] - (or (seq (mapcat #(M % data) ms)) (reduced ()))) - (list matches) - MS)) - {::matcher? true}))) - -(defn disj - "disj[unction] of multiple patterns." - [& PS] - (let [MS (map matcher* PS)] - (with-meta - (fn [matches data] - (reduce - (fn [ms M] - (if-let [ms (seq (M matches data))] - (reduced ms) - ms)) - () - MS)) - {::matcher? true}))) - -(defn not [P] - (let [M (matcher* P)] - (with-meta - (fn [matches data] - (when-not (match? M matches data) - (list matches))) - {::matcher? true}))) - -(defn each - ([P] - (let [M (matcher* P)] - (with-meta - (fn [matches data] - (when (sequential? data) - (reduce - (fn [ms [M data]] - (mapcat #(M % data) ms)) - (list matches) - (map vector (repeat (count data) M) data)))) - {::matcher? true}))) - ([index-P value-P] - (let [M (each [index-P value-P])] - (with-meta - (fn [matches data] - (M matches (map-indexed vector data))) - {::matcher? true})))) - -(defn scan - ([P] - (let [M (matcher* P)] - (with-meta - (fn [matches data] - (when (sequential? data) - (mapcat #(M matches %) data))) - {::matcher? true}))) - ([index-P value-P] - (let [M (matcher* [index-P value-P])] - (with-meta - (fn [matches data] - (when (sequential? data) - (apply concat - (map-indexed - (fn [i v] - (M matches [i v])) - data)))) - {::matcher? true})))) - -(defn- logic-var? [P] - (and (keyword? P) (some #(string/starts-with? (name P) %) ["?" "!" "_"]))) - -(defn pattern? [P] - (or (logic-var? P) - ((some-fn ::matcher? ::matcher-maker?) (meta P)) - (and ((some-fn map? sequential? set?) P) - (some pattern? P)))) - -(defn- binding-matcher [P] - (with-meta - (fn [matches data] - (if (contains? matches P) - (if (= data (get matches P)) - (list matches) - ()) - (list (assoc matches P data)))) - {::matcher? true})) - -(defn- memo-binding-matcher [P] - (with-meta - (fn [matches data] - (list (update matches P (fnil cc/conj []) data))) - {::matcher? true})) - -(defn- placeholder-matcher [P] - (if (> (count (name P)) 1) - (binding-matcher P) - (with-meta - (fn [matches _data] - (list matches)) - {::matcher? true}))) - -(defn- data-matcher [D] - (with-meta - (fn [matches data] - (if (= data D) - (list matches) - ())) - {::matcher? true})) - -(defn- seq-matcher [PS] - (let [MS (map matcher* PS)] - (with-meta - (fn [matches data] - (when (and (sequential? data) - (<= (count MS) (count data))) - (reduce-kv - (fn [matches M d] - (mapcat #(M % d) matches)) - (list matches) - (zipmap MS data)))) - {::matcher? true}))) - -(defn- simple-map-matcher [P] - (let [M (reduce-kv #(assoc %1 %2 (matcher* %3)) {} P)] - (with-meta - (fn [matches data] - (reduce-kv - (fn [ms k M] - (or (and (contains? data k) - (seq (mapcat #(M % (get data k)) ms))) - (reduced ()))) - (list matches) - M)) - {::matcher? true}))) - -(defn- complex-map-matcher [P] - (let [M (matcher* (seq P))] - (with-meta - (fn [matches data] - (when (>= (count data) - (count P)) - (mapcat #(M matches %) - (filter (fn [comb] (apply distinct? (map first comb))) - (combo/selections data (count P)))))) - {::matcher? true}))) - -(defn- map-matcher [P] - (let [{simple-keys false complex-keys true} (group-by pattern? (keys P)) - simple-P (select-keys P simple-keys) - simple-M (simple-map-matcher simple-P) - complex-P (not-empty (select-keys P complex-keys)) - complex-M (when complex-P (complex-map-matcher complex-P))] - (with-meta - (fn [matches data] - (when (map? data) - (let [simple-data (select-keys data simple-keys) - complex-data (apply (partial dissoc data) simple-keys) - matches' (simple-M matches simple-data)] - (if (and complex-M (seq matches')) - (mapcat #(complex-M % complex-data) matches') - matches')))) - {::matcher? true}))) - -(defn- set->map-pattern [P] - (let [{simple false - complex true} (group-by pattern? P)] - (merge - (into {} (map (fn [v] [v v])) simple) - (into {} (map (fn [v] [(keyword (gensym "_")) v])) complex)))) - -(defn- set-matcher [P] - (let [m (set->map-pattern P) - M (map-matcher m)] - (with-meta - (fn [matches data] - (when (set? data) - (M matches (into {} (map (fn [v] [v v])) data)))) - {::matcher? true}))) - -(defn- matcher* [P] - (cond - (::matcher? (meta P)) - P - - (set? P) - (set-matcher P) - - (map? P) - (map-matcher P) - - (sequential? P) - (seq-matcher P) - - (logic-var? P) - (case (first (name P)) - \? (binding-matcher P) - \! (memo-binding-matcher P) - \_ (placeholder-matcher P)) - - :else - (data-matcher P))) - -(defn clean-matches [matches] - (reduce-kv - (fn [m k v] - (if (= \_ (first (name k))) - m - (assoc m k v))) - {} - matches)) - -(defn matcher [P] - (let [M (matcher* P)] - (with-meta - (fn f - ([data] (f {} data)) - ([matches data] - (sequence - (map clean-matches) - (M matches data)))) - {::matcher? true}))) - -(defn matches - ([pattern data] (matches pattern {} data)) - ([pattern init-matches data] - (sequence - (map clean-matches) - (if (fn? pattern) - (pattern init-matches data) - ((matcher pattern) init-matches data))))) - -(defn match? - ([pattern data] (match? pattern {} data)) - ([pattern init-matches data] - (boolean (seq (matches pattern init-matches data))))) diff --git a/src/matchete/logic.cljc b/src/matchete/logic.cljc index 047e29b..06fdc1b 100644 --- a/src/matchete/logic.cljc +++ b/src/matchete/logic.cljc @@ -2,17 +2,24 @@ (:refer-clojure :exclude [not conj disj var?]) (:require [clojure.math.combinatorics :as combo] [clojure.string :as string] - [#?(:clj clojure.core :cljs cljs.core) :as cc])) + [#?(:clj clojure.core :cljs cljs.core) :as cc]) + #?(:clj (:import (clojure.lang IFn)))) (defn- var? [P] (and (keyword? P) (some #(string/starts-with? (name P) %) ["?" "!" "_"]))) +(defn binding? [P] + (and (keyword? P) (string/starts-with? (name P) "?"))) + (defprotocol Pattern (matches [this data] [this precondition data])) (defprotocol Matcher (match? [this data] [this precondition data])) +(defprotocol BindingGuard + (probe [this data])) + (defn pattern? [P] (or (satisfies? Pattern P) (var? P) @@ -173,8 +180,15 @@ (reify Pattern (matches [_ precondition data] (if (contains? precondition P) - (if (= data (get precondition P)) + (cond + (satisfies? BindingGuard (get precondition P)) + (when (probe (get precondition P) data) + (list (assoc precondition P data))) + + (= data (get precondition P)) (list precondition) + + :else ()) (list (assoc precondition P data)))))) @@ -239,4 +253,9 @@ (matches [this data] (matches this {} data)) (matches [this precondition data] - (matches P precondition data))))) + (matches P precondition data)) + IFn + (#?(:clj invoke :cljs -invoke) [_ data] + (matches P {} data)) + (#?(:clj invoke :cljs -invoke) [_ preconditions data] + (matches P preconditions data))))) From 9100c3501a9d3b036c6579b0cb1d17496c4d7c37 Mon Sep 17 00:00:00 2001 From: Kirill Chernyshov Date: Tue, 16 Jun 2020 13:54:10 +0200 Subject: [PATCH 03/15] [WIP] --- dev/example/graph.cljc | 12 +- dev/example/poker_hand.cljc | 41 ++-- dev/user.cljc | 11 + src/matchete/{logic.cljc => lang.cljc} | 210 +++++++---------- src/matchete/lang/core.cljc | 164 ++++++++++++++ src/matchete/lang/string.cljc | 23 ++ test/matchete/lang_test.cljc | 301 +++++++++++++++++++++++++ test/matchete/logic_test.cljc | 228 ------------------- 8 files changed, 605 insertions(+), 385 deletions(-) create mode 100644 dev/user.cljc rename src/matchete/{logic.cljc => lang.cljc} (53%) create mode 100644 src/matchete/lang/core.cljc create mode 100644 src/matchete/lang/string.cljc create mode 100644 test/matchete/lang_test.cljc delete mode 100644 test/matchete/logic_test.cljc diff --git a/dev/example/graph.cljc b/dev/example/graph.cljc index 97350bb..71f06e7 100644 --- a/dev/example/graph.cljc +++ b/dev/example/graph.cljc @@ -1,5 +1,5 @@ (ns example.graph - (:require [matchete.logic :as logic])) + (:require [matchete.lang :as ml])) (def city-to-city-distance #{["Berlin" #{["New York" 14] ["London" 2] ["Tokyo" 14] ["Vancouver" 13]}] @@ -9,13 +9,13 @@ ["Vancouver" #{["Berlin" 13] ["New York" 6] ["London" 10] ["Tokyo" 12]}]}) (def calculate-distance - (reify logic/Pattern + (reify ml/Pattern (matches [_ preconditions data] (list (update preconditions :?distance (fnil + 0) data))))) (defn generate-matcher [cities-count] (let [l (range cities-count)] - (logic/matcher + (ml/matcher (into #{} (map (fn [[n1 n2]] [(keyword (str "?" n1)) @@ -30,7 +30,7 @@ (let [{:keys [?distance]} (first (sort-by :?distance - (logic/matches (generate-matcher (count db)) - {:?0 start} - db)))] + (ml/matches (generate-matcher (count db)) + {:?0 start} + db)))] ?distance)) diff --git a/dev/example/poker_hand.cljc b/dev/example/poker_hand.cljc index 995613d..03c0cbe 100644 --- a/dev/example/poker_hand.cljc +++ b/dev/example/poker_hand.cljc @@ -1,17 +1,17 @@ (ns example.poker-hand - (:require [matchete.logic :as logic])) + (:require [matchete.lang :as ml])) (defn card [P] - (logic/matcher P)) + (ml/matcher P)) (defn hand-pattern [pattern] - (logic/matcher (into #{} (map card) pattern))) + (ml/matcher (into #{} (map card) pattern))) (defn match? [matcher hand] - (logic/match? matcher hand)) + (ml/match? matcher hand)) (defn p+ [lvar n] - (reify logic/Pattern + (reify ml/Pattern (matches [_ preconditions m] (cond (and (contains? preconditions lvar) @@ -23,7 +23,7 @@ (list (assoc preconditions lvar (- m n))))))) (defn high-card-> [lvar] - (reify logic/Pattern + (reify ml/Pattern (matches [_ {[_ rank' :as card'] lvar} [_ rank :as card]] (list {lvar (cond (nil? card') @@ -37,43 +37,43 @@ (let [p (hand-pattern [[:?s 14] [:?s 13] [:?s 12] [:?s 11] [:?s 10]])] (defn royal-flush? [hand] - (logic/match? p hand))) + (ml/match? p hand))) (let [p (hand-pattern [[:?s :?n] [:?s (p+ :?n 1)] [:?s (p+ :?n 2)] [:?s (p+ :?n 3)] [:?s (p+ :?n 4)]])] (defn straight-flush? [hand] - (logic/match? p hand))) + (ml/match? p hand))) (let [p (hand-pattern [[:_ :?n] [:_ :?n] [:_ :?n] [:_ :?n] :_])] (defn four-of-a-kind? [hand] - (logic/match? p hand))) + (ml/match? p hand))) (let [p (hand-pattern [[:_ :?m] [:_ :?m] [:_ :?m] [:_ :?n] [:_ :?n]])] (defn full-house? [hand] - (logic/match? p hand))) + (ml/match? p hand))) (let [p (hand-pattern [[:?s :_] [:?s :_] [:?s :_] [:?s :_] [:?s :_]])] (defn flush? [hand] - (logic/match? p hand))) + (ml/match? p hand))) (let [p (hand-pattern [[:_ :?n] [:_ (p+ :?n 1)] [:_ (p+ :?n 2)] [:_ (p+ :?n 3)] [:_ (p+ :?n 4)]])] (defn straight? [hand] - (logic/match? p hand))) + (ml/match? p hand))) (let [p (hand-pattern [[:_ :?n] [:_ :?n] [:_ :?n] :_ :_])] (defn three-of-a-kind? [hand] - (logic/match? p hand))) + (ml/match? p hand))) (let [p (hand-pattern [[:_ :?n] [:_ :?n] [:_ :?m] [:_ :?m] :_])] (defn two-pair? [hand] - (logic/match? p hand))) + (ml/match? p hand))) (let [p (hand-pattern [[:_ :?n] [:_ :?n] :_ :_ :_])] (defn one-pair? [hand] - (logic/match? p hand))) + (ml/match? p hand))) (let [p (hand-pattern (repeatedly 5 #(high-card-> :?card)))] (defn high-card [hand] - (:?card (first (logic/matches p hand))))) + (:?card (first (ml/matches p hand))))) (defn poker-hand {:test #(do @@ -135,12 +135,3 @@ :else (high-card hand))) - -(comment - - (time - (dotimes [_ 100] - (poker-hand #{[:♠ 10] [:♠ 11] [:♠ 12] [:♠ 13] [:♠ 14]}) - (poker-hand #{[:♠ 5] [:♦ 11] [:♠ 6] [:♠ 7] [:♠ 8]}))) - - ) diff --git a/dev/user.cljc b/dev/user.cljc new file mode 100644 index 0000000..4756714 --- /dev/null +++ b/dev/user.cljc @@ -0,0 +1,11 @@ +(ns user) + +(defmacro predicates->pattern-defns [& preds] + `(do ~@(for [p preds] + `(defn ~(symbol (name p)) [& args#] + (make-pattern ~p args#))))) + +(defmacro predicates->pattern-defs [& preds] + `(do ~@(for [p preds] + `(def ~(symbol (name p)) + (make-pattern ~p))))) diff --git a/src/matchete/logic.cljc b/src/matchete/lang.cljc similarity index 53% rename from src/matchete/logic.cljc rename to src/matchete/lang.cljc index 06fdc1b..9b32d79 100644 --- a/src/matchete/logic.cljc +++ b/src/matchete/lang.cljc @@ -1,113 +1,50 @@ -(ns matchete.logic - (:refer-clojure :exclude [not conj disj var?]) +(ns matchete.lang (:require [clojure.math.combinatorics :as combo] - [clojure.string :as string] - [#?(:clj clojure.core :cljs cljs.core) :as cc]) + [clojure.string :as string]) #?(:clj (:import (clojure.lang IFn)))) -(defn- var? [P] - (and (keyword? P) (some #(string/starts-with? (name P) %) ["?" "!" "_"]))) - -(defn binding? [P] - (and (keyword? P) (string/starts-with? (name P) "?"))) - (defprotocol Pattern (matches [this data] [this precondition data])) (defprotocol Matcher (match? [this data] [this precondition data])) -(defprotocol BindingGuard - (probe [this data])) +;; TODO delayed matchers +;; (defprotocol TmpValue +;; (-value [this])) + +;; (defprotocol Checks +;; (-checks [this]) +;; (-ok? [this preconditions value])) + +;; (defn add-check-fn +;; ([f] +;; (reify Checks +;; (-checks [_] [f]) +;; (-ok? [this preconditions value] +;; (filter #(not (% preconditions value)) (-checks this))))) +;; ([checks f] +;; (reify Checks +;; (-checks [_] (conj (-checks checks) f)) +;; (-ok? [this preconditions value] +;; (filter #(not (% preconditions value)) (-checks this)))))) + +(defn- lvar? [P] + (and (keyword? P) (some #(string/starts-with? (name P) %) ["?" "!" "_"]))) + +;; (defn binding? [P] +;; (and (keyword? P) (string/starts-with? (name P) "?"))) (defn pattern? [P] (or (satisfies? Pattern P) - (var? P) + (lvar? P) (and ((some-fn map? sequential? set?) P) (some pattern? P)))) -(declare matcher pattern*) - -(defn conj - "conj[unction] of multiple patterns." - [& patterns] - (let [MS (mapv pattern* patterns)] - (reify Pattern - (matches [_ precondition data] - (reduce - (fn [ms M] - (or - (seq (mapcat #(matches M % data) ms)) - (reduced ()))) - (list precondition) - MS))))) - -(defn disj - "disj[unction] of multiple patterns." - [& patterns] - (let [MS (mapv pattern* patterns)] - (reify Pattern - (matches [_ precondition data] - (reduce - (fn [ms M] - (if-let [ms (seq (matches M precondition data))] - (reduced ms) - ms)) - () - MS))))) - -(defn not [pattern] - (let [M (matcher pattern)] - (reify Pattern - (matches [_ preconditions data] - (when-not (match? M preconditions data) - (list preconditions)))))) - -(defn each - ([item-pattern] - (let [M (pattern* item-pattern)] - (reify Pattern - (matches [_ preconditions data] - (when (sequential? data) - (reduce - (fn [ms [M data]] - (mapcat #(matches M % data) ms)) - (list preconditions) - (map vector (repeat (count data) M) data))))))) - ([index-pattern item-pattern] - (let [M (each [index-pattern item-pattern])] - (reify Pattern - (matches [_ preconditions data] - (matches M preconditions (map-indexed vector data))))))) - -(defn scan - ([item-pattern] - (let [M (pattern* item-pattern)] - (reify Pattern - (matches [_ preconditions data] - (when ((some-fn sequential? map? set?) data) - (mapcat #(matches M preconditions %) data)))))) - ([index-pattern item-pattern] - (let [M (pattern* [index-pattern item-pattern])] - (reify Pattern - (matches [_ preconditions data] - (when ((some-fn sequential? map? set?) data) - (cond - (sequential? data) - (apply concat - (map-indexed - (fn [i v] - (matches M preconditions [i v])) - data)) - - (map? data) - (mapcat (fn [[k v]] (matches M preconditions [k v])) data) - - (set? data) - (mapcat (fn [v] (matches M preconditions [v v])) data)))))))) +(declare pattern matcher) (defn- simple-map-pattern [P] - (let [M (reduce-kv #(assoc %1 %2 (pattern* %3)) {} P)] + (let [M (reduce-kv #(assoc %1 %2 (pattern %3)) {} P)] (reify Pattern (matches [_ preconditions data] (reduce-kv @@ -119,7 +56,7 @@ M))))) (defn- complex-map-pattern [P] - (let [M (pattern* (seq P))] + (let [M (pattern (seq P))] (reify Pattern (matches [_ preconditions data] (when (>= (count data) @@ -160,12 +97,12 @@ (sequence (map #(into {} (filter (fn [[k _]] - (cc/not (string/starts-with? (name k) key-prefix)))) + (not (string/starts-with? (name k) key-prefix)))) %)) (matches M preconditions (into {} (map (fn [v] [v v])) data)))))))) -(defn- seq-pattern [patterns-list] - (let [MS (mapv pattern* patterns-list)] +(defn- seq-pattern [PS] + (let [MS (mapv pattern PS)] (reify Pattern (matches [_ preconditions data] (when (and (sequential? data) @@ -178,24 +115,38 @@ (defn- binding-pattern [P] (reify Pattern - (matches [_ precondition data] - (if (contains? precondition P) - (cond - (satisfies? BindingGuard (get precondition P)) - (when (probe (get precondition P) data) - (list (assoc precondition P data))) - - (= data (get precondition P)) - (list precondition) + (matches [_ preconditions data] + (if (contains? preconditions P) + (let [val (get preconditions P)] + (cond + ;; TODO descide based on TmpValue + ;; (satisfies? TmpValue val) + ;; (when (= data (-value val)) + ;; (list preconditions)) + + ;; TODO fire all the checks associated with logical var + ;; (satisfies? Checks val) + ;; (if-let [pending-checks (seq (-ok? val preconditions data))] + ;; (list (assoc preconditions P (reify + ;; Checks + ;; (-checks [_] pending-checks) + ;; (-ok? [this preconditions value] + ;; (filter #(not (% preconditions value)) (-checks this))) + ;; TmpValue + ;; (-value [_] data)))) + ;; (list (assoc preconditions P data))) + + (= data val) + (list preconditions) - :else - ()) - (list (assoc precondition P data)))))) + :else + ())) + (list (assoc preconditions P data)))))) (defn- memo-binding-pattern [P] (reify Pattern (matches [_ precondition data] - (list (update precondition P (fnil cc/conj []) data))))) + (list (update precondition P (fnil conj []) data))))) (defn- placeholder-pattern [P] (if (> (count (name P)) 1) @@ -211,7 +162,23 @@ (when (= data value) (list precondition))))) -(defn- pattern* [P] +(defn- clean-matches [matches] + (reduce-kv + (fn [m k v] + (cond + (= \_ (first (name k))) + m + + ;; TODO extract value from TmpValue + ;; (satisfies? TmpValue v) + ;; (assoc m k (-value v)) + + :else + (assoc m k v))) + {} + matches)) + +(defn pattern [P] (cond (satisfies? Pattern P) P @@ -224,7 +191,7 @@ (sequential? P) (seq-pattern P) - (var? P) + (lvar? P) (case (first (name P)) \? (binding-pattern P) \! (memo-binding-pattern P) @@ -232,17 +199,8 @@ :else (data-pattern P))) -(defn clean-matches [matches] - (reduce-kv - (fn [m k v] - (if (= \_ (first (name k))) - m - (assoc m k v))) - {} - matches)) - -(defn matcher [pattern] - (let [P (pattern* pattern)] +(defn matcher [P] + (let [P (pattern P)] (reify Matcher (match? [this data] @@ -255,7 +213,7 @@ (matches [this precondition data] (matches P precondition data)) IFn - (#?(:clj invoke :cljs -invoke) [_ data] - (matches P {} data)) + (#?(:clj invoke :cljs -invoke) [this data] + (this {} data)) (#?(:clj invoke :cljs -invoke) [_ preconditions data] - (matches P preconditions data))))) + (sequence (map clean-matches) (matches P preconditions data)))))) diff --git a/src/matchete/lang/core.cljc b/src/matchete/lang/core.cljc new file mode 100644 index 0000000..c874207 --- /dev/null +++ b/src/matchete/lang/core.cljc @@ -0,0 +1,164 @@ +(ns matchete.lang.core + (:refer-clojure :exclude [every? some number? string? boolean? integer? + pos? neg? even? odd? rational? decimal? float? double? + keyword? symbol? + or and]) + (:require [matchete.lang :as ml] + [clojure.core :as cc])) + +(defn- make-pattern [p] + (reify ml/Pattern + (matches [_ preconditions data] + (when (p data) + (list preconditions))))) + +(defn and + ([P] (ml/pattern P)) + ([P & patterns] + (let [MS (mapv ml/pattern (list* P patterns))] + (reify ml/Pattern + (matches [_ precondition data] + (reduce + (fn [ms M] + (cc/or (seq (mapcat #(ml/matches M % data) ms)) + (reduced ()))) + (list precondition) + MS)))))) + +(defn or + ([P] (ml/pattern P)) + ([P & patterns] + (let [MS (mapv ml/pattern (list* P patterns))] + (reify ml/Pattern + (matches [_ precondition data] + (reduce + (fn [ms M] + (if-let [ms (seq (ml/matches M precondition data))] + (reduced ms) + ms)) + () + MS)))))) + +(defn every? + ([item-pattern] + (let [M (ml/pattern item-pattern)] + (reify ml/Pattern + (matches [_ preconditions data] + (when (sequential? data) + (reduce + (fn [ms data] + (mapcat #(ml/matches M % data) ms)) + (list preconditions) + data)))))) + ([index-pattern item-pattern] + (let [M (every? [index-pattern item-pattern])] + (reify ml/Pattern + (matches [_ preconditions data] + (when (sequential? data) + (ml/matches M preconditions (map-indexed vector data)))))))) + +(defn some + ([item-pattern] + (let [M (ml/pattern item-pattern)] + (reify ml/Pattern + (matches [_ preconditions data] + (when (sequential? data) + (reduce + (fn [ms data] + (if-let [ms' (seq (mapcat #(ml/matches M % data) ms))] + ms' ms)) + (list preconditions) + data)))))) + ([index-pattern item-pattern] + (let [M (some [index-pattern item-pattern])] + (reify ml/Pattern + (matches [_ preconditions data] + (when (sequential? data) + (ml/matches M preconditions (map-indexed vector data)))))))) + +(defn scan + ([item-pattern] + (let [M (ml/pattern item-pattern)] + (reify ml/Pattern + (matches [_ preconditions data] + (when ((some-fn sequential? map? set?) data) + (mapcat #(ml/matches M preconditions %) data)))))) + ([index-pattern item-pattern] + (let [M (ml/pattern [index-pattern item-pattern])] + (reify ml/Pattern + (matches [_ preconditions data] + (when ((some-fn sequential? map? set?) data) + (cond + (sequential? data) + (apply concat + (map-indexed + (fn [i v] + (ml/matches M preconditions [i v])) + data)) + + (map? data) + (mapcat (fn [[k v]] (ml/matches M preconditions [k v])) data) + + (set? data) + (mapcat (fn [v] (ml/matches M preconditions [v v])) data)))))))) + +(def number? (make-pattern cc/number?)) +(def string? (make-pattern cc/string?)) +(def boolean? (make-pattern cc/boolean?)) +(def integer? (make-pattern cc/integer?)) +(def pos? (make-pattern cc/pos?)) +(def neg? (make-pattern cc/neg?)) +(def even? (make-pattern cc/even?)) +(def odd? (make-pattern cc/odd?)) +(def rational? (make-pattern cc/rational?)) +(def decimal? (make-pattern cc/decimal?)) +(def float? (make-pattern cc/float?)) +(def double? (make-pattern cc/double?)) +(def keyword? (make-pattern cc/keyword?)) +(def symbol? (make-pattern cc/symbol?)) + +;; (defmulti compare-pattern #(ml/binding? %2)) + +;; (defmethod compare-pattern true [f lvar] +;; (reify ml/Pattern +;; (matches [_ p data] +;; (cond +;; (satisfies? ml/Checks (get p lvar)) +;; (list (assoc p lvar (ml/add-check-fn (get p lvar) +;; (fn [_ value] +;; (f data value))))) + +;; (contains? p lvar) +;; (when (f data (get p lvar)) (list p)) + +;; :else +;; (list (assoc p lvar (ml/add-check-fn +;; (fn [_ lvar-data] +;; (f data lvar-data))))))))) + +;; (defmethod compare-pattern false [f val] +;; (reify ml/Pattern +;; (matches [_ p data] +;; (when (f data val) +;; (list p))))) + +(defn compare-pattern [f val] + (reify ml/Pattern + (matches [_ p data] + (when (f data val) + (list p))))) + +(defn not-eq [lvar] + (compare-pattern not= lvar)) + +(defn gt [lvar] + (compare-pattern > lvar)) + +(defn gte [lvar] + (compare-pattern >= lvar)) + +(defn lt [lvar] + (compare-pattern < lvar)) + +(defn lte [lvar] + (compare-pattern <= lvar)) diff --git a/src/matchete/lang/string.cljc b/src/matchete/lang/string.cljc new file mode 100644 index 0000000..718eaa6 --- /dev/null +++ b/src/matchete/lang/string.cljc @@ -0,0 +1,23 @@ +(ns matchete.lang.string + (:require [clojure.string :as string] + [matchete.lang :as ml] + [matchete.lang.core :as mlcore])) + +(defn- make-pattern + ([p] (make-pattern p nil)) + ([p args] + (mlcore/and + mlcore/string? + (reify ml/Pattern + (matches [_ preconditions data] + (when (apply p (list* data args)) + (list preconditions))))))) + +(def blank? + (make-pattern string/blank?)) +(defn ends-with? [& args] + (make-pattern string/ends-with? args)) +(defn includes? [& args] + (make-pattern string/includes? args)) +(defn starts-with? [& args] + (make-pattern string/starts-with? args)) diff --git a/test/matchete/lang_test.cljc b/test/matchete/lang_test.cljc new file mode 100644 index 0000000..6ce4c33 --- /dev/null +++ b/test/matchete/lang_test.cljc @@ -0,0 +1,301 @@ +(ns matchete.lang-test + (:require [matchete.lang :as ml] + [matchete.lang.core :as mlcore] + [matchete.lang.string :as mlstring] + [example.poker-hand :as ph] + [example.graph :as g] + #?(:clj [clojure.test :refer [deftest is are]] + :cljs [cljs.test :refer [deftest is are] :include-macros true]))) + +(deftest core-test + (is (= [{:?x :x + :?y :y + :?obj {:x :x + :y :y} + :?k 1 + :?v 1} + {:?x :x + :?y :y + :?obj {:x :x + :y :y} + :?k 4 + :?v 4}] + (ml/matches (ml/matcher [1 "qwe" :?x + {:x :?x + :collections [1 2 3 :?x]} + [1 2 3] + [1 2 3 4] + (mlcore/and :?obj {:x :?x + :y :?y}) + (mlcore/or 1 :?x) + {:?k :?v} + #{1 2 3} + :_]) + [1 "qwe" :x + {:x :x + :collections [1 2 3 :x]} + [1 2 3 4] + [1 2 3 4] + {:x :x + :y :y} + :x + {1 1 + 4 4} + #{1 2 3} + :not-bind])))) + +(deftest set-pattern + (is (= [] + (ml/matches (ml/matcher #{:?x :?y 42}) + #{1 2 3}))) + (is (= [{:?x 1, :?y 3} + {:?x 1, :?y 2} + {:?x 3, :?y 1} + {:?x 3, :?y 2} + {:?x 2, :?y 1} + {:?x 2, :?y 3}] + (ml/matches (ml/matcher #{:?x :?y 42}) + #{1 2 3 42})))) + +(deftest no-match + (is (every? empty? + [(ml/matches (ml/matcher [:?x :?x]) [1 2]) + (ml/matches (ml/matcher (mlcore/and :?x 42)) 43) + (ml/matches (ml/matcher [1 2 3]) "qwe")]))) + +(deftest placeholders + (is (= [{:_user-name "Bob", :?recipient 2} + {:_user-name "Bob", :?recipient 3}] + (ml/matches (ml/matcher {:id :_ + :name :_user-name + :messages (mlcore/scan {:author :_user-name + :dest :?recipient})}) + {:id 1 + :name "Bob" + :messages [{:author "Bob" + :dest 2} + {:author "Alise" + :dest 1} + {:author "Bob" + :dest 3}]})))) + +(deftest memo-binding + (is (= [{:!foo [1 3] + :!bar [2 4]}] + (ml/matches (ml/matcher [:!foo :!bar :!foo :!bar]) + [1 2 3 4]))) + (is (= [{:!path [:x :x] + :?node 1} + {:!path [:x :y] + :?node []} + {:!path [:x :x] + :?node 1}] + (ml/matches (ml/matcher {:foo (mlcore/scan {:!path {:!path :?node}})}) + {:foo [{:x {:x 1 :y []}} {:x {:x 1}}]})))) + +(deftest pattern? + (is (not (ml/pattern? {:foo 1 :bar 2}))) + (is (ml/pattern? (reify ml/Pattern + (matches [_ _ _])))) + (is (ml/pattern? {:?foo 1})) + (is (ml/pattern? {(mlcore/and 42 :?x) "qwe"}))) + +(deftest scan-pattern + (is (empty? (ml/matches (ml/matcher (mlcore/scan {:foo :?x})) + [{:bar 1} {:bar 2}]))) + (is (empty? (ml/matches (ml/matcher (mlcore/scan {:foo :?x})) + {:foo 1}))) + (is (= [{:?x 1}] + (ml/matches (ml/matcher (mlcore/scan {:foo :?x})) + [{:foo 1}]))) + (is (= [{:?x 1} + {:?x 2}] + (ml/matches (ml/matcher (mlcore/scan {:foo :?x})) + [{:foo 1} + {} + {:foo 2}])))) + +(deftest scan-indexed-pattern + (is (empty? (ml/matches (ml/matcher (mlcore/scan :?index :?data)) + []))) + (is (empty? (ml/matches (ml/matcher (mlcore/scan :?index :?data)) + {}))) + (is (empty? (ml/matches (ml/matcher (mlcore/scan :?index :?data)) + 42))) + (is (= [{:?index 0 + :?data 1} + {:?index 1 + :?data 2} + {:?index 2 + :?data 3}] + (ml/matches (ml/matcher (mlcore/scan :?index :?data)) + [1 2 3])))) + +(deftest each-test + (is (= [#:user{:!ids [1 2 3]}] + (ml/matches (ml/matcher {:users (mlcore/every? {:id :user/!ids})}) + {:users [{:id 1 + :name "Alise"} + {:id 2} + {:id 3 + :name "Bob"}]})))) + +(deftest each-indexed-test + (is (= [#:user{:!ids [0 1 2]}] + (ml/matches (ml/matcher {:users (mlcore/every? :user/!ids {:id :_})}) + {:users [{:id 1 + :name "Alise"} + {:id 2} + {:id 3 + :name "Bob"}]})))) + +(deftest some-test + (is (= [#:user{:!ids [1 3], :!names ["Alise" "Bob"]}] + (ml/matches (ml/matcher {:users (mlcore/some {:id :user/!ids + :name :user/!names})}) + {:users [{:id 1 + :name "Alise"} + {:id 2} + {:id 3 + :name "Bob"}]})))) + +(deftest some-indexed-test + (is (= [#:user{:!ids [0 2]}] + (ml/matches (ml/matcher {:users (mlcore/some :user/!ids {:id :_ :name :_})}) + {:users [{:id 1 + :name "Alise"} + {:id 2} + {:id 3 + :name "Bob"}]})))) + + +(deftest failed-binding + (is (not (ml/match? (ml/matcher {:x :?x :y :?x}) {:x 1 :y 2}))) + (is (not (ml/match? (ml/matcher [1 2 3]) {:x 1}))) + (is (not (ml/match? (ml/matcher {:x :?x}) {:?x 1} {:x 2})))) + +(deftest failed-conjn + (is (not (ml/match? (ml/matcher {:x :?x + :y (mlcore/and :?y :?x)}) + {:x 1 + :y 2})))) + +(deftest failed-seq + (is (not (ml/match? (ml/matcher [1 2 3]) + {:x 1})))) + +(deftest failed-map + (is (not (ml/match? (ml/matcher {:x 1 + :y 2}) + {:x 1})))) + +(deftest aggregate-rule + (letfn [(minimum [s] + (reify ml/Pattern + (matches [_ preconditions n] + (let [prev-min (get preconditions s n)] + (list (assoc preconditions s (min prev-min n)))))))] + (is (= [{:?min-n 1}] + (ml/matches (ml/matcher (repeat 3 (minimum :?min-n))) + [2 3 1 0]))))) + +(declare children) + +(defn children [] + (reify ml/Pattern + (matches [_ preconditions data] + (ml/matches (ml/matcher + (mlcore/or (mlcore/scan :!path (children)) + :?node)) + preconditions data)))) + +(deftest recursive-matcher + (is (= [{:!path [0], :?node 1} + {:!path [1 :foo 3], :?node 3} + {:!path [1 :foo 2], :?node 2} + {:!path [2], :?node 3}] + (ml/matches (ml/matcher (children)) [1 {:foo #{2 3}} 3])))) + +(deftest poker-hand + (are [hand res] (= (ph/poker-hand hand) res) + #{[:♣ 10] [:♣ 14] [:♣ 12] [:♣ 13] [:♣ 11]} "Royal flush" + + #{[:♠ 5] [:♠ 6] [:♠ 7] [:♠ 8] [:♠ 9]} "Straight flush" + + #{[:♠ 5] [:♦ 5] [:♠ 7] [:♣ 5] [:♥ 5]} "Four of a kind" + + #{[:♠ 5] [:♦ 5] [:♠ 7] [:♣ 5] [:♥ 7]} "Full house" + + #{[:♠ 5] [:♠ 6] [:♠ 7] [:♠ 13] [:♠ 9]} "Flush" + + #{[:♠ 5] [:♣ 6] [:♠ 7] [:♠ 8] [:♠ 9]} "Straight" + + #{[:♠ 5] [:♦ 5] [:♠ 7] [:♣ 5] [:♥ 8]} "Three of a kind" + + #{[:♠ 5] [:♦ 10] [:♠ 7] [:♣ 5] [:♥ 10]} "Two pair" + + #{[:♠ 5] [:♦ 10] [:♠ 7] [:♣ 5] [:♥ 8]} "One pair" + + #{[:♠ 8] [:♠ 5] [:♠ 6] [:♦ 11] [:♠ 7]} [:♦ 11])) + +(deftest graph + (is (= 46 (g/shortest-path g/city-to-city-distance "Berlin")))) + +(deftest matcher-as-a-function + (let [M (ml/matcher {:id :_id + :messages (mlcore/scan {:author :_id + :message :?msg})})] + (is (= [{:?msg "ping"} + {:?msg "whoohu!"}] + (M {:id 1 + :messages [{:author 1 + :message "ping"} + {:author 2 + :message "pong"} + {:author 1 + :message "whoohu!"}]}))))) + +(deftest and-or + (is (= [{}] ((ml/matcher (mlcore/and 42)) 42))) + (is (= [{}] ((ml/matcher (mlcore/or 42)) 42)))) + +(deftest core-predicates + (is (ml/match? (ml/matcher (mlcore/not-eq 2)) 3)) + (is (not (ml/match? (ml/matcher (mlcore/not-eq 2)) 2))) + + (is (ml/match? (ml/matcher (mlcore/gt 2)) 3)) + (is (not (ml/match? (ml/matcher (mlcore/gt 2)) 1))) + + (is (ml/match? (ml/matcher (mlcore/gte 2)) 2)) + (is (ml/match? (ml/matcher (mlcore/gte 2)) 3)) + (is (not (ml/match? (ml/matcher (mlcore/gte 2)) 1))) + + (is (ml/match? (ml/matcher (mlcore/lt 2)) 1)) + (is (not (ml/match? (ml/matcher (mlcore/lt 2)) 3))) + + (is (ml/match? (ml/matcher (mlcore/lte 2)) 2)) + (is (ml/match? (ml/matcher (mlcore/lte 2)) 1)) + (is (not (ml/match? (ml/matcher (mlcore/lte 2)) 3))) + + (are [x y] (ml/match? (ml/matcher x) y) + mlcore/number? 42.0 + mlcore/string? "42" + mlcore/boolean? false + mlcore/integer? 42 + mlcore/pos? 42 + mlcore/neg? -42 + mlcore/even? 42 + mlcore/odd? 43 + #?@(:clj [mlcore/rational? 5/3 + mlcore/decimal? 42M]) + mlcore/float? 42.0 + mlcore/double? 42.0 + mlcore/keyword? :x42 + mlcore/symbol? 'x42)) + +(deftest string-predicates + (are [x y] (ml/match? (ml/matcher x) y) + mlstring/blank? "" + (mlstring/ends-with? "!") "qwe!" + (mlstring/includes? "we") "qwe!" + (mlstring/starts-with? "q") "qwe!")) diff --git a/test/matchete/logic_test.cljc b/test/matchete/logic_test.cljc deleted file mode 100644 index e18d596..0000000 --- a/test/matchete/logic_test.cljc +++ /dev/null @@ -1,228 +0,0 @@ -(ns matchete.logic-test - (:require [matchete.logic :as logic] - [example.poker-hand :as ph] - [example.graph :as g] - #?(:clj [clojure.test :refer [deftest is are]] - :cljs [cljs.test :refer [deftest is are] :include-macros true]))) - -(deftest core-test - (is (= [{:?x :x - :?y :y - :?obj {:x :x - :y :y} - :?k 1 - :?v 1} - {:?x :x - :?y :y - :?obj {:x :x - :y :y} - :?k 4 - :?v 4}] - (logic/matches (logic/matcher [1 "qwe" :?x - {:x :?x - :collections [1 2 3 :?x]} - [1 2 3] - [1 2 3 4] - (logic/conj :?obj {:x :?x - :y :?y}) - (logic/disj 1 :?x) - {:?k :?v} - #{1 2 3} - :_]) - [1 "qwe" :x - {:x :x - :collections [1 2 3 :x]} - [1 2 3 4] - [1 2 3 4] - {:x :x - :y :y} - :x - {1 1 - 4 4} - #{1 2 3} - :not-bind])))) - -(deftest set-pattern - (is (= [] - (logic/matches (logic/matcher #{:?x :?y 42}) - #{1 2 3}))) - (is (= [{:?x 1, :?y 3} - {:?x 1, :?y 2} - {:?x 3, :?y 1} - {:?x 3, :?y 2} - {:?x 2, :?y 1} - {:?x 2, :?y 3}] - (logic/matches (logic/matcher #{:?x :?y 42}) - #{1 2 3 42})))) - -(deftest not-pattern - (is (= [] - (logic/matches (logic/matcher (logic/each (logic/not 42))) - [1 2 3 42]))) - (is (= [{}] - (logic/matches (logic/matcher (logic/each (logic/not 42))) - [1 2 3 4])))) - -(deftest no-match - (is (every? empty? - [(logic/matches (logic/matcher [:?x :?x]) [1 2]) - (logic/matches (logic/matcher (logic/conj :?x 42)) 43) - (logic/matches (logic/matcher [1 2 3]) "qwe")]))) - -(deftest placeholders - (is (= [{:_user-name "Bob", :?recipient 2} - {:_user-name "Bob", :?recipient 3}] - (logic/matches (logic/matcher {:id :_ - :name :_user-name - :messages (logic/scan {:author :_user-name - :dest :?recipient})}) - {:id 1 - :name "Bob" - :messages [{:author "Bob" - :dest 2} - {:author "Alise" - :dest 1} - {:author "Bob" - :dest 3}]})))) - -(deftest memo-binding - (is (= [{:!foo [1 3] - :!bar [2 4]}] - (logic/matches (logic/matcher [:!foo :!bar :!foo :!bar]) - [1 2 3 4]))) - (is (= [{:!path [:x :x] - :?node 1} - {:!path [:x :y] - :?node []} - {:!path [:x :x] - :?node 1}] - (logic/matches (logic/matcher {:foo (logic/scan {:!path {:!path :?node}})}) - {:foo [{:x {:x 1 :y []}} {:x {:x 1}}]})))) - -(deftest pattern? - (is (not (logic/pattern? {:foo 1 :bar 2}))) - (is (logic/pattern? (reify logic/Pattern - (matches [_ _ _])))) - (is (logic/pattern? {:?foo 1})) - (is (logic/pattern? {(logic/conj 42 :?x) "qwe"}))) - -(deftest scan-pattern - (is (empty? (logic/matches (logic/matcher (logic/scan {:foo :?x})) - [{:bar 1} {:bar 2}]))) - (is (empty? (logic/matches (logic/matcher (logic/scan {:foo :?x})) - {:foo 1}))) - (is (= [{:?x 1}] - (logic/matches (logic/matcher (logic/scan {:foo :?x})) - [{:foo 1}]))) - (is (= [{:?x 1} - {:?x 2}] - (logic/matches (logic/matcher (logic/scan {:foo :?x})) - [{:foo 1} - {} - {:foo 2}])))) - -(deftest scan-indexed-pattern - (is (empty? (logic/matches (logic/matcher (logic/scan :?index :?data)) - []))) - (is (empty? (logic/matches (logic/matcher (logic/scan :?index :?data)) - {}))) - (is (empty? (logic/matches (logic/matcher (logic/scan :?index :?data)) - 42))) - (is (= [{:?index 0 - :?data 1} - {:?index 1 - :?data 2} - {:?index 2 - :?data 3}] - (logic/matches (logic/matcher (logic/scan :?index :?data)) - [1 2 3])))) - -(deftest each-test - (is (= [#:user{:!ids [1 2 3]}] - (logic/matches (logic/matcher {:users (logic/each {:id :user/!ids})}) - {:users [{:id 1 - :name "Alise"} - {:id 2} - {:id 3 - :name "Bob"}]})))) - -(deftest each-indexed-test - (is (= [#:user{:!ids [0 1 2]}] - (logic/matches (logic/matcher {:users (logic/each :user/!ids {:id :_})}) - {:users [{:id 1 - :name "Alise"} - {:id 2} - {:id 3 - :name "Bob"}]})))) - -(deftest failed-binding - (is (not (logic/match? (logic/matcher {:x :?x :y :?x}) {:x 1 :y 2}))) - (is (not (logic/match? (logic/matcher [1 2 3]) {:x 1}))) - (is (not (logic/match? (logic/matcher {:x :?x}) {:?x 1} {:x 2})))) - -(deftest failed-conjn - (is (not (logic/match? (logic/matcher {:x :?x - :y (logic/conj :?y :?x)}) - {:x 1 - :y 2})))) - -(deftest failed-seq - (is (not (logic/match? (logic/matcher [1 2 3]) - {:x 1})))) - -(deftest failed-map - (is (not (logic/match? (logic/matcher {:x 1 - :y 2}) - {:x 1})))) - -(deftest aggregate-rule - (letfn [(minimum [s] - (reify logic/Pattern - (matches [_ preconditions n] - (let [prev-min (get preconditions s n)] - (list (assoc preconditions s (min prev-min n)))))))] - (is (= [{:?min-n 1}] - (logic/matches (logic/matcher (repeat 3 (minimum :?min-n))) - [2 3 1 0]))))) - -(declare children) - -(defn children [] - (reify logic/Pattern - (matches [_ preconditions data] - (logic/matches (logic/matcher - (logic/disj (logic/scan :!path (children)) - :?node)) - preconditions data)))) - -(deftest recursive-matcher - (is (= [{:!path [0], :?node 1} - {:!path [1 :foo 3], :?node 3} - {:!path [1 :foo 2], :?node 2} - {:!path [2], :?node 3}] - (logic/matches (logic/matcher (children)) [1 {:foo #{2 3}} 3])))) - -(deftest poker-hand - (are [hand res] (= (ph/poker-hand hand) res) - #{[:♣ 10] [:♣ 14] [:♣ 12] [:♣ 13] [:♣ 11]} "Royal flush" - - #{[:♠ 5] [:♠ 6] [:♠ 7] [:♠ 8] [:♠ 9]} "Straight flush" - - #{[:♠ 5] [:♦ 5] [:♠ 7] [:♣ 5] [:♥ 5]} "Four of a kind" - - #{[:♠ 5] [:♦ 5] [:♠ 7] [:♣ 5] [:♥ 7]} "Full house" - - #{[:♠ 5] [:♠ 6] [:♠ 7] [:♠ 13] [:♠ 9]} "Flush" - - #{[:♠ 5] [:♣ 6] [:♠ 7] [:♠ 8] [:♠ 9]} "Straight" - - #{[:♠ 5] [:♦ 5] [:♠ 7] [:♣ 5] [:♥ 8]} "Three of a kind" - - #{[:♠ 5] [:♦ 10] [:♠ 7] [:♣ 5] [:♥ 10]} "Two pair" - - #{[:♠ 5] [:♦ 10] [:♠ 7] [:♣ 5] [:♥ 8]} "One pair" - - #{[:♠ 8] [:♠ 5] [:♠ 6] [:♦ 11] [:♠ 7]} [:♦ 11])) - -(deftest graph - (is (= 46 (g/shortest-path g/city-to-city-distance "Berlin")))) From 1ef5289f7ccacdbe621f7b6011e22b9e5c3617fe Mon Sep 17 00:00:00 2001 From: Kirill Chernyshov Date: Fri, 19 Jun 2020 00:00:53 +0200 Subject: [PATCH 04/15] WIP --- deps.edn | 3 +- dev/example/graph.cljc | 31 ++-- dev/example/poker_hand.cljc | 107 +++++++---- dev/user.cljc | 132 +++++++++++++- src/matchete/core.cljc | 330 ++++++++++++++++++++++++++++++++++ src/matchete/lang.cljc | 219 ---------------------- src/matchete/lang/core.cljc | 164 ----------------- src/matchete/lang/string.cljc | 23 --- test/matchete/core_test.cljc | 31 ++++ test/matchete/lang_test.cljc | 301 ------------------------------- 10 files changed, 580 insertions(+), 761 deletions(-) create mode 100644 src/matchete/core.cljc delete mode 100644 src/matchete/lang.cljc delete mode 100644 src/matchete/lang/core.cljc delete mode 100644 src/matchete/lang/string.cljc create mode 100644 test/matchete/core_test.cljc delete mode 100644 test/matchete/lang_test.cljc diff --git a/deps.edn b/deps.edn index 444799b..a80ee33 100644 --- a/deps.edn +++ b/deps.edn @@ -9,6 +9,7 @@ lambdaisland/kaocha-cljs {:mvn/version "0.0-71"}}} :+dev {:extra-paths ["dev"] - :extra-deps {criterium {:mvn/version "0.4.5"}}} + :extra-deps {criterium {:mvn/version "0.4.5"} + meander/epsilon {:mvn/version "0.0.421"}}} :+cljs {:extra-deps {org.clojure/clojurescript {:mvn/version "1.10.764"}}}}} diff --git a/dev/example/graph.cljc b/dev/example/graph.cljc index 71f06e7..5a133a5 100644 --- a/dev/example/graph.cljc +++ b/dev/example/graph.cljc @@ -1,5 +1,5 @@ (ns example.graph - (:require [matchete.lang :as ml])) + (:require [matchete.core :as ml])) (def city-to-city-distance #{["Berlin" #{["New York" 14] ["London" 2] ["Tokyo" 14] ["Vancouver" 13]}] @@ -8,29 +8,32 @@ ["Tokyo" #{["Berlin" 14] ["New York" 18] ["London" 15] ["Vancouver" 12]}] ["Vancouver" #{["Berlin" 13] ["New York" 6] ["London" 10] ["Tokyo" 12]}]}) -(def calculate-distance - (reify ml/Pattern - (matches [_ preconditions data] - (list (update preconditions :?distance (fnil + 0) data))))) +(defn add-distance [distance path] + (+ (or distance 0) path)) (defn generate-matcher [cities-count] (let [l (range cities-count)] - (ml/matcher - (into #{} - (map (fn [[n1 n2]] - [(keyword (str "?" n1)) - #{[(keyword (str "?" n2)) calculate-distance]}])) - (take cities-count (map vector (cycle l) (rest (cycle l)))))))) + (into #{} + (map (fn [[n1 n2]] + [(symbol (str "?" n1)) + #{[(symbol (str "?" n2)) (ml/aggregate add-distance '?distance)]}])) + (take cities-count (map vector (cycle l) (rest (cycle l))))))) (defn shortest-path {:test #(do (assert (= 46 (shortest-path city-to-city-distance "Berlin"))))} [db start] - (let [{:keys [?distance]} + (let [{:syms [?distance]} (first - (sort-by :?distance + (sort-by #(get % '?distance) (ml/matches (generate-matcher (count db)) - {:?0 start} + {'?0 start} db)))] ?distance)) + +(comment + + (shortest-path city-to-city-distance "Berlin") + + ) diff --git a/dev/example/poker_hand.cljc b/dev/example/poker_hand.cljc index 03c0cbe..0687d74 100644 --- a/dev/example/poker_hand.cljc +++ b/dev/example/poker_hand.cljc @@ -1,8 +1,8 @@ (ns example.poker-hand - (:require [matchete.lang :as ml])) + (:require [matchete.core :as ml :include-macros true])) (defn card [P] - (ml/matcher P)) + (ml/pattern P)) (defn hand-pattern [pattern] (ml/matcher (into #{} (map card) pattern))) @@ -10,70 +10,85 @@ (defn match? [matcher hand] (ml/match? matcher hand)) -(defn p+ [lvar n] - (reify ml/Pattern - (matches [_ preconditions m] - (cond - (and (contains? preconditions lvar) - (= m (+ n (get preconditions lvar)))) - (list preconditions) - - (and (not (contains? preconditions lvar)) - (> m n)) - (list (assoc preconditions lvar (- m n))))))) - -(defn high-card-> [lvar] - (reify ml/Pattern - (matches [_ {[_ rank' :as card'] lvar} [_ rank :as card]] - (list {lvar (cond - (nil? card') - card - - (> rank rank') - card - - :else - card')})))) - -(let [p (hand-pattern [[:?s 14] [:?s 13] [:?s 12] [:?s 11] [:?s 10]])] +(let [p (hand-pattern '[[?s 14] [?s 13] [?s 12] [?s 11] [?s 10]])] (defn royal-flush? [hand] (ml/match? p hand))) -(let [p (hand-pattern [[:?s :?n] [:?s (p+ :?n 1)] [:?s (p+ :?n 2)] [:?s (p+ :?n 3)] [:?s (p+ :?n 4)]])] +(let [p (hand-pattern [['?s '?n] + ['?s (ml/formula (+ ?n 1))] + ['?s (ml/formula (+ ?n 2))] + ['?s (ml/formula (+ ?n 3))] + ['?s (ml/formula (+ ?n 4))]])] (defn straight-flush? [hand] (ml/match? p hand))) -(let [p (hand-pattern [[:_ :?n] [:_ :?n] [:_ :?n] [:_ :?n] :_])] +(let [p (hand-pattern '[[?_ ?n] + [?_ ?n] + [?_ ?n] + [?_ ?n] + ?_])] (defn four-of-a-kind? [hand] (ml/match? p hand))) -(let [p (hand-pattern [[:_ :?m] [:_ :?m] [:_ :?m] [:_ :?n] [:_ :?n]])] +(let [p (hand-pattern '[[?_ ?m] + [?_ ?m] + [?_ ?m] + [?_ ?n] + [?_ ?n]])] (defn full-house? [hand] (ml/match? p hand))) -(let [p (hand-pattern [[:?s :_] [:?s :_] [:?s :_] [:?s :_] [:?s :_]])] +(let [p (hand-pattern '[[?s ?_] + [?s ?_] + [?s ?_] + [?s ?_] + [?s ?_]])] (defn flush? [hand] (ml/match? p hand))) -(let [p (hand-pattern [[:_ :?n] [:_ (p+ :?n 1)] [:_ (p+ :?n 2)] [:_ (p+ :?n 3)] [:_ (p+ :?n 4)]])] +(let [p (hand-pattern [['?_ '?n] + ['?_ (ml/formula (+ ?n 1))] + ['?_ (ml/formula (+ ?n 2))] + ['?_ (ml/formula (+ ?n 3))] + ['?_ (ml/formula (+ ?n 4))]])] (defn straight? [hand] (ml/match? p hand))) -(let [p (hand-pattern [[:_ :?n] [:_ :?n] [:_ :?n] :_ :_])] +(let [p (hand-pattern '[[?_ ?n] + [?_ ?n] + [?_ ?n] + ?_ + ?_])] (defn three-of-a-kind? [hand] (ml/match? p hand))) -(let [p (hand-pattern [[:_ :?n] [:_ :?n] [:_ :?m] [:_ :?m] :_])] +(let [p (hand-pattern '[[?_ ?n] + [?_ ?n] + [?_ ?m] + [?_ ?m] + ?_])] (defn two-pair? [hand] (ml/match? p hand))) -(let [p (hand-pattern [[:_ :?n] [:_ :?n] :_ :_ :_])] +(let [p (hand-pattern '[[?_ ?n] + [?_ ?n] + ?_ + ?_ + ?_])] (defn one-pair? [hand] (ml/match? p hand))) -(let [p (hand-pattern (repeatedly 5 #(high-card-> :?card)))] +(let [aggr-fn (fn [[_ old-rank :as old-card] [_ new-rank :as new-card]] + (if (> new-rank (or old-rank 0)) + new-card + old-card)) + p (hand-pattern [(ml/aggregate aggr-fn :high-card) + (ml/aggregate aggr-fn :high-card) + (ml/aggregate aggr-fn :high-card) + (ml/aggregate aggr-fn :high-card) + (ml/aggregate aggr-fn :high-card)])] (defn high-card [hand] - (:?card (first (ml/matches p hand))))) + (:high-card (first (ml/matches p hand))))) (defn poker-hand {:test #(do @@ -135,3 +150,19 @@ :else (high-card hand))) + +(comment + + (time + (dotimes [_ 10] + (test #'poker-hand))) + + (royal-flush? #{[:♠ 10] [:♠ 11] [:♠ 12] [:♠ 13] [:♠ 9]}) + + (straight-flush? #{[:♠ 5] [:♠ 6] [:♠ 7] [:♠ 8] [:♠ 9]}) + + (straight? #{[:♠ 5] [:♣ 6] [:♠ 7] [:♠ 8] [:♠ 9]}) + + (high-card #{[:♠ 5] [:♦ 5] [:♠ 7] [:♣ 5] [:♥ 5]}) + + ) diff --git a/dev/user.cljc b/dev/user.cljc index 4756714..aec238f 100644 --- a/dev/user.cljc +++ b/dev/user.cljc @@ -1,4 +1,9 @@ -(ns user) +(ns user + (:require [meander.epsilon :as m] + [matchete.lang :as ml] + [matchete.lang.core :as mlcore] + [matchete.core :as ml2] + [criterium.core :refer [quick-bench]])) (defmacro predicates->pattern-defns [& preds] `(do ~@(for [p preds] @@ -9,3 +14,128 @@ `(do ~@(for [p preds] `(def ~(symbol (name p)) (make-pattern ~p))))) + +(defn favorite-food-info [foods-by-name user] + (m/match {:user user + :foods-by-name foods-by-name} + {:foods-by-name {?food {:popularity ?popularity + :calories ?calories}} + :user + {:name ?name + :favorite-food {:name ?food}} + } + {:name ?name + :favorite {:food ?food + :popularity ?popularity + :calories ?calories}})) + +(defn favorite-foods-info [foods-by-name user] + (m/search {:user user + :foods-by-name foods-by-name} + {:user + {:name ?name + :favorite-foods (m/scan {:name ?food})} + :foods-by-name {?food {:popularity ?popularity + :calories ?calories}}} + {:name ?name + :favorite {:food ?food + :popularity ?popularity + :calories ?calories}})) + +(def foods-by-name + {:nachos {:popularity :high + :calories :lots} + :smoothie {:popularity :high + :calories :less}}) + +;; (time +;; (dotimes [_ 1000] +;; (favorite-food-info foods-by-name +;; {:name :alice +;; :favorite-food {:name :nachos}}))) + +;; (time +;; (dotimes [_ 1000] +;; (favorite-foods-info foods-by-name +;; {:name :alice +;; :favorite-foods [{:name :nachos} +;; {:name :smoothie}]}))) + +;; (let [M (ml/matcher '{:user {:name ?name +;; :favorite-food {:name ?food}} +;; :foods-by-name {?food {:popularity ?popularity +;; :calories ?calories}}})] +;; (time +;; (dotimes [_ 1000] +;; (M {:user {:name :alice +;; :favorite-food {:name :nachos}} +;; :foods-by-name foods-by-name})))) + +;; (let [M (ml/matcher {:user {:name :?name +;; :favorite-foods (mlcore/scan {:name :?food})} +;; :foods-by-name {:?food {:popularity :?popularity +;; :calories :?calories}}})] +;; (M {:user {:name :alice +;; :favorite-foods [{:name :nachos} +;; {:name :smoothie}]} +;; :foods-by-name foods-by-name}) +;; (time +;; (dotimes [_ 1000] +;; (M {:user {:name :alice +;; :favorite-foods [{:name :nachos} +;; {:name :smoothie}]} +;; :foods-by-name foods-by-name})))) + +;; (m/match {:foo [1 2 3 4]} +;; {:foo [42 '?x '?y]} +;; {:x '?x :y '?y}) + +(let [M2 (ml2/matcher {:user {:name '?name + :favorite-foods (ml2/scan {:name '?food})} + :foods-by-name {'?food {:popularity '?popularity + :calories '?calories}}}) + M1 (ml/matcher {:user {:name '?name + :favorite-foods (mlcore/scan {:name '?food})} + :foods-by-name {'?food {:popularity '?popularity + :calories '?calories}}})] + (prn "---DBG matchete1" (M1 {:user {:name :alice + :favorite-foods [{:name :nachos} + {:name :smoothie}]} + :foods-by-name foods-by-name})) + (prn "---DBG matchete2" (M2 {:user {:name :alice + :favorite-foods [{:name :nachos} + {:name :smoothie}]} + :foods-by-name foods-by-name})) + (prn "---DBG meander" (favorite-foods-info foods-by-name + {:name :alice + :favorite-foods [{:name :nachos} + {:name :smoothie}]})) + (quick-bench (doall (M1 {:user {:name :alice + :favorite-foods [{:name :nachos} + {:name :smoothie}]} + :foods-by-name foods-by-name}))) + (quick-bench (doall (M2 {:user {:name :alice + :favorite-foods [{:name :nachos} + {:name :smoothie}]} + :foods-by-name foods-by-name}))) + (quick-bench (doall (favorite-foods-info foods-by-name + {:name :alice + :favorite-foods [{:name :nachos} + {:name :smoothie}]})))) + +(let [M (ml2/matcher '{:user {:name ?name + :favorite-food {:name ?food}} + :foods-by-name {?food {:popularity ?popularity + :calories ?calories}}})] + (prn "---DBG matchete" (M {:user {:name :alice + :favorite-food {:name :nachos}} + :foods-by-name foods-by-name})) + (prn "---DBG meander" (favorite-food-info foods-by-name + {:name :alice + :favorite-food {:name :nachos}})) + (quick-bench (doall (M {:user {:name :alice + :favorite-food {:name :nachos}} + :foods-by-name foods-by-name}))) + (quick-bench (doall (favorite-food-info foods-by-name + {:name :alice + :favorite-food {:name :nachos}})))) diff --git a/src/matchete/core.cljc b/src/matchete/core.cljc new file mode 100644 index 0000000..a9b0612 --- /dev/null +++ b/src/matchete/core.cljc @@ -0,0 +1,330 @@ +(ns matchete.core + (:refer-clojure :rename {some core-some + and core-and + or core-or + not core-not}) + (:require [clojure.math.combinatorics :as combo] + [clojure.set :as set])) + +(defn lvar? [x] + (core-and (simple-symbol? x) (= \? (first (name x))))) + +(defn placeholder? [x] + (core-and (lvar? x) (= \_ (second (name x))))) + +(defn pattern? [P] + (core-or (:pattern (meta P)) + (lvar? P) + (core-and ((some-fn map? sequential? set?) P) + (core-some pattern? P)))) + +(declare pattern) + +(defn- simple-map-pattern [P] + (let [P (reduce-kv #(assoc %1 %2 (pattern %3)) {} P)] + (fn [data ms] + (reduce-kv + (fn [ms k v] + (core-or (seq (v (get data k) ms)) (reduced ()))) + ms + P)))) + +(defn- complex-map-pattern [P] + (if (empty? P) + (fn [_data ms] ms) + (let [M (pattern (seq P))] + (fn [data ms] + (mapcat #(M % ms) + (filter #(apply distinct? (map first %)) + (combo/selections data (count P)))))))) + +(defn map-pattern [P] + (let [{scalar-keys false variable-keys true} (group-by pattern? (keys P)) + simple-pattern (simple-map-pattern (select-keys P scalar-keys)) + complex-pattern (complex-map-pattern (select-keys P variable-keys))] + (with-meta + (fn [data ms] + (when (core-and (map? data) + (>= (count data) + (count P)) + (every? #(contains? data %) scalar-keys)) + (let [simple-data (select-keys data scalar-keys) + rest-data (apply dissoc data scalar-keys)] + (when-let [ms' (seq (simple-pattern simple-data ms))] + (complex-pattern rest-data ms'))))) + {:pattern true}))) + +(defn- seq-pattern [P] + (let [P (mapv pattern P)] + (with-meta + (fn [data ms] + (when (sequential? data) + (reduce + (fn [ms [P data]] + (core-or (seq (P data ms)) (reduced ()))) + ms + (partition 2 (interleave P data))))) + {:pattern true}))) + +(defn- complex-set-pattern [P] + (let [M (pattern (seq P))] + (fn [data ms] + (mapcat #(M % ms) + (filter #(apply distinct? %) + (combo/selections data (count P))))))) + +(defn- set-pattern [P] + (let [{scalar-items false variable-items true} (group-by pattern? P) + scalar-items (set scalar-items) + M (complex-set-pattern variable-items)] + (with-meta + (fn [data ms] + (when (core-and (set? data) + (>= (count data) + (count P)) + (set/subset? scalar-items data)) + (M (set/difference data scalar-items) ms))) + {:pattern true}))) + +(defn- lvar-pattern [P] + (with-meta + (fn [data ms] + (reduce + (fn [ms m] + (cond + (core-and (contains? m P) + (not= data (get m P))) + ms + + (core-not (contains? m P)) + (let [{::keys [guards] :as m} (assoc m P data)] + (if-let [m (if (not-empty guards) + (reduce + (fn [m guard] + (case (guard m) + true m + false (reduced nil) + (update m ::guards conj guard))) + (assoc m ::guards []) + guards) + m)] + (conj ms m) + ms)) + + (= data (get m P)) + (conj ms m))) + () + ms)) + {:pattern true})) + +(defn- placeholder-pattern [P] + (if (> (count (name P)) 2) + (lvar-pattern P) + (with-meta + (fn [_data ms] ms) + {:pattern true}))) + +(defn- data-pattern [P] + (with-meta + (fn [data ms] + (when (= data P) ms)) + {:pattern true})) + +(defn pattern [P] + (cond + (:pattern (meta P)) + P + + (map? P) + (map-pattern P) + + (set? P) + (set-pattern P) + + (sequential? P) + (seq-pattern P) + + (placeholder? P) + (placeholder-pattern P) + + (lvar? P) + (lvar-pattern P) + + :else + (data-pattern P))) + +(defn scan + ([P] + (let [M (pattern P)] + (with-meta + (fn [data ms] + (when ((some-fn sequential? map?) data) + (mapcat #(M % ms) data))) + {:pattern true}))) + ([index-P value-P] + (let [M (pattern [index-P value-P])] + (with-meta + (fn [data ms] + (cond + (map? data) + (mapcat #(M [% (get data %)] ms) (keys data)) + + (sequential? data) + (apply concat (map-indexed #(M [%1 %2] ms) data)))) + {:pattern true})))) + +(defn each + ([P] (each P false)) + ([P skip-fail?] + (let [M (pattern P)] + (with-meta + (fn [data ms] + (when (sequential? data) + (reduce + (fn [ms item] + (core-or (seq (M item ms)) (if skip-fail? ms (reduced ())))) + ms + data))) + {:pattern true})))) + +(defn some [P] + (each P true)) + +(defn and + ([P] (pattern P)) + ([P & PS] + (let [MS (mapv pattern (list* P PS))] + (with-meta + (fn [data ms] + (reduce + (fn [ms M] + (core-or (seq (M data ms)) (reduced ()))) + ms + MS)) + {:pattern true})))) + +(defn or + ([P] (pattern P)) + ([P & PS] + (let [MS (mapv pattern (list* P PS))] + (with-meta + (fn [data ms] + (reduce + (fn [ms' M] + (if-let [ms' (seq (M data ms))] + (reduced ms') + ms')) + () + MS)) + {:pattern true})))) + +(defn not [P] + (let [M (pattern P)] + (with-meta + (fn [data ms] + (when-not (seq (M data ms)) + ms)) + {:pattern true}))) + +(defn predicate + ([pred] + (predicate pred nil)) + ([pred dest] + (with-meta + (fn [data ms] + (when (pred data) + (core-or + (core-and (some? dest) + (sequence + (map #(assoc % dest data)) + ms)) + ms))) + {:pattern true}))) + +(defn aggregate + ([aggr-fn] + (with-meta + (fn [data ms] + (sequence + (comp + (map #(aggr-fn % data)) + (filter some?)) + ms)) + {:pattern true})) + ([aggr-fn dest] + (aggregate #(update %1 dest aggr-fn %2)))) + +(defn- find-lvars [expr] + (cond + (coll? expr) + (set (mapcat find-lvars expr)) + + (lvar? expr) + (list expr) + + :else + nil)) + +(defn check-guard [guard ms] + (sequence + (comp + (map (fn [m] + (case (guard m) + true m + false nil + (update m ::guards (fnil conj []) guard)))) + (filter some?)) + ms)) + +(defmacro formula [expr & [dest]] + (let [m (gensym) + lvars (find-lvars expr)] + `(and + (with-meta + (fn [data# ms#] + (letfn [(f# [~m] + (if (every? #(contains? ~m %) ~(mapv (fn [s] `(symbol ~(name s))) lvars)) + (let [{:syms ~(vec lvars)} ~m] + (= data# ~expr)) + f#))] + (check-guard f# ms#))) + {:pattern true}) + ~@(if dest `((symbol ~(name dest))) ())))) + +(defn result-of [f & [dest]] + (let [lvars (:lvars (meta f)) + guard (with-meta + (fn [data ms] + (let [f (f data)] + (letfn [(f' [m] + (if (every? #(contains? m %) lvars) + (f m) + f'))] + (check-guard f' ms)))) + {:pattern true})] + (if dest + (and guard dest) + guard))) + +(defn matcher [P] + (let [M (pattern P)] + (with-meta + (fn f + ([data] (f data {})) + ([data preconditions] + (sequence + (comp + (remove #(not-empty (::guards %))) + (map #(dissoc % ::guards))) + (M data [preconditions])))) + {:matcher true}))) + +(defn match? + ([M data] (match? M {} data)) + ([M preconditions data] + (boolean (seq ((if (:matcher (meta M)) M (matcher M)) data preconditions))))) + +(defn matches + ([M data] (matches M {} data)) + ([M preconditions data] + ((if (:matcher (meta M)) M (matcher M)) data preconditions))) diff --git a/src/matchete/lang.cljc b/src/matchete/lang.cljc deleted file mode 100644 index 9b32d79..0000000 --- a/src/matchete/lang.cljc +++ /dev/null @@ -1,219 +0,0 @@ -(ns matchete.lang - (:require [clojure.math.combinatorics :as combo] - [clojure.string :as string]) - #?(:clj (:import (clojure.lang IFn)))) - -(defprotocol Pattern - (matches [this data] [this precondition data])) - -(defprotocol Matcher - (match? [this data] [this precondition data])) - -;; TODO delayed matchers -;; (defprotocol TmpValue -;; (-value [this])) - -;; (defprotocol Checks -;; (-checks [this]) -;; (-ok? [this preconditions value])) - -;; (defn add-check-fn -;; ([f] -;; (reify Checks -;; (-checks [_] [f]) -;; (-ok? [this preconditions value] -;; (filter #(not (% preconditions value)) (-checks this))))) -;; ([checks f] -;; (reify Checks -;; (-checks [_] (conj (-checks checks) f)) -;; (-ok? [this preconditions value] -;; (filter #(not (% preconditions value)) (-checks this)))))) - -(defn- lvar? [P] - (and (keyword? P) (some #(string/starts-with? (name P) %) ["?" "!" "_"]))) - -;; (defn binding? [P] -;; (and (keyword? P) (string/starts-with? (name P) "?"))) - -(defn pattern? [P] - (or (satisfies? Pattern P) - (lvar? P) - (and ((some-fn map? sequential? set?) P) - (some pattern? P)))) - -(declare pattern matcher) - -(defn- simple-map-pattern [P] - (let [M (reduce-kv #(assoc %1 %2 (pattern %3)) {} P)] - (reify Pattern - (matches [_ preconditions data] - (reduce-kv - (fn [ms k M] - (or (and (contains? data k) - (seq (mapcat #(matches M % (get data k)) ms))) - (reduced ()))) - (list preconditions) - M))))) - -(defn- complex-map-pattern [P] - (let [M (pattern (seq P))] - (reify Pattern - (matches [_ preconditions data] - (when (>= (count data) - (count P)) - (mapcat #(matches M preconditions %) - (filter (fn [comb] (apply distinct? (map first comb))) - (combo/selections data (count P))))))))) - -(defn- map-pattern [P] - (let [{simple-keys false complex-keys true} (group-by pattern? (keys P)) - simple-P (select-keys P simple-keys) - simple-M (simple-map-pattern simple-P) - complex-P (not-empty (select-keys P complex-keys)) - complex-M (when complex-P (complex-map-pattern complex-P))] - (reify Pattern - (matches [_ preconditions data] - (when (map? data) - (let [simple-data (select-keys data simple-keys) - complex-data (apply (partial dissoc data) simple-keys) - preconditions' (matches simple-M preconditions simple-data)] - (if (and complex-M (seq preconditions')) - (mapcat #(matches complex-M % complex-data) preconditions') - preconditions'))))))) - -(defn- set->map-pattern [prefix P] - (let [{simple false - complex true} (group-by pattern? P)] - (merge - (into {} (map (fn [v] [v v])) simple) - (into {} (map (fn [v] [(keyword (gensym prefix)) v])) complex)))) - -(defn- set-pattern [P] - (let [key-prefix (str (name (gensym "_")) "_") - M (map-pattern (set->map-pattern key-prefix P))] - (reify Pattern - (matches [_ preconditions data] - (when (set? data) - (sequence - (map #(into {} - (filter (fn [[k _]] - (not (string/starts-with? (name k) key-prefix)))) - %)) - (matches M preconditions (into {} (map (fn [v] [v v])) data)))))))) - -(defn- seq-pattern [PS] - (let [MS (mapv pattern PS)] - (reify Pattern - (matches [_ preconditions data] - (when (and (sequential? data) - (<= (count MS) (count data))) - (reduce-kv - (fn [preconditions M d] - (mapcat #(matches M % d) preconditions)) - (list preconditions) - (zipmap MS data))))))) - -(defn- binding-pattern [P] - (reify Pattern - (matches [_ preconditions data] - (if (contains? preconditions P) - (let [val (get preconditions P)] - (cond - ;; TODO descide based on TmpValue - ;; (satisfies? TmpValue val) - ;; (when (= data (-value val)) - ;; (list preconditions)) - - ;; TODO fire all the checks associated with logical var - ;; (satisfies? Checks val) - ;; (if-let [pending-checks (seq (-ok? val preconditions data))] - ;; (list (assoc preconditions P (reify - ;; Checks - ;; (-checks [_] pending-checks) - ;; (-ok? [this preconditions value] - ;; (filter #(not (% preconditions value)) (-checks this))) - ;; TmpValue - ;; (-value [_] data)))) - ;; (list (assoc preconditions P data))) - - (= data val) - (list preconditions) - - :else - ())) - (list (assoc preconditions P data)))))) - -(defn- memo-binding-pattern [P] - (reify Pattern - (matches [_ precondition data] - (list (update precondition P (fnil conj []) data))))) - -(defn- placeholder-pattern [P] - (if (> (count (name P)) 1) - (binding-pattern P) - (reify Pattern - (matches [_ precondition _data] - (list precondition))))) - -(defn- data-pattern [value] - (reify - Pattern - (matches [_ precondition data] - (when (= data value) - (list precondition))))) - -(defn- clean-matches [matches] - (reduce-kv - (fn [m k v] - (cond - (= \_ (first (name k))) - m - - ;; TODO extract value from TmpValue - ;; (satisfies? TmpValue v) - ;; (assoc m k (-value v)) - - :else - (assoc m k v))) - {} - matches)) - -(defn pattern [P] - (cond - (satisfies? Pattern P) P - - (set? P) - (set-pattern P) - - (map? P) - (map-pattern P) - - (sequential? P) - (seq-pattern P) - - (lvar? P) - (case (first (name P)) - \? (binding-pattern P) - \! (memo-binding-pattern P) - \_ (placeholder-pattern P)) - - :else (data-pattern P))) - -(defn matcher [P] - (let [P (pattern P)] - (reify - Matcher - (match? [this data] - (match? this {} data)) - (match? [this precondition data] - (boolean (seq (matches this precondition data)))) - Pattern - (matches [this data] - (matches this {} data)) - (matches [this precondition data] - (matches P precondition data)) - IFn - (#?(:clj invoke :cljs -invoke) [this data] - (this {} data)) - (#?(:clj invoke :cljs -invoke) [_ preconditions data] - (sequence (map clean-matches) (matches P preconditions data)))))) diff --git a/src/matchete/lang/core.cljc b/src/matchete/lang/core.cljc deleted file mode 100644 index c874207..0000000 --- a/src/matchete/lang/core.cljc +++ /dev/null @@ -1,164 +0,0 @@ -(ns matchete.lang.core - (:refer-clojure :exclude [every? some number? string? boolean? integer? - pos? neg? even? odd? rational? decimal? float? double? - keyword? symbol? - or and]) - (:require [matchete.lang :as ml] - [clojure.core :as cc])) - -(defn- make-pattern [p] - (reify ml/Pattern - (matches [_ preconditions data] - (when (p data) - (list preconditions))))) - -(defn and - ([P] (ml/pattern P)) - ([P & patterns] - (let [MS (mapv ml/pattern (list* P patterns))] - (reify ml/Pattern - (matches [_ precondition data] - (reduce - (fn [ms M] - (cc/or (seq (mapcat #(ml/matches M % data) ms)) - (reduced ()))) - (list precondition) - MS)))))) - -(defn or - ([P] (ml/pattern P)) - ([P & patterns] - (let [MS (mapv ml/pattern (list* P patterns))] - (reify ml/Pattern - (matches [_ precondition data] - (reduce - (fn [ms M] - (if-let [ms (seq (ml/matches M precondition data))] - (reduced ms) - ms)) - () - MS)))))) - -(defn every? - ([item-pattern] - (let [M (ml/pattern item-pattern)] - (reify ml/Pattern - (matches [_ preconditions data] - (when (sequential? data) - (reduce - (fn [ms data] - (mapcat #(ml/matches M % data) ms)) - (list preconditions) - data)))))) - ([index-pattern item-pattern] - (let [M (every? [index-pattern item-pattern])] - (reify ml/Pattern - (matches [_ preconditions data] - (when (sequential? data) - (ml/matches M preconditions (map-indexed vector data)))))))) - -(defn some - ([item-pattern] - (let [M (ml/pattern item-pattern)] - (reify ml/Pattern - (matches [_ preconditions data] - (when (sequential? data) - (reduce - (fn [ms data] - (if-let [ms' (seq (mapcat #(ml/matches M % data) ms))] - ms' ms)) - (list preconditions) - data)))))) - ([index-pattern item-pattern] - (let [M (some [index-pattern item-pattern])] - (reify ml/Pattern - (matches [_ preconditions data] - (when (sequential? data) - (ml/matches M preconditions (map-indexed vector data)))))))) - -(defn scan - ([item-pattern] - (let [M (ml/pattern item-pattern)] - (reify ml/Pattern - (matches [_ preconditions data] - (when ((some-fn sequential? map? set?) data) - (mapcat #(ml/matches M preconditions %) data)))))) - ([index-pattern item-pattern] - (let [M (ml/pattern [index-pattern item-pattern])] - (reify ml/Pattern - (matches [_ preconditions data] - (when ((some-fn sequential? map? set?) data) - (cond - (sequential? data) - (apply concat - (map-indexed - (fn [i v] - (ml/matches M preconditions [i v])) - data)) - - (map? data) - (mapcat (fn [[k v]] (ml/matches M preconditions [k v])) data) - - (set? data) - (mapcat (fn [v] (ml/matches M preconditions [v v])) data)))))))) - -(def number? (make-pattern cc/number?)) -(def string? (make-pattern cc/string?)) -(def boolean? (make-pattern cc/boolean?)) -(def integer? (make-pattern cc/integer?)) -(def pos? (make-pattern cc/pos?)) -(def neg? (make-pattern cc/neg?)) -(def even? (make-pattern cc/even?)) -(def odd? (make-pattern cc/odd?)) -(def rational? (make-pattern cc/rational?)) -(def decimal? (make-pattern cc/decimal?)) -(def float? (make-pattern cc/float?)) -(def double? (make-pattern cc/double?)) -(def keyword? (make-pattern cc/keyword?)) -(def symbol? (make-pattern cc/symbol?)) - -;; (defmulti compare-pattern #(ml/binding? %2)) - -;; (defmethod compare-pattern true [f lvar] -;; (reify ml/Pattern -;; (matches [_ p data] -;; (cond -;; (satisfies? ml/Checks (get p lvar)) -;; (list (assoc p lvar (ml/add-check-fn (get p lvar) -;; (fn [_ value] -;; (f data value))))) - -;; (contains? p lvar) -;; (when (f data (get p lvar)) (list p)) - -;; :else -;; (list (assoc p lvar (ml/add-check-fn -;; (fn [_ lvar-data] -;; (f data lvar-data))))))))) - -;; (defmethod compare-pattern false [f val] -;; (reify ml/Pattern -;; (matches [_ p data] -;; (when (f data val) -;; (list p))))) - -(defn compare-pattern [f val] - (reify ml/Pattern - (matches [_ p data] - (when (f data val) - (list p))))) - -(defn not-eq [lvar] - (compare-pattern not= lvar)) - -(defn gt [lvar] - (compare-pattern > lvar)) - -(defn gte [lvar] - (compare-pattern >= lvar)) - -(defn lt [lvar] - (compare-pattern < lvar)) - -(defn lte [lvar] - (compare-pattern <= lvar)) diff --git a/src/matchete/lang/string.cljc b/src/matchete/lang/string.cljc deleted file mode 100644 index 718eaa6..0000000 --- a/src/matchete/lang/string.cljc +++ /dev/null @@ -1,23 +0,0 @@ -(ns matchete.lang.string - (:require [clojure.string :as string] - [matchete.lang :as ml] - [matchete.lang.core :as mlcore])) - -(defn- make-pattern - ([p] (make-pattern p nil)) - ([p args] - (mlcore/and - mlcore/string? - (reify ml/Pattern - (matches [_ preconditions data] - (when (apply p (list* data args)) - (list preconditions))))))) - -(def blank? - (make-pattern string/blank?)) -(defn ends-with? [& args] - (make-pattern string/ends-with? args)) -(defn includes? [& args] - (make-pattern string/includes? args)) -(defn starts-with? [& args] - (make-pattern string/starts-with? args)) diff --git a/test/matchete/core_test.cljc b/test/matchete/core_test.cljc new file mode 100644 index 0000000..f6cd2fc --- /dev/null +++ b/test/matchete/core_test.cljc @@ -0,0 +1,31 @@ +(ns matchete.core-test + (:require [matchete.core :as mc] + [example.poker-hand :as ph] + [example.graph :as g] + #?(:clj [clojure.test :refer [deftest are is]] + :cljs [cljs.test :refer [deftest are is] :include-macros true]))) + +(deftest poker-hand + (are [hand res] (= (ph/poker-hand hand) res) + #{[:♣ 10] [:♣ 14] [:♣ 12] [:♣ 13] [:♣ 11]} "Royal flush" + + #{[:♠ 5] [:♠ 6] [:♠ 7] [:♠ 8] [:♠ 9]} "Straight flush" + + #{[:♠ 5] [:♦ 5] [:♠ 7] [:♣ 5] [:♥ 5]} "Four of a kind" + + #{[:♠ 5] [:♦ 5] [:♠ 7] [:♣ 5] [:♥ 7]} "Full house" + + #{[:♠ 5] [:♠ 6] [:♠ 7] [:♠ 13] [:♠ 9]} "Flush" + + #{[:♠ 5] [:♣ 6] [:♠ 7] [:♠ 8] [:♠ 9]} "Straight" + + #{[:♠ 5] [:♦ 5] [:♠ 7] [:♣ 5] [:♥ 8]} "Three of a kind" + + #{[:♠ 5] [:♦ 10] [:♠ 7] [:♣ 5] [:♥ 10]} "Two pair" + + #{[:♠ 5] [:♦ 10] [:♠ 7] [:♣ 5] [:♥ 8]} "One pair" + + #{[:♠ 8] [:♠ 5] [:♠ 6] [:♦ 11] [:♠ 7]} [:♦ 11])) + +(deftest graph + (is (= 46 (g/shortest-path g/city-to-city-distance "Berlin")))) diff --git a/test/matchete/lang_test.cljc b/test/matchete/lang_test.cljc deleted file mode 100644 index 6ce4c33..0000000 --- a/test/matchete/lang_test.cljc +++ /dev/null @@ -1,301 +0,0 @@ -(ns matchete.lang-test - (:require [matchete.lang :as ml] - [matchete.lang.core :as mlcore] - [matchete.lang.string :as mlstring] - [example.poker-hand :as ph] - [example.graph :as g] - #?(:clj [clojure.test :refer [deftest is are]] - :cljs [cljs.test :refer [deftest is are] :include-macros true]))) - -(deftest core-test - (is (= [{:?x :x - :?y :y - :?obj {:x :x - :y :y} - :?k 1 - :?v 1} - {:?x :x - :?y :y - :?obj {:x :x - :y :y} - :?k 4 - :?v 4}] - (ml/matches (ml/matcher [1 "qwe" :?x - {:x :?x - :collections [1 2 3 :?x]} - [1 2 3] - [1 2 3 4] - (mlcore/and :?obj {:x :?x - :y :?y}) - (mlcore/or 1 :?x) - {:?k :?v} - #{1 2 3} - :_]) - [1 "qwe" :x - {:x :x - :collections [1 2 3 :x]} - [1 2 3 4] - [1 2 3 4] - {:x :x - :y :y} - :x - {1 1 - 4 4} - #{1 2 3} - :not-bind])))) - -(deftest set-pattern - (is (= [] - (ml/matches (ml/matcher #{:?x :?y 42}) - #{1 2 3}))) - (is (= [{:?x 1, :?y 3} - {:?x 1, :?y 2} - {:?x 3, :?y 1} - {:?x 3, :?y 2} - {:?x 2, :?y 1} - {:?x 2, :?y 3}] - (ml/matches (ml/matcher #{:?x :?y 42}) - #{1 2 3 42})))) - -(deftest no-match - (is (every? empty? - [(ml/matches (ml/matcher [:?x :?x]) [1 2]) - (ml/matches (ml/matcher (mlcore/and :?x 42)) 43) - (ml/matches (ml/matcher [1 2 3]) "qwe")]))) - -(deftest placeholders - (is (= [{:_user-name "Bob", :?recipient 2} - {:_user-name "Bob", :?recipient 3}] - (ml/matches (ml/matcher {:id :_ - :name :_user-name - :messages (mlcore/scan {:author :_user-name - :dest :?recipient})}) - {:id 1 - :name "Bob" - :messages [{:author "Bob" - :dest 2} - {:author "Alise" - :dest 1} - {:author "Bob" - :dest 3}]})))) - -(deftest memo-binding - (is (= [{:!foo [1 3] - :!bar [2 4]}] - (ml/matches (ml/matcher [:!foo :!bar :!foo :!bar]) - [1 2 3 4]))) - (is (= [{:!path [:x :x] - :?node 1} - {:!path [:x :y] - :?node []} - {:!path [:x :x] - :?node 1}] - (ml/matches (ml/matcher {:foo (mlcore/scan {:!path {:!path :?node}})}) - {:foo [{:x {:x 1 :y []}} {:x {:x 1}}]})))) - -(deftest pattern? - (is (not (ml/pattern? {:foo 1 :bar 2}))) - (is (ml/pattern? (reify ml/Pattern - (matches [_ _ _])))) - (is (ml/pattern? {:?foo 1})) - (is (ml/pattern? {(mlcore/and 42 :?x) "qwe"}))) - -(deftest scan-pattern - (is (empty? (ml/matches (ml/matcher (mlcore/scan {:foo :?x})) - [{:bar 1} {:bar 2}]))) - (is (empty? (ml/matches (ml/matcher (mlcore/scan {:foo :?x})) - {:foo 1}))) - (is (= [{:?x 1}] - (ml/matches (ml/matcher (mlcore/scan {:foo :?x})) - [{:foo 1}]))) - (is (= [{:?x 1} - {:?x 2}] - (ml/matches (ml/matcher (mlcore/scan {:foo :?x})) - [{:foo 1} - {} - {:foo 2}])))) - -(deftest scan-indexed-pattern - (is (empty? (ml/matches (ml/matcher (mlcore/scan :?index :?data)) - []))) - (is (empty? (ml/matches (ml/matcher (mlcore/scan :?index :?data)) - {}))) - (is (empty? (ml/matches (ml/matcher (mlcore/scan :?index :?data)) - 42))) - (is (= [{:?index 0 - :?data 1} - {:?index 1 - :?data 2} - {:?index 2 - :?data 3}] - (ml/matches (ml/matcher (mlcore/scan :?index :?data)) - [1 2 3])))) - -(deftest each-test - (is (= [#:user{:!ids [1 2 3]}] - (ml/matches (ml/matcher {:users (mlcore/every? {:id :user/!ids})}) - {:users [{:id 1 - :name "Alise"} - {:id 2} - {:id 3 - :name "Bob"}]})))) - -(deftest each-indexed-test - (is (= [#:user{:!ids [0 1 2]}] - (ml/matches (ml/matcher {:users (mlcore/every? :user/!ids {:id :_})}) - {:users [{:id 1 - :name "Alise"} - {:id 2} - {:id 3 - :name "Bob"}]})))) - -(deftest some-test - (is (= [#:user{:!ids [1 3], :!names ["Alise" "Bob"]}] - (ml/matches (ml/matcher {:users (mlcore/some {:id :user/!ids - :name :user/!names})}) - {:users [{:id 1 - :name "Alise"} - {:id 2} - {:id 3 - :name "Bob"}]})))) - -(deftest some-indexed-test - (is (= [#:user{:!ids [0 2]}] - (ml/matches (ml/matcher {:users (mlcore/some :user/!ids {:id :_ :name :_})}) - {:users [{:id 1 - :name "Alise"} - {:id 2} - {:id 3 - :name "Bob"}]})))) - - -(deftest failed-binding - (is (not (ml/match? (ml/matcher {:x :?x :y :?x}) {:x 1 :y 2}))) - (is (not (ml/match? (ml/matcher [1 2 3]) {:x 1}))) - (is (not (ml/match? (ml/matcher {:x :?x}) {:?x 1} {:x 2})))) - -(deftest failed-conjn - (is (not (ml/match? (ml/matcher {:x :?x - :y (mlcore/and :?y :?x)}) - {:x 1 - :y 2})))) - -(deftest failed-seq - (is (not (ml/match? (ml/matcher [1 2 3]) - {:x 1})))) - -(deftest failed-map - (is (not (ml/match? (ml/matcher {:x 1 - :y 2}) - {:x 1})))) - -(deftest aggregate-rule - (letfn [(minimum [s] - (reify ml/Pattern - (matches [_ preconditions n] - (let [prev-min (get preconditions s n)] - (list (assoc preconditions s (min prev-min n)))))))] - (is (= [{:?min-n 1}] - (ml/matches (ml/matcher (repeat 3 (minimum :?min-n))) - [2 3 1 0]))))) - -(declare children) - -(defn children [] - (reify ml/Pattern - (matches [_ preconditions data] - (ml/matches (ml/matcher - (mlcore/or (mlcore/scan :!path (children)) - :?node)) - preconditions data)))) - -(deftest recursive-matcher - (is (= [{:!path [0], :?node 1} - {:!path [1 :foo 3], :?node 3} - {:!path [1 :foo 2], :?node 2} - {:!path [2], :?node 3}] - (ml/matches (ml/matcher (children)) [1 {:foo #{2 3}} 3])))) - -(deftest poker-hand - (are [hand res] (= (ph/poker-hand hand) res) - #{[:♣ 10] [:♣ 14] [:♣ 12] [:♣ 13] [:♣ 11]} "Royal flush" - - #{[:♠ 5] [:♠ 6] [:♠ 7] [:♠ 8] [:♠ 9]} "Straight flush" - - #{[:♠ 5] [:♦ 5] [:♠ 7] [:♣ 5] [:♥ 5]} "Four of a kind" - - #{[:♠ 5] [:♦ 5] [:♠ 7] [:♣ 5] [:♥ 7]} "Full house" - - #{[:♠ 5] [:♠ 6] [:♠ 7] [:♠ 13] [:♠ 9]} "Flush" - - #{[:♠ 5] [:♣ 6] [:♠ 7] [:♠ 8] [:♠ 9]} "Straight" - - #{[:♠ 5] [:♦ 5] [:♠ 7] [:♣ 5] [:♥ 8]} "Three of a kind" - - #{[:♠ 5] [:♦ 10] [:♠ 7] [:♣ 5] [:♥ 10]} "Two pair" - - #{[:♠ 5] [:♦ 10] [:♠ 7] [:♣ 5] [:♥ 8]} "One pair" - - #{[:♠ 8] [:♠ 5] [:♠ 6] [:♦ 11] [:♠ 7]} [:♦ 11])) - -(deftest graph - (is (= 46 (g/shortest-path g/city-to-city-distance "Berlin")))) - -(deftest matcher-as-a-function - (let [M (ml/matcher {:id :_id - :messages (mlcore/scan {:author :_id - :message :?msg})})] - (is (= [{:?msg "ping"} - {:?msg "whoohu!"}] - (M {:id 1 - :messages [{:author 1 - :message "ping"} - {:author 2 - :message "pong"} - {:author 1 - :message "whoohu!"}]}))))) - -(deftest and-or - (is (= [{}] ((ml/matcher (mlcore/and 42)) 42))) - (is (= [{}] ((ml/matcher (mlcore/or 42)) 42)))) - -(deftest core-predicates - (is (ml/match? (ml/matcher (mlcore/not-eq 2)) 3)) - (is (not (ml/match? (ml/matcher (mlcore/not-eq 2)) 2))) - - (is (ml/match? (ml/matcher (mlcore/gt 2)) 3)) - (is (not (ml/match? (ml/matcher (mlcore/gt 2)) 1))) - - (is (ml/match? (ml/matcher (mlcore/gte 2)) 2)) - (is (ml/match? (ml/matcher (mlcore/gte 2)) 3)) - (is (not (ml/match? (ml/matcher (mlcore/gte 2)) 1))) - - (is (ml/match? (ml/matcher (mlcore/lt 2)) 1)) - (is (not (ml/match? (ml/matcher (mlcore/lt 2)) 3))) - - (is (ml/match? (ml/matcher (mlcore/lte 2)) 2)) - (is (ml/match? (ml/matcher (mlcore/lte 2)) 1)) - (is (not (ml/match? (ml/matcher (mlcore/lte 2)) 3))) - - (are [x y] (ml/match? (ml/matcher x) y) - mlcore/number? 42.0 - mlcore/string? "42" - mlcore/boolean? false - mlcore/integer? 42 - mlcore/pos? 42 - mlcore/neg? -42 - mlcore/even? 42 - mlcore/odd? 43 - #?@(:clj [mlcore/rational? 5/3 - mlcore/decimal? 42M]) - mlcore/float? 42.0 - mlcore/double? 42.0 - mlcore/keyword? :x42 - mlcore/symbol? 'x42)) - -(deftest string-predicates - (are [x y] (ml/match? (ml/matcher x) y) - mlstring/blank? "" - (mlstring/ends-with? "!") "qwe!" - (mlstring/includes? "we") "qwe!" - (mlstring/starts-with? "q") "qwe!")) From dbbbb325400ae2f5d44b8f09cb4e2ff295431c13 Mon Sep 17 00:00:00 2001 From: Kirill Chernyshov Date: Fri, 19 Jun 2020 13:54:20 +0200 Subject: [PATCH 05/15] WIP --- .clj-kondo/config.edn | 6 ++ dev/example/graph.cljc | 2 +- dev/example/poker_hand.cljc | 10 +-- src/matchete/core.cljc | 54 +++++++++---- test/matchete/core_test.cljc | 142 ++++++++++++++++++++++++++++++++++- 5 files changed, 192 insertions(+), 22 deletions(-) create mode 100644 .clj-kondo/config.edn diff --git a/.clj-kondo/config.edn b/.clj-kondo/config.edn new file mode 100644 index 0000000..b6b97f7 --- /dev/null +++ b/.clj-kondo/config.edn @@ -0,0 +1,6 @@ +{:lint-as + {matchete.core/defnpattern clojure.core/defn + matchete.core/defpattern clojure.core/def} + :linters + {:unresolved-symbol + {:exclude [(matchete.core/formula)]}}} diff --git a/dev/example/graph.cljc b/dev/example/graph.cljc index 5a133a5..48cb844 100644 --- a/dev/example/graph.cljc +++ b/dev/example/graph.cljc @@ -16,7 +16,7 @@ (into #{} (map (fn [[n1 n2]] [(symbol (str "?" n1)) - #{[(symbol (str "?" n2)) (ml/aggregate add-distance '?distance)]}])) + #{[(symbol (str "?" n2)) (ml/aggregate-by add-distance '?distance)]}])) (take cities-count (map vector (cycle l) (rest (cycle l))))))) (defn shortest-path diff --git a/dev/example/poker_hand.cljc b/dev/example/poker_hand.cljc index 0687d74..ca30227 100644 --- a/dev/example/poker_hand.cljc +++ b/dev/example/poker_hand.cljc @@ -82,11 +82,11 @@ (if (> new-rank (or old-rank 0)) new-card old-card)) - p (hand-pattern [(ml/aggregate aggr-fn :high-card) - (ml/aggregate aggr-fn :high-card) - (ml/aggregate aggr-fn :high-card) - (ml/aggregate aggr-fn :high-card) - (ml/aggregate aggr-fn :high-card)])] + p (hand-pattern [(ml/aggregate-by aggr-fn :high-card) + (ml/aggregate-by aggr-fn :high-card) + (ml/aggregate-by aggr-fn :high-card) + (ml/aggregate-by aggr-fn :high-card) + (ml/aggregate-by aggr-fn :high-card)])] (defn high-card [hand] (:high-card (first (ml/matches p hand))))) diff --git a/src/matchete/core.cljc b/src/matchete/core.cljc index a9b0612..ee340ff 100644 --- a/src/matchete/core.cljc +++ b/src/matchete/core.cljc @@ -67,11 +67,13 @@ {:pattern true}))) (defn- complex-set-pattern [P] - (let [M (pattern (seq P))] - (fn [data ms] - (mapcat #(M % ms) - (filter #(apply distinct? %) - (combo/selections data (count P))))))) + (if (empty? P) + (fn [_data ms] ms) + (let [M (pattern (seq P))] + (fn [data ms] + (mapcat #(M % ms) + (filter #(apply distinct? %) + (combo/selections data (count P)))))))) (defn- set-pattern [P] (let [{scalar-items false variable-items true} (group-by pattern? P) @@ -153,6 +155,8 @@ :else (data-pattern P))) +(def memoized-pattern (memoize pattern)) + (defn scan ([P] (let [M (pattern P)] @@ -241,7 +245,7 @@ ms))) {:pattern true}))) -(defn aggregate +(defn aggregate-by ([aggr-fn] (with-meta (fn [data ms] @@ -252,7 +256,7 @@ ms)) {:pattern true})) ([aggr-fn dest] - (aggregate #(update %1 dest aggr-fn %2)))) + (aggregate-by #(update %1 dest aggr-fn %2)))) (defn- find-lvars [expr] (cond @@ -284,23 +288,40 @@ (fn [data# ms#] (letfn [(f# [~m] (if (every? #(contains? ~m %) ~(mapv (fn [s] `(symbol ~(name s))) lvars)) - (let [{:syms ~(vec lvars)} ~m] + (let [{:syms ~(vec lvars) :as x#} ~m] (= data# ~expr)) f#))] (check-guard f# ms#))) {:pattern true}) ~@(if dest `((symbol ~(name dest))) ())))) +(defmacro defpattern [name P] + `(def ~name + (with-meta + (fn [data# ms#] + ((memoized-pattern ~P) data# ms#)) + {:pattern true}))) + +(defmacro defnpattern [name args P] + `(def ~name + (with-meta + (fn [data# ms#] + (sequence + (mapcat (fn [m#] + (let [P# (memoized-pattern ((fn ~args ~P) m#))] + (P# data# [m#])))) + ms#)) + {:pattern true}))) + (defn result-of [f & [dest]] (let [lvars (:lvars (meta f)) guard (with-meta (fn [data ms] - (let [f (f data)] - (letfn [(f' [m] - (if (every? #(contains? m %) lvars) - (f m) - f'))] - (check-guard f' ms)))) + (letfn [(f' [m] + (if (every? #(contains? m %) lvars) + (= data (f m)) + f'))] + (check-guard f' ms))) {:pattern true})] (if dest (and guard dest) @@ -327,4 +348,7 @@ (defn matches ([M data] (matches M {} data)) ([M preconditions data] - ((if (:matcher (meta M)) M (matcher M)) data preconditions))) + (sequence + (map (fn [m] + (into {} (remove #(placeholder? (first %))) m))) + ((if (:matcher (meta M)) M (matcher M)) data preconditions)))) diff --git a/test/matchete/core_test.cljc b/test/matchete/core_test.cljc index f6cd2fc..402c138 100644 --- a/test/matchete/core_test.cljc +++ b/test/matchete/core_test.cljc @@ -1,5 +1,5 @@ (ns matchete.core-test - (:require [matchete.core :as mc] + (:require [matchete.core :as mc :include-macros true] [example.poker-hand :as ph] [example.graph :as g] #?(:clj [clojure.test :refer [deftest are is]] @@ -29,3 +29,143 @@ (deftest graph (is (= 46 (g/shortest-path g/city-to-city-distance "Berlin")))) + +(deftest map-pattern + (is (= [{}] + ((mc/matcher {:a "a" + :b "b"}) + {:a "a" + :b "b" + :c "c"}))) + (is (not (mc/match? {:a '?a + :b '?a} + {:a "a" + :b "b"}))) + (is (not (mc/match? {:a "a"} "string"))) + (is (not (mc/match? {:a "a" :b "b"} {:a "a" :c "c"}))) + (is (not (mc/match? {:a "a" :b "b"} {:a "a"}))) + (is (= '[{?b "this-is-b", ?c :c} + {?b "this-is-b", ?c :d} + {?b "this-is-b", ?c :e}] + ((mc/matcher {:a 42 + :b '?b + '?c 42 + (mc/formula (keyword ?b)) 24 + {:x (mc/predicate string?)} true}) + {:a 42 + :b "this-is-b" + :c 42 + :d 42 + :this-is-b 24 + :e 42 + {:x "qwe"} true + {:x 42} true})))) + +(deftest set-pattern + (is (= [{}] + ((mc/matcher #{1 2 3}) #{1 2 3 4 5}))) + (is (not (mc/match? #{1 2 3} #{1 2}))) + (is (not (mc/match? #{1 2 3} "string"))) + (is (not (mc/match? #{1 2 3} #{1 3 4}))) + (is (= '#{{?x 1} + {?x 2} + {?x 3}} + (set ((mc/matcher #{'?x}) #{1 2 3}))))) + +(deftest placeholder-pattern + (is (= [{}] + (mc/matches '[?_ ?_ ?_a ?_a] ["ignore" "another-ignore" 1 1]))) + (is (= '[{?_a 1}] + ((mc/matcher '[?_ ?_ ?_a ?_a]) ["ignore" "another-ignore" 1 1])))) + +(deftest formula-pattern + (is (= [] + ((mc/matcher [(mc/formula (+ ?x 20)) '?x]) [42 23]))) + (is (= [{'?x 22 '?y 42}] + ((mc/matcher [(mc/formula (+ ?x 20) ?y) '?x]) [42 22]))) + (is (= [{'?x 22 '?y 1}] + ((mc/matcher [(mc/formula (+ ?x 20)) (mc/formula (* ?y ?x 10)) '?x '?y]) [42 220 22 1])))) + +(deftest result-of-pattern + (let [inc-x (with-meta + (fn [{:syms [?x]}] + (inc ?x)) + {:lvars ['?x]}) + sum-x-y (with-meta + (fn [{:syms [?x ?y]}] + (+ ?x ?y)) + {:lvars ['?x '?y]})] + (is (= [{'?x 1 '?y 2}] + (mc/matches ['?x (mc/result-of inc-x '?y)] [1 2]))) + (is (= [{'?x 1 '?y 2}] + (mc/matches ['?x (mc/result-of sum-x-y) '?y] + [1 3 2]))) + (is (not (mc/match? [(mc/result-of sum-x-y) '?y] + [3 2]))))) + +(deftest lvar-pattern + (is (not (mc/match? ['?x '?x] [1 2])))) + +(defn conj-path [path step] + ((fnil conj []) path step)) + +(mc/defpattern tree-walk + (mc/or (mc/scan (mc/aggregate-by conj-path '?path) + tree-walk) + '?leaf)) + +(mc/defnpattern limited-tree-walk [{:syms [?path]}] + (if (< (count ?path) 3) + (mc/or (mc/scan [(mc/aggregate-by conj-path '?path) limited-tree-walk]) + '?leaf) + '?leaf)) + +(deftest recursive-pattern + (is (= '[{?path [:x 0], ?leaf 1} + {?path [:x 1], ?leaf 2} + {?path [:x 2 :y], ?leaf "qwe"} + {?path [:z], ?leaf 42}] + (mc/matches tree-walk {:x [1 2 {:y "qwe"}] + :z 42}))) + (is (= '[{?path [:x :x :x], ?leaf {:x 1}} + {?path [:y], ?leaf 42}] + (mc/matches limited-tree-walk {:x {:x {:x {:x 1}}} + :y 42})))) + +(deftest each-pattern + (is (not (mc/match? (mc/each 42) [42 3 42]))) + (is (mc/match? (mc/each 42) [42 42 42]))) + +(deftest some-pattern + (is (mc/match? (mc/some 42) [42 3 42]))) + +(deftest predicate-pattern + (is (mc/match? (mc/matcher (mc/each (mc/predicate string?))) ["qwe" "rty" "uio"])) + (is (not (mc/match? (mc/each (mc/predicate string?)) ["qwe" 'rty "uio"]))) + (is (= [{'?string "qwe"}] + (mc/matches (mc/matcher {:string (mc/predicate string? '?string) + :number (mc/predicate number?)}) + {:string "qwe" + :number 42 + :boolean true})))) + +(deftest and-pattern + (is (not (mc/match? ['?x (mc/and 42 '?x)] [43 42]))) + (is (= [{'?x true}] (mc/matches (mc/and true '?x) true)))) + +(deftest or-pattern + (is (mc/match? (mc/or 42) 42)) + (is (not (mc/match? (mc/or (mc/predicate string?) (mc/predicate number?)) nil)))) + +(deftest not-pattern + (is (mc/match? (mc/not (mc/predicate string?)) 42)) + (is (not (mc/match? (mc/not (mc/predicate string?)) "42")))) + +(comment + + (mc/matches (mc/and (mc/scan (mc/formula (Math/sqrt (+ (Math/pow ?x 2) (Math/pow ?y 2))) ?z)) + (mc/scan '?x) + (mc/scan '?y)) + (map double (range 1 50))) + + ) From da059381578ff8c771da8c4e012c5b46997be2a5 Mon Sep 17 00:00:00 2001 From: Kirill Chernyshov Date: Fri, 19 Jun 2020 14:06:10 +0200 Subject: [PATCH 06/15] WIP --- dev/user.cljc | 141 -------------------------------------------------- 1 file changed, 141 deletions(-) delete mode 100644 dev/user.cljc diff --git a/dev/user.cljc b/dev/user.cljc deleted file mode 100644 index aec238f..0000000 --- a/dev/user.cljc +++ /dev/null @@ -1,141 +0,0 @@ -(ns user - (:require [meander.epsilon :as m] - [matchete.lang :as ml] - [matchete.lang.core :as mlcore] - [matchete.core :as ml2] - [criterium.core :refer [quick-bench]])) - -(defmacro predicates->pattern-defns [& preds] - `(do ~@(for [p preds] - `(defn ~(symbol (name p)) [& args#] - (make-pattern ~p args#))))) - -(defmacro predicates->pattern-defs [& preds] - `(do ~@(for [p preds] - `(def ~(symbol (name p)) - (make-pattern ~p))))) - -(defn favorite-food-info [foods-by-name user] - (m/match {:user user - :foods-by-name foods-by-name} - {:foods-by-name {?food {:popularity ?popularity - :calories ?calories}} - :user - {:name ?name - :favorite-food {:name ?food}} - } - {:name ?name - :favorite {:food ?food - :popularity ?popularity - :calories ?calories}})) - -(defn favorite-foods-info [foods-by-name user] - (m/search {:user user - :foods-by-name foods-by-name} - {:user - {:name ?name - :favorite-foods (m/scan {:name ?food})} - :foods-by-name {?food {:popularity ?popularity - :calories ?calories}}} - {:name ?name - :favorite {:food ?food - :popularity ?popularity - :calories ?calories}})) - -(def foods-by-name - {:nachos {:popularity :high - :calories :lots} - :smoothie {:popularity :high - :calories :less}}) - -;; (time -;; (dotimes [_ 1000] -;; (favorite-food-info foods-by-name -;; {:name :alice -;; :favorite-food {:name :nachos}}))) - -;; (time -;; (dotimes [_ 1000] -;; (favorite-foods-info foods-by-name -;; {:name :alice -;; :favorite-foods [{:name :nachos} -;; {:name :smoothie}]}))) - -;; (let [M (ml/matcher '{:user {:name ?name -;; :favorite-food {:name ?food}} -;; :foods-by-name {?food {:popularity ?popularity -;; :calories ?calories}}})] -;; (time -;; (dotimes [_ 1000] -;; (M {:user {:name :alice -;; :favorite-food {:name :nachos}} -;; :foods-by-name foods-by-name})))) - -;; (let [M (ml/matcher {:user {:name :?name -;; :favorite-foods (mlcore/scan {:name :?food})} -;; :foods-by-name {:?food {:popularity :?popularity -;; :calories :?calories}}})] -;; (M {:user {:name :alice -;; :favorite-foods [{:name :nachos} -;; {:name :smoothie}]} -;; :foods-by-name foods-by-name}) -;; (time -;; (dotimes [_ 1000] -;; (M {:user {:name :alice -;; :favorite-foods [{:name :nachos} -;; {:name :smoothie}]} -;; :foods-by-name foods-by-name})))) - -;; (m/match {:foo [1 2 3 4]} -;; {:foo [42 '?x '?y]} -;; {:x '?x :y '?y}) - -(let [M2 (ml2/matcher {:user {:name '?name - :favorite-foods (ml2/scan {:name '?food})} - :foods-by-name {'?food {:popularity '?popularity - :calories '?calories}}}) - M1 (ml/matcher {:user {:name '?name - :favorite-foods (mlcore/scan {:name '?food})} - :foods-by-name {'?food {:popularity '?popularity - :calories '?calories}}})] - (prn "---DBG matchete1" (M1 {:user {:name :alice - :favorite-foods [{:name :nachos} - {:name :smoothie}]} - :foods-by-name foods-by-name})) - (prn "---DBG matchete2" (M2 {:user {:name :alice - :favorite-foods [{:name :nachos} - {:name :smoothie}]} - :foods-by-name foods-by-name})) - (prn "---DBG meander" (favorite-foods-info foods-by-name - {:name :alice - :favorite-foods [{:name :nachos} - {:name :smoothie}]})) - (quick-bench (doall (M1 {:user {:name :alice - :favorite-foods [{:name :nachos} - {:name :smoothie}]} - :foods-by-name foods-by-name}))) - (quick-bench (doall (M2 {:user {:name :alice - :favorite-foods [{:name :nachos} - {:name :smoothie}]} - :foods-by-name foods-by-name}))) - (quick-bench (doall (favorite-foods-info foods-by-name - {:name :alice - :favorite-foods [{:name :nachos} - {:name :smoothie}]})))) - -(let [M (ml2/matcher '{:user {:name ?name - :favorite-food {:name ?food}} - :foods-by-name {?food {:popularity ?popularity - :calories ?calories}}})] - (prn "---DBG matchete" (M {:user {:name :alice - :favorite-food {:name :nachos}} - :foods-by-name foods-by-name})) - (prn "---DBG meander" (favorite-food-info foods-by-name - {:name :alice - :favorite-food {:name :nachos}})) - (quick-bench (doall (M {:user {:name :alice - :favorite-food {:name :nachos}} - :foods-by-name foods-by-name}))) - (quick-bench (doall (favorite-food-info foods-by-name - {:name :alice - :favorite-food {:name :nachos}})))) From c55f9daf6a4a24e109cadf8c6d7fc4d12a284755 Mon Sep 17 00:00:00 2001 From: Kirill Chernyshov Date: Fri, 19 Jun 2020 18:37:29 +0200 Subject: [PATCH 07/15] WIP --- src/matchete/core.cljc | 45 +++++++++++++++--------------------- test/matchete/core_test.cljc | 5 ++-- 2 files changed, 20 insertions(+), 30 deletions(-) diff --git a/src/matchete/core.cljc b/src/matchete/core.cljc index ee340ff..387bb9f 100644 --- a/src/matchete/core.cljc +++ b/src/matchete/core.cljc @@ -1,8 +1,8 @@ (ns matchete.core (:refer-clojure :rename {some core-some and core-and - or core-or - not core-not}) + or core-or} + :exclude [not]) (:require [clojure.math.combinatorics :as combo] [clojure.set :as set])) @@ -91,31 +91,22 @@ (defn- lvar-pattern [P] (with-meta (fn [data ms] - (reduce - (fn [ms m] - (cond - (core-and (contains? m P) - (not= data (get m P))) - ms - - (core-not (contains? m P)) - (let [{::keys [guards] :as m} (assoc m P data)] - (if-let [m (if (not-empty guards) - (reduce - (fn [m guard] - (case (guard m) - true m - false (reduced nil) - (update m ::guards conj guard))) - (assoc m ::guards []) - guards) - m)] - (conj ms m) - ms)) - - (= data (get m P)) - (conj ms m))) - () + (sequence + (comp + (remove #(core-and (contains? % P) (not= data (get % P)))) + (map (fn [m] + (core-or (core-and (contains? m P) m) + (let [{::keys [guards] :as m} (assoc m P data)] + (core-or (core-and (empty? guards) m) + (reduce + (fn [m guard] + (case (guard m) + true m + false (reduced nil) + (update m ::guards conj guard))) + (assoc m ::guards []) + guards)))))) + (filter some?)) ms)) {:pattern true})) diff --git a/test/matchete/core_test.cljc b/test/matchete/core_test.cljc index 402c138..96b5563 100644 --- a/test/matchete/core_test.cljc +++ b/test/matchete/core_test.cljc @@ -6,7 +6,7 @@ :cljs [cljs.test :refer [deftest are is] :include-macros true]))) (deftest poker-hand - (are [hand res] (= (ph/poker-hand hand) res) + (are [hand res] (= res (ph/poker-hand hand)) #{[:♣ 10] [:♣ 14] [:♣ 12] [:♣ 13] [:♣ 11]} "Royal flush" #{[:♠ 5] [:♠ 6] [:♠ 7] [:♠ 8] [:♠ 9]} "Straight flush" @@ -110,8 +110,7 @@ ((fnil conj []) path step)) (mc/defpattern tree-walk - (mc/or (mc/scan (mc/aggregate-by conj-path '?path) - tree-walk) + (mc/or (mc/scan (mc/aggregate-by conj-path '?path) tree-walk) '?leaf)) (mc/defnpattern limited-tree-walk [{:syms [?path]}] From 8a1f493aad865b268675d04c461d3a7f74324414 Mon Sep 17 00:00:00 2001 From: Kirill Chernyshov Date: Mon, 22 Jun 2020 10:02:56 +0200 Subject: [PATCH 08/15] Add lif operator (lif cond-pattern then-pattern else-pattern) else-pattern is optional "IF data matches with cond-pattern (result of match is not empty) THEN use result as a preconditions for match then-pattern against the same data ELSE match the data against else-pattern if present." --- src/matchete/core.cljc | 15 +++++++++++++++ test/matchete/core_test.cljc | 10 ++++++++++ 2 files changed, 25 insertions(+) diff --git a/src/matchete/core.cljc b/src/matchete/core.cljc index 387bb9f..d54089b 100644 --- a/src/matchete/core.cljc +++ b/src/matchete/core.cljc @@ -221,6 +221,21 @@ ms)) {:pattern true}))) +(defn lif + ([cond-pattern then-pattern] + (lif cond-pattern then-pattern ::empty)) + ([cond-pattern then-pattern else-pattern] + (let [cond-m (pattern cond-pattern) + then-m (pattern then-pattern) + else-m (when (not= ::empty else-pattern) + (pattern else-pattern))] + (with-meta + (fn [data ms] + (if-let [ms' (seq (cond-m data ms))] + (then-m data ms') + (when else-m (else-m data ms)))) + {:pattern true})))) + (defn predicate ([pred] (predicate pred nil)) diff --git a/test/matchete/core_test.cljc b/test/matchete/core_test.cljc index 96b5563..6078d3a 100644 --- a/test/matchete/core_test.cljc +++ b/test/matchete/core_test.cljc @@ -160,6 +160,16 @@ (is (mc/match? (mc/not (mc/predicate string?)) 42)) (is (not (mc/match? (mc/not (mc/predicate string?)) "42")))) +(deftest if-pattern + (let [M (mc/lif (mc/predicate string?) '?this-is-a-string (mc/lif (mc/predicate number?) '?this-is-a-number '?i-dont-know-what-it-is))] + (is (= ['{?this-is-a-string "string"}] + (mc/matches M "string"))) + (is (= ['{?this-is-a-number 42}] + (mc/matches M 42))) + (is (= ['{?i-dont-know-what-it-is true}] + (mc/matches M true)))) + (is (not (mc/match? (mc/lif 42 '?forty-two) 43)))) + (comment (mc/matches (mc/and (mc/scan (mc/formula (Math/sqrt (+ (Math/pow ?x 2) (Math/pow ?y 2))) ?z)) From 59b3408d4142c6228b3e3bd00596e133b9b3ca0f Mon Sep 17 00:00:00 2001 From: Kirill Chernyshov Date: Mon, 22 Jun 2020 15:28:11 +0200 Subject: [PATCH 09/15] Add reshape-by pattern takes a function of one argument and pattern. Before match agains some data will apply this tr-fn function to the data before applying pattern. ``` (matches (reshape-by (juxt ex-message ex-data) ['?msg {:type :input-error}]) (ex-info "Message" {:type :input-error})) ;; => '({?msg "Message}) ``` --- src/matchete/core.cljc | 46 +++++++++++++++++++++++++----------- test/matchete/core_test.cljc | 13 +++++++++- 2 files changed, 44 insertions(+), 15 deletions(-) diff --git a/src/matchete/core.cljc b/src/matchete/core.cljc index d54089b..c30b1a3 100644 --- a/src/matchete/core.cljc +++ b/src/matchete/core.cljc @@ -168,22 +168,33 @@ (apply concat (map-indexed #(M [%1 %2] ms) data)))) {:pattern true})))) -(defn each - ([P] (each P false)) - ([P skip-fail?] - (let [M (pattern P)] - (with-meta - (fn [data ms] - (when (sequential? data) - (reduce - (fn [ms item] - (core-or (seq (M item ms)) (if skip-fail? ms (reduced ())))) - ms - data))) - {:pattern true})))) +(defn each [P] + (let [M (pattern P)] + (with-meta + (fn [data ms] + (when (sequential? data) + (reduce + (fn [ms item] + (core-or (seq (M item ms)) (reduced ()))) + ms + data))) + {:pattern true}))) (defn some [P] - (each P true)) + (let [M (pattern P)] + (with-meta + (fn [data ms] + (when (sequential? data) + (let [[found-one? ms] + (reduce + (fn [[found-one? ms] item] + (if-let [ms' (seq (M item ms))] + [true ms'] + [found-one? ms])) + [false ms] + data)] + (if found-one? ms ())))) + {:pattern true}))) (defn and ([P] (pattern P)) @@ -264,6 +275,13 @@ ([aggr-fn dest] (aggregate-by #(update %1 dest aggr-fn %2)))) +(defn reshape-by [tr-fn P] + (let [M (pattern P)] + (with-meta + (fn [data ms] + (M (tr-fn data) ms)) + {:pattern true}))) + (defn- find-lvars [expr] (cond (coll? expr) diff --git a/test/matchete/core_test.cljc b/test/matchete/core_test.cljc index 6078d3a..6563a66 100644 --- a/test/matchete/core_test.cljc +++ b/test/matchete/core_test.cljc @@ -3,7 +3,8 @@ [example.poker-hand :as ph] [example.graph :as g] #?(:clj [clojure.test :refer [deftest are is]] - :cljs [cljs.test :refer [deftest are is] :include-macros true]))) + :cljs [cljs.test :refer [deftest are is] :include-macros true])) + #?(:clj (:import (clojure.lang ExceptionInfo)))) (deftest poker-hand (are [hand res] (= res (ph/poker-hand hand)) @@ -131,6 +132,16 @@ (mc/matches limited-tree-walk {:x {:x {:x {:x 1}}} :y 42})))) +(deftest reshape-test + (is (= '[{?ex-message "message 1"} + {?ex-message "message 3"}] + (mc/matches (mc/scan (mc/and (mc/predicate #(instance? ExceptionInfo %)) + (mc/reshape-by (juxt ex-message ex-data) + ['?ex-message {:type :A}]))) + [(ex-info "message 1" {:type :A}) + (ex-info "message 2" {:type :B}) + (ex-info "message 3" {:type :A})])))) + (deftest each-pattern (is (not (mc/match? (mc/each 42) [42 3 42]))) (is (mc/match? (mc/each 42) [42 42 42]))) From d10265a5a5386a94fcdd232841c63dfe7469e557 Mon Sep 17 00:00:00 2001 From: Kirill Chernyshov Date: Mon, 22 Jun 2020 15:53:43 +0200 Subject: [PATCH 10/15] Allow extract from tail in seq-pattern Same as clojure.core/destructure ``` [?x ?y & [?x ?y ?z]] [1 2 1 2 3] ;; => {?x 1 ?y 2 ?z 3} ``` --- README.md | 238 ----------------------------------- src/matchete/core.cljc | 10 +- test/matchete/core_test.cljc | 15 ++- 3 files changed, 21 insertions(+), 242 deletions(-) diff --git a/README.md b/README.md index 4a9a8e8..d1afa1b 100644 --- a/README.md +++ b/README.md @@ -1,239 +1 @@ # matchete [![cljdoc badge](https://cljdoc.org/badge/io.xapix/matchete)](https://cljdoc.org/d/io.xapix/matchete/CURRENT) ![Check code style using clj-kondo](https://github.com/xapix-io/matchete/workflows/Check%20code%20style%20using%20clj-kondo/badge.svg?branch=master) ![Run tests for all environments](https://github.com/xapix-io/matchete/workflows/Run%20tests%20for%20all%20environments/badge.svg?branch=master) - -Yet another pattern matching library for Clojure(Script). - -## Using - -
leiningen -

- -``` -[io.xapix/matchete "1.1.0"] -``` - -

-
- -
boot -

- -``` -(set-env! :dependencies #(conj % [io.xapix/matchete "1.1.0"])) -``` - -

-
- -
deps.edn -

- -``` -{:deps {io.xapix/matchete {:mvn/version "1.1.0"}}} -``` - -

-
- -```clojure -(require '[matchete.core :as m]) - -;; `match?` function returns true or false to indicate if the data matches the pattern -(m/match? '{:foo ?foo} {:foo 1}) ;; => true -(m/match? '{:bar ?bar} {:foo 1}) ;; => false - -;; `matches` function returns lazy sequence with collected bindings -;; empty seq indicates not matched data -(m/matches '{:foo ?foo} {:foo 1}) ;; => '({?foo 1}) -(m/matches '{:bar ?bar} {:foo 1}) ;; => '() - -;; `matcher` function precompiles pattern into a function -(let [matcher (m/matcher '{:foo ?foo})] - (matcher {:foo 1})) ;; => '({?foo 1}) -``` - -## Match data using data as a pattern - -```clojure -(m/match? 42 42) ;; => true -(m/match? "42" "24") ;; => false - -;; sequences -(m/match? [1 2 3] [1 2 3]) ;; => true -(m/match? '(1 2 3) [1 2 3]) ;; => true - -(m/match? [1 2 3] [1 2 3 4]) ;; => false because pattern expects exactly 3 elements - -;; to override this behaviour tail destructuring pattern can be used -(m/match? [1 2 3 & _] [1 2 3 4]) ;; => true, `_` is a placeholder here that will match to any provided data - -;; hash-maps -(m/match? {:id 123 :name "Alise"} {:id 123 :name "Alise" :lastname "Cooper"}) ;; => true -(m/match? {:id 123 :name "Alise"} {:id 123 :lastname "Cooper"}) ;; => false because `:name` key is missing -``` - -## Extract data - -There are three types of special symbols that can be used in a pattern: - -* data bindings - symbols starts with '?' -* memo bindings - symbols starts with '!' -* named rule - symbols starts with '$' - -### Data Binding - -```clojure -(m/matches '?user {:id 1 :name "Bob"}) ;; => '({?user {:id 1 :name "Bob"}}) -(m/matches '{:id ?user-id :name ?user-name} - {:id 1 :name "Bob"}) ;; => '({?user-id 1 ?user-name "Bob"}) - -(m/matches '[1 ?two 3 & [?four & _]] - [1 2 3 4 5 6]) ;; => '({?two 2 ?four 4}) - -(m/matches '{:vector [_ {:id ?id}]} - {:vector [{:id 1} {:id 2}]}) ;; => '({?id 2}) -``` - -data bindings can be used as a hash-map keys - -```clojure -(m/matches '{?key ?value} - {:foo "foo" - :bar "bar"}) ;; => '({?key :foo ?value "foo"} {?key :bar ?value "bar"}) - -(m/matches '{?x "foo" - ?y "bar"} - {:key-1 "foo" - :key-2 "foo" - :key-3 "bar"}) ;; => '({?x :key-1 ?y :key-3} {?x :key-2 ?y :key-3}) -``` - -### Memo Binding - -Collect data into a vector. Order of appearence is not guaranteed. - -```clojure -(m/matches '[{:id !ids} {:id !ids} {:id !ids}] - [{:id 1} {:id 2} {:id 3}]) ;; => '({!ids [1 2 3]}) -``` - -## Control sequences - -### `not!` predicate - -``` -(m/matches '{:id (cat (not! 10) ?id) - :name ?name} - {:id 42 - :name "Alise"} ;; => '({?id 42 ?name "Alise"}) - ;; {:id 10 - ;; :name "Bob"} ;; => '() - ) -``` - -### `cat` combinator - -Each pattern will be applied to the same data combine data bindings into one result. Patterns can extend the result or add more sofisticated restrictions. - -```clojure -(m/matches '(cat {:id ?id :name ?name} ?user) - {:id 1 - :name "Alise" - :lastname "Cooper"}) ;; => '({?id 1 ?name "Alise" ?user {:id 1 :name "Alise" :lastname "Cooper"}}) -``` - -### `alt` combinator - -Patterns combined by `alt` will be applied to the same data as long as one of them will match and the matches from that pattern will be the result of matching. - -```clojure -(m/matches '(alt {:id ?id} {"id" ?id} {:userId ?id}) - {:id 1} ;; => '({?id 1}) - ;; {"id" 2} ;; => '({?id 2}) - ;; {:userId 3} ;; => '({?id 3}) - ) -``` - -### `each` - -#### `(each P)` - -Sequentialy match elements of collection in order. Fail if any of elements can not match. - -```clojure -(m/matches '(every (and %string? !elements)) - ["qwe" "rty" "uio"]) ;; => '({!elements ["qwe" "rty" "uio"]}) - -(m/matches '(every (and %string? !elements)) - ["qwe" 42 "uio"]) ;; => '() -``` - -#### `(each index-P value-P)` - -2-arity version of `each` where first pattern will match against an index and second - match against value associated with that index. - -### `scan` - -#### `(scan P)` - -Expects one pattern wich will be applied to each item of sequence or hash-map (item will be in the form of tuple: [key, value]). - -```clojure -(m/matches '{:foo (scan [?id ?name])} - {:foo [[1 "Alise"] [::empty] [3 "Bob"]]}) ;; => '({?id 1 ?name "Alise"} {?id 3 ?name "Bob"})' -``` - -#### `(scan index-P value-P)` - -Expects two patterns: - - 1. index matcher (index in sequences and key in hash-maps) - 1. value matcher - -```clojure -(m/matches '(scan !path (scan !path (scan !path ?node))) - [{:id 1 - :user {:name "Alise" - :role :admin} - :actions [{:type :login}]}]) -;; => '({!path [0 :user :name] ?node "Alise"} -;; {!path [0 :user :role] ?node :admin} -;; {!path [0 :actions 0] ?node {:type :login}}) -``` - -### Named rule - -```clojure -(m/matches '(def-rule $children (scan !path (alt $children ?leaf))) - [{:id 1 - :user {:name "Alise" - :role :admin} - :actions [{:type :login}]}]) -;; => '({!path [0 :id] ?leaf 1} -;; {!path [0 :user :name] ?leaf "Alise"} -;; {!path [0 :user :role] ?leaf :admin} -;; {!path [0 :actions 0 :type] ?leaf :login}) - -;; rules can be precompiled -(let [rules {'$children (m/matcher '(scan !path (alt $children ?leaf)))}] - (m/matches '$children rules - [{:id 1 - :user {:name "Alise" - :role :admin} - :actions [{:type :login}]}])) -;; => '({!path [0 :id] ?leaf 1} -;; {!path [0 :user :name] ?leaf "Alise"} -;; {!path [0 :user :role] ?leaf :admin} -;; {!path [0 :actions 0 :type] ?leaf :login}) -``` - -Rules can work as predicates: - -```clojure -(def rules - {'$string? (fn [matches _ s] - (when (string? s) - (list matches)))}) - -(m/match? '(each $string?) rules ["qwe" "rty" "uio"]) ;; => true -(m/match? '(each $string?) rules ["qwe" 42 "uio"]) ;; => false -``` diff --git a/src/matchete/core.cljc b/src/matchete/core.cljc index c30b1a3..2a98568 100644 --- a/src/matchete/core.cljc +++ b/src/matchete/core.cljc @@ -55,15 +55,19 @@ {:pattern true}))) (defn- seq-pattern [P] - (let [P (mapv pattern P)] + (let [[P [_ TP :as tail]] (split-with #(not= '& %) P) + P (mapv pattern P) + TP (when (seq tail) (pattern TP))] (with-meta (fn [data ms] - (when (sequential? data) + (when (core-and (sequential? data) + (>= (count data) (count P))) (reduce (fn [ms [P data]] (core-or (seq (P data ms)) (reduced ()))) ms - (partition 2 (interleave P data))))) + (concat (partition 2 (interleave P data)) + (when TP (list [TP (drop (count P) data)])))))) {:pattern true}))) (defn- complex-set-pattern [P] diff --git a/test/matchete/core_test.cljc b/test/matchete/core_test.cljc index 6563a66..be4337a 100644 --- a/test/matchete/core_test.cljc +++ b/test/matchete/core_test.cljc @@ -62,6 +62,16 @@ {:x "qwe"} true {:x 42} true})))) +(deftest seq-pattern + (is (not (mc/match? '[?_ ?_] [1]))) + (is (not (mc/match? '[] 42))) + (is (mc/match? '[?_ ?_] [1 2])) + (is (mc/match? '[?_ ?_] [1 2 3])) + (is (= '[{?x 1}] (mc/matches '[?x ?x ?x] [1 1 1 2]))) + (is (= '[{?x 1 ?y 2 ?z 3}] + (mc/matches '[?x ?y & [?x ?y ?z]] + [1 2 1 2 3])))) + (deftest set-pattern (is (= [{}] ((mc/matcher #{1 2 3}) #{1 2 3 4 5}))) @@ -84,6 +94,8 @@ ((mc/matcher [(mc/formula (+ ?x 20)) '?x]) [42 23]))) (is (= [{'?x 22 '?y 42}] ((mc/matcher [(mc/formula (+ ?x 20) ?y) '?x]) [42 22]))) + (is (= [{'?x 22 '?y 42}] + ((mc/matcher ['?x (mc/formula (+ ?x 20) ?y)]) [22 42]))) (is (= [{'?x 22 '?y 1}] ((mc/matcher [(mc/formula (+ ?x 20)) (mc/formula (* ?y ?x 10)) '?x '?y]) [42 220 22 1])))) @@ -147,7 +159,8 @@ (is (mc/match? (mc/each 42) [42 42 42]))) (deftest some-pattern - (is (mc/match? (mc/some 42) [42 3 42]))) + (is (mc/match? (mc/some 42) [42 3 42])) + (is (not (mc/match? (mc/some 42) [1 2 3])))) (deftest predicate-pattern (is (mc/match? (mc/matcher (mc/each (mc/predicate string?))) ["qwe" "rty" "uio"])) From 6eed13f81884fcf89b417d7f29ba705ccfe6b80c Mon Sep 17 00:00:00 2001 From: Kirill Chernyshov Date: Thu, 25 Jun 2020 18:15:49 +0200 Subject: [PATCH 11/15] Add data-form.cljc --- deps.edn | 6 +- src/matchete/core.cljc | 137 +++++++++++++------- src/matchete/data_form.cljc | 113 ++++++++++++++++ src/matchete/json_schema.cljc | 208 ++++++++++++++++++++++++++++++ test/matchete/core_test.cljc | 26 +--- test/matchete/data_form_test.cljc | 33 +++++ 6 files changed, 449 insertions(+), 74 deletions(-) create mode 100644 src/matchete/data_form.cljc create mode 100644 src/matchete/json_schema.cljc create mode 100644 test/matchete/data_form_test.cljc diff --git a/deps.edn b/deps.edn index a80ee33..0e7d3f5 100644 --- a/deps.edn +++ b/deps.edn @@ -1,6 +1,7 @@ {:paths ["src"] - :deps {org.clojure/math.combinatorics {:mvn/version "0.1.6"}} + :deps {org.clojure/math.combinatorics {:mvn/version "0.1.6"} + borkdude/sci {:mvn/version "0.1.1-alpha.1"}} :aliases {:+test {:extra-paths ["test"] @@ -10,6 +11,7 @@ :+dev {:extra-paths ["dev"] :extra-deps {criterium {:mvn/version "0.4.5"} - meander/epsilon {:mvn/version "0.0.421"}}} + meander/epsilon {:mvn/version "0.0.421"} + cheshire {:mvn/version "5.10.0"}}} :+cljs {:extra-deps {org.clojure/clojurescript {:mvn/version "1.10.764"}}}}} diff --git a/src/matchete/core.cljc b/src/matchete/core.cljc index 2a98568..51cb2ab 100644 --- a/src/matchete/core.cljc +++ b/src/matchete/core.cljc @@ -9,12 +9,16 @@ (defn lvar? [x] (core-and (simple-symbol? x) (= \? (first (name x))))) +(defn mvar? [x] + (core-and (simple-symbol? x) (= \! (first (name x))))) + (defn placeholder? [x] - (core-and (lvar? x) (= \_ (second (name x))))) + (core-and ((some-fn lvar? mvar?) x) + (= \_ (second (name x))))) (defn pattern? [P] (core-or (:pattern (meta P)) - (lvar? P) + ((some-fn lvar? mvar?) P) (core-and ((some-fn map? sequential? set?) P) (core-some pattern? P)))) @@ -127,31 +131,6 @@ (when (= data P) ms)) {:pattern true})) -(defn pattern [P] - (cond - (:pattern (meta P)) - P - - (map? P) - (map-pattern P) - - (set? P) - (set-pattern P) - - (sequential? P) - (seq-pattern P) - - (placeholder? P) - (placeholder-pattern P) - - (lvar? P) - (lvar-pattern P) - - :else - (data-pattern P))) - -(def memoized-pattern (memoize pattern)) - (defn scan ([P] (let [M (pattern P)] @@ -228,6 +207,26 @@ MS)) {:pattern true})))) +(defn only-one + ([P] (pattern P)) + ([P & PS] + (let [MS (mapv pattern (list* P PS))] + (with-meta + (fn [data ms] + (second + (reduce + (fn [[ok-already? ms' :as r] M] + (if ok-already? + (if (seq (M data ms)) + (reduced [false ()]) + r) + (if-let [ms' (seq (M data ms))] + [true ms'] + [ok-already? ms']))) + [false ()] + MS))) + {:pattern true})))) + (defn not [P] (let [M (pattern P)] (with-meta @@ -236,9 +235,9 @@ ms)) {:pattern true}))) -(defn lif +(defn if* ([cond-pattern then-pattern] - (lif cond-pattern then-pattern ::empty)) + (if* cond-pattern then-pattern ::empty)) ([cond-pattern then-pattern else-pattern] (let [cond-m (pattern cond-pattern) then-m (pattern then-pattern) @@ -251,6 +250,22 @@ (when else-m (else-m data ms)))) {:pattern true})))) +(defn open-map [map-pattern] + (let [M (into {} (map (fn [[k v]] + [k (pattern v)])) + map-pattern)] + (with-meta + (fn [data ms] + (when (map? data) + (reduce-kv + (fn [ms k v] + (if (contains? M k) + (core-or (seq ((get M k) v ms)) (reduced ())) + ms)) + ms + data))) + {:pattern true}))) + (defn predicate ([pred] (predicate pred nil)) @@ -266,6 +281,14 @@ ms))) {:pattern true}))) +(defn guard [pred] + (with-meta + (fn [_ ms] + (sequence + (filter pred) + ms)) + {:pattern true})) + (defn aggregate-by ([aggr-fn] (with-meta @@ -279,6 +302,16 @@ ([aggr-fn dest] (aggregate-by #(update %1 dest aggr-fn %2)))) +(defn update-at [dest f] + (with-meta + (fn [data ms] + (sequence + (comp + (map #(update % dest f data)) + (filter some?)) + ms)) + {:pattern true})) + (defn reshape-by [tr-fn P] (let [M (pattern P)] (with-meta @@ -291,7 +324,7 @@ (coll? expr) (set (mapcat find-lvars expr)) - (lvar? expr) + ((some-fn lvar? mvar?) expr) (list expr) :else @@ -323,24 +356,6 @@ {:pattern true}) ~@(if dest `((symbol ~(name dest))) ())))) -(defmacro defpattern [name P] - `(def ~name - (with-meta - (fn [data# ms#] - ((memoized-pattern ~P) data# ms#)) - {:pattern true}))) - -(defmacro defnpattern [name args P] - `(def ~name - (with-meta - (fn [data# ms#] - (sequence - (mapcat (fn [m#] - (let [P# (memoized-pattern ((fn ~args ~P) m#))] - (P# data# [m#])))) - ms#)) - {:pattern true}))) - (defn result-of [f & [dest]] (let [lvars (:lvars (meta f)) guard (with-meta @@ -355,6 +370,32 @@ (and guard dest) guard))) +(defn pattern [P] + (cond + (:pattern (meta P)) + P + + (map? P) + (map-pattern P) + + (set? P) + (set-pattern P) + + (sequential? P) + (seq-pattern P) + + (placeholder? P) + (placeholder-pattern P) + + (lvar? P) + (lvar-pattern P) + + (mvar? P) + (aggregate-by (fnil conj []) (symbol (str "?" (subs (name P) 1)))) + + :else + (data-pattern P))) + (defn matcher [P] (let [M (pattern P)] (with-meta diff --git a/src/matchete/data_form.cljc b/src/matchete/data_form.cljc new file mode 100644 index 0000000..4a3bd9c --- /dev/null +++ b/src/matchete/data_form.cljc @@ -0,0 +1,113 @@ +(ns matchete.data-form + (:require [matchete.core :as mc] + [sci.core :as sci])) + +(defn pattern-type [_ P] + (when + (vector? P) + (first P))) + +(defn save-pattern! [{:keys [id]} named P] + (when (some? id) + (swap! named assoc id P)) + P) + +(defmulti ->pattern pattern-type) + +(defmethod ->pattern :default [_ value] value) + +(defmethod ->pattern :value [_ [_ _ value]] + value) + +(defmethod ->pattern :map [named [_ opts & entries]] + (let [{optional-keys true + required-keys false} (group-by #(boolean (get-in % [1 :optional])) entries) + make-map-pattern (fn [kvs] + (into {} + (map (fn [[k _ v]] + [(->pattern named k) + (->pattern named v)])) + kvs)) + optional-map-pattern (mc/open-map (make-map-pattern optional-keys)) + required-map-pattern (make-map-pattern required-keys)] + (cond + (and optional-keys required-keys) + (save-pattern! opts named (mc/and optional-map-pattern required-map-pattern)) + + optional-keys + (save-pattern! opts named optional-map-pattern) + + required-keys + (save-pattern! opts named required-map-pattern)))) + +(defmethod ->pattern :seq [named [_ opts & items]] + (save-pattern! opts named (into [] (map #(->pattern named %)) items))) + +(defmethod ->pattern :set [named [_ opts & items]] + (save-pattern! opts named (into #{} (map #(->pattern named %)) items))) + +(defmethod ->pattern :or [named [_ opts & PS]] + (save-pattern! opts named (apply mc/or (mapv (partial ->pattern named) PS)))) + +(defmethod ->pattern :one-of [named [_ opts & PS]] + (save-pattern! opts named (apply mc/only-one (map (partial ->pattern named) PS)))) + +(defmethod ->pattern :and [named [_ opts & PS]] + (save-pattern! opts named (apply mc/and (map (partial ->pattern named) PS)))) + +(defmethod ->pattern :not [named [_ opts P]] + (save-pattern! opts named (mc/not (->pattern named P)))) + +(defmethod ->pattern :if [named [_ opts & PS]] + (save-pattern! opts named (apply mc/if* (map (partial ->pattern named) PS)))) + +(defmethod ->pattern :scan [named [_ opts & PS]] + (save-pattern! opts named (apply mc/scan (map (partial ->pattern named) PS)))) + +(defmethod ->pattern :each [named [_ opts & PS]] + (save-pattern! opts named (apply mc/each (map (partial ->pattern named) PS)))) + +(defmethod ->pattern :some [named [_ opts & PS]] + (save-pattern! opts named (apply mc/some (map (partial ->pattern named) PS)))) + +(defmethod ->pattern :update-at [named [_ opts & PS]] + (save-pattern! opts named (apply mc/update-at PS))) + +(defmethod ->pattern :pred [named [_ opts & args]] + (save-pattern! opts named (apply mc/predicate (map (partial ->pattern named) args)))) + +(defmethod ->pattern :guard [named [_ opts f]] + (save-pattern! opts named (mc/guard (->pattern named f)))) + +(defmethod ->pattern :reshape-by [named [_ opts f P]] + (save-pattern! opts named (mc/reshape-by f (->pattern named P)))) + +(defmethod ->pattern :with-refs [named [_ opts bindings P]] + (doall (map #(save-pattern! {:id (first %)} named (->pattern (second %))) + (partition 2 bindings))) + (save-pattern! opts named (->pattern named P))) + +(defmethod ->pattern :fn [_ [_ _ form]] + (sci/eval-string (str form) {:preset :termination-safe})) + +(defmethod ->pattern :ref [named [_ _opts reference]] + (with-meta + (fn [data ms] + ((mc/pattern (get @named reference)) data ms)) + {:pattern true})) + +(defn inject-opts [P] + (if (vector? P) + (let [[t & P] P + opts (if (map? (first P)) + (first P) + {}) + P (map inject-opts (if (map? (first P)) + (rest P) + P))] + (into [] (cons t (cons opts P)))) + P)) + +(defn make-pattern [P] + (let [P (inject-opts P)] + (->pattern (atom {}) P))) diff --git a/src/matchete/json_schema.cljc b/src/matchete/json_schema.cljc new file mode 100644 index 0000000..0330703 --- /dev/null +++ b/src/matchete/json_schema.cljc @@ -0,0 +1,208 @@ +(ns matchete.json-schema + (:require [clojure.string :as string])) + +(defn subschema-type [_path {:strs [$id type $ref $defs definitions enum const anyOf allOf oneOf not default] + :as schema}] + (cond + (#{{} true} schema) :allow-all + (= false schema) :disallow-all + $defs :$defs + definitions :definitions + $id :id + (some some? [anyOf allOf oneOf not]) :combination + enum :enum + const :const + $ref :ref + (vector? type) :types + type (case type + "null" :nil + "boolean" :boolean + "string" :string + "integer" :integer + "number" :number + "array" :array + "object" :object) + default :allow-all)) + +(def json-schema->pattern nil) + +(defmulti json-schema->pattern subschema-type) + +(defmethod json-schema->pattern :allow-all [path _] + [:and {:ref path} '?_]) + +(defmethod json-schema->pattern :disallow-all [path _] + [:not {:ref path} '?_]) + +(defmethod json-schema->pattern :id [path {:strs [$id] :as schema}] + (let [pattern (json-schema->pattern path (dissoc schema "$id"))] + (update-in pattern [1] merge {:id $id :ref path}))) + +(defmethod json-schema->pattern :$defs [path {:strs [$defs] :as schema}] + (let [$defs (map (fn [[n p]] + (let [path (conj path "$defs" n)] + [:define {:id path} (json-schema->pattern path p)])) + $defs)] + (vec (concat (list :and {}) + $defs + (list (json-schema->pattern path (dissoc schema "$defs"))))))) + +(defmethod json-schema->pattern :definitions [path {:strs [definitions] :as schema}] + (let [$defs (map (fn [[n p]] + (let [path (conj path "definitions" n)] + [:define {:id path} (json-schema->pattern path p)])) + definitions)] + (vec (concat (list :and {}) + $defs + (list (json-schema->pattern path (dissoc schema "definitions"))))))) + +(defmethod json-schema->pattern :enum [path {:strs [enum]}] + (let [path (conj path "enum")] + (vec (concat [:or {:ref path}] + (map-indexed #(vector :value {:ref (conj path %1)} %2) enum))))) + +(defmethod json-schema->pattern :const [path {:strs [const]}] + [:value {:ref (conj path "const")} const]) + +(defn normalize-ref [ref] + (mapv (comp #(string/replace % #"~0" "~") + #(string/replace % #"~1" "/")) + (string/split ref #"/"))) + +(defmethod json-schema->pattern :ref [path {:strs [$ref]}] + [:ref {:ref path :origin $ref} (normalize-ref $ref)]) + +(defmethod json-schema->pattern :types [path {:strs [type] :as schema}] + (vec (concat (list :or {}) + (map (fn [t] + (let [res (json-schema->pattern path (assoc schema "type" t))] + (update-in res [1] dissoc :ref))) + type)))) + +(defmethod json-schema->pattern :nil [_ _] + nil) + +(defmethod json-schema->pattern :boolean [_ _] + [:predicate {} boolean?]) + +(defmethod json-schema->pattern :string [_ {:strs [minLength maxLength #_pattern #_format]}] + (let [base [:predicate {} string?] + length (when (or minLength maxLength) + [:predicate {} #(<= (or minLength 0) (count %) (or maxLength ##Inf))])] + (if length + [:and {} base length] + base))) + +(defn numeric-validator [{:strs [multipleOf minimum maximum exclusiveMinimum exclusiveMaximum]}] + (when (some some? [multipleOf minimum maximum exclusiveMinimum exclusiveMaximum]) + [:predicate {} + (every-pred + (if multipleOf #(zero? (mod % multipleOf)) (constantly true)) + (cond + minimum #(>= % minimum) + exclusiveMinimum #(> % exclusiveMinimum) + :else (constantly true)) + (cond + maximum #(<= % maximum) + exclusiveMaximum #(< % exclusiveMaximum) + :else (constantly true)))])) + +(defmethod json-schema->pattern :integer [_ schema] + (let [base [:predicate {} integer?] + validator (numeric-validator schema)] + (if validator + [:and {} base validator] + base))) + +(defmethod json-schema->pattern :number [_ schema] + (let [base [:predicate {} number?] + validator (numeric-validator schema)] + (if validator + [:and {} base validator] + base))) + +(defmethod json-schema->pattern :array [path {:strs [items minItems maxItems uniqueItems additionalItems] :as schema}] + (if (= false additionalItems) + (json-schema->pattern path (-> schema (assoc "maxItems" (count items)) (dissoc "additionalItems"))) + (let [additional-items (cond + (map? additionalItems) + ['& [:each {} (json-schema->pattern (conj path "additionalItems") additionalItems)]] + + (= false additionalItems) + ['& '?_]) + items (vec (cond + (sequential? items) + (concat [:seq {:ref path}] + (map-indexed #(json-schema->pattern (conj path "items" %1) %2) items) + additional-items) + + (map? items) + (conj [:each {:ref (conj path "items")}] + (json-schema->pattern (conj path "items") items)) + + :else + (concat [:seq {:ref path}] + additional-items)))] + (vec (concat [:and {}] [items] + (when (some some? [minItems maxItems]) + [[:predicate {} #(<= (or minItems 0) (count %) (or maxItems ##Inf))]]) + (when uniqueItems + [[:predicate {} distinct?]])))))) + +(defmethod json-schema->pattern :object [path {:strs [properties]}] + (vec (concat [:map {:ref path}] + (map (fn [[k vs]] + [k (json-schema->pattern (conj path "properties" k) vs)]) + properties)))) + +(defmethod json-schema->pattern :combination [path schema] + (let [to-combine (filter #(not-empty (get schema %)) ["anyOf" "allOf" "oneOf" "not"]) + combos (map #((get-method json-schema->pattern %) path schema) + to-combine)] + (vec (if (= 1 (count combos)) + (first combos) + (concat (list :and {}) combos))))) + +(defmethod json-schema->pattern "anyOf" [path {:strs [anyOf]}] + (concat (list :or {}) + (map-indexed #(json-schema->pattern (conj path "anyOf" %1) %2) anyOf))) + +(defmethod json-schema->pattern "allOf" [path {:strs [allOf]}] + (concat (list :and {}) + (map-indexed #(json-schema->pattern (conj path "allOf" %1) %2) allOf))) + +(defmethod json-schema->pattern "oneOf" [path {:strs [oneOf]}] + (concat (list :only-one {}) + (map-indexed #(json-schema->pattern (conj path "oneOf" %1) %2) oneOf))) + +(defmethod json-schema->pattern "not" [path {:strs [not]}] + [:not (json-schema->pattern (conj path "not") not)]) + +(comment + + (require '[matchete.data-form :as df] + '[matchete.core :as mc] + '[clojure.java.io :as io] + '[cheshire.core :as json]) + + (json-schema->pattern ["#"] {"definitions" {"foo" {"const" 42} + "bar" {"const" 43}} + "const" [1 2 3]}) + + (json-schema->pattern ["#"] {"type" ["null" "string"] + "minLength" 3}) + + (json-schema->pattern ["#"] {"anyOf" [{"type" "string" "maxLength" 3} + {"type" "number" "minimum" 0}]}) + + (mc/match? (df/make-pattern (json-schema->pattern ["#"] {"type" "array" "minItems" 2 "maxItems" 4})) + [1 3 4 5]) + + (let [M (df/make-pattern + (json-schema->pattern ["#"] + (json/parse-string (slurp (io/resource "draft_07.json"))))) + data (json/parse-string (slurp (io/resource "project.json")))] + (mc/match? M data) + #_(mc/match? M {})) + + ) diff --git a/test/matchete/core_test.cljc b/test/matchete/core_test.cljc index be4337a..5061c18 100644 --- a/test/matchete/core_test.cljc +++ b/test/matchete/core_test.cljc @@ -122,28 +122,6 @@ (defn conj-path [path step] ((fnil conj []) path step)) -(mc/defpattern tree-walk - (mc/or (mc/scan (mc/aggregate-by conj-path '?path) tree-walk) - '?leaf)) - -(mc/defnpattern limited-tree-walk [{:syms [?path]}] - (if (< (count ?path) 3) - (mc/or (mc/scan [(mc/aggregate-by conj-path '?path) limited-tree-walk]) - '?leaf) - '?leaf)) - -(deftest recursive-pattern - (is (= '[{?path [:x 0], ?leaf 1} - {?path [:x 1], ?leaf 2} - {?path [:x 2 :y], ?leaf "qwe"} - {?path [:z], ?leaf 42}] - (mc/matches tree-walk {:x [1 2 {:y "qwe"}] - :z 42}))) - (is (= '[{?path [:x :x :x], ?leaf {:x 1}} - {?path [:y], ?leaf 42}] - (mc/matches limited-tree-walk {:x {:x {:x {:x 1}}} - :y 42})))) - (deftest reshape-test (is (= '[{?ex-message "message 1"} {?ex-message "message 3"}] @@ -185,14 +163,14 @@ (is (not (mc/match? (mc/not (mc/predicate string?)) "42")))) (deftest if-pattern - (let [M (mc/lif (mc/predicate string?) '?this-is-a-string (mc/lif (mc/predicate number?) '?this-is-a-number '?i-dont-know-what-it-is))] + (let [M (mc/if* (mc/predicate string?) '?this-is-a-string (mc/if* (mc/predicate number?) '?this-is-a-number '?i-dont-know-what-it-is))] (is (= ['{?this-is-a-string "string"}] (mc/matches M "string"))) (is (= ['{?this-is-a-number 42}] (mc/matches M 42))) (is (= ['{?i-dont-know-what-it-is true}] (mc/matches M true)))) - (is (not (mc/match? (mc/lif 42 '?forty-two) 43)))) + (is (not (mc/match? (mc/if* 42 '?forty-two) 43)))) (comment diff --git a/test/matchete/data_form_test.cljc b/test/matchete/data_form_test.cljc new file mode 100644 index 0000000..72bc285 --- /dev/null +++ b/test/matchete/data_form_test.cljc @@ -0,0 +1,33 @@ +(ns matchete.data-form-test + (:require [matchete.data-form :as df] + [matchete.core :as mc] + #?(:clj [clojure.test :refer [deftest is]] + :cljs [cljs.test :refer [deftest is] :include-macros true]))) + +(deftest simple + (is (= [{'?x 1}] + (mc/matches (df/make-pattern '[:predicate [:fn (fn [x] true)] ?x]) 1)))) + +(deftest function + (is (= 3 ((df/make-pattern '[:fn (fn [x] (inc x))]) 2)))) + +(deftest tree-walk + (let [M (df/make-pattern '[:or {:id tree-walk} + [:scan !path [:ref tree-walk]] + ?leaf]) + M' (df/make-pattern '[:or {:id tree-walk} + [:and + [:guard [:fn (fn [{:syms [?path] :as m}] + (< (count ?path) 3))]] + [:scan !path [:ref tree-walk]]] + ?leaf])] + (is (= '[{?path [:x 0], ?leaf 1} + {?path [:x 1], ?leaf 2} + {?path [:x 2 :y], ?leaf "qwe"} + {?path [:z], ?leaf 42}] + (mc/matches M {:x [1 2 {:y "qwe"}] + :z 42}))) + (is (= '[{?path [:x :x :x], ?leaf {:x 1}} + {?path [:y], ?leaf 42}] + (mc/matches M' {:x {:x {:x {:x 1}}} + :y 42}))))) From 9d08f35ca299b4e34c792e37646808e8c5374077 Mon Sep 17 00:00:00 2001 From: Kirill Chernyshov Date: Thu, 25 Jun 2020 18:26:25 +0200 Subject: [PATCH 12/15] small fix --- test/matchete/data_form_test.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/matchete/data_form_test.cljc b/test/matchete/data_form_test.cljc index 72bc285..211f62a 100644 --- a/test/matchete/data_form_test.cljc +++ b/test/matchete/data_form_test.cljc @@ -6,7 +6,7 @@ (deftest simple (is (= [{'?x 1}] - (mc/matches (df/make-pattern '[:predicate [:fn (fn [x] true)] ?x]) 1)))) + (mc/matches (df/make-pattern '[:pred [:fn (fn [x] true)] ?x]) 1)))) (deftest function (is (= 3 ((df/make-pattern '[:fn (fn [x] (inc x))]) 2)))) From e241cfc56e79c7274b5140683c2d390fdc45e6d9 Mon Sep 17 00:00:00 2001 From: Kirill Chernyshov Date: Thu, 25 Jun 2020 18:28:11 +0200 Subject: [PATCH 13/15] make linter happy --- src/matchete/json_schema.cljc | 31 ------------------------------- 1 file changed, 31 deletions(-) diff --git a/src/matchete/json_schema.cljc b/src/matchete/json_schema.cljc index 0330703..4e1fc5e 100644 --- a/src/matchete/json_schema.cljc +++ b/src/matchete/json_schema.cljc @@ -24,8 +24,6 @@ "object" :object) default :allow-all)) -(def json-schema->pattern nil) - (defmulti json-schema->pattern subschema-type) (defmethod json-schema->pattern :allow-all [path _] @@ -177,32 +175,3 @@ (defmethod json-schema->pattern "not" [path {:strs [not]}] [:not (json-schema->pattern (conj path "not") not)]) - -(comment - - (require '[matchete.data-form :as df] - '[matchete.core :as mc] - '[clojure.java.io :as io] - '[cheshire.core :as json]) - - (json-schema->pattern ["#"] {"definitions" {"foo" {"const" 42} - "bar" {"const" 43}} - "const" [1 2 3]}) - - (json-schema->pattern ["#"] {"type" ["null" "string"] - "minLength" 3}) - - (json-schema->pattern ["#"] {"anyOf" [{"type" "string" "maxLength" 3} - {"type" "number" "minimum" 0}]}) - - (mc/match? (df/make-pattern (json-schema->pattern ["#"] {"type" "array" "minItems" 2 "maxItems" 4})) - [1 3 4 5]) - - (let [M (df/make-pattern - (json-schema->pattern ["#"] - (json/parse-string (slurp (io/resource "draft_07.json"))))) - data (json/parse-string (slurp (io/resource "project.json")))] - (mc/match? M data) - #_(mc/match? M {})) - - ) From debdf388caf46b5db55328f7f5fbdfcec52b3bd4 Mon Sep 17 00:00:00 2001 From: Kirill Chernyshov Date: Fri, 26 Jun 2020 09:34:07 +0200 Subject: [PATCH 14/15] Add missing dependency into pom.xml --- pom.xml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/pom.xml b/pom.xml index 7e427d8..f45f569 100644 --- a/pom.xml +++ b/pom.xml @@ -11,6 +11,11 @@ math.combinatorics 0.1.6 + + borkdude + sci + 0.1.1-alpha.1 + src From f2f150150eb7fd6f9e84f14f741e9bb7d935f856 Mon Sep 17 00:00:00 2001 From: Kirill Chernyshov Date: Fri, 26 Jun 2020 15:39:03 +0200 Subject: [PATCH 15/15] Small fixes --- src/matchete/data_form.cljc | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/matchete/data_form.cljc b/src/matchete/data_form.cljc index 4a3bd9c..ccd9669 100644 --- a/src/matchete/data_form.cljc +++ b/src/matchete/data_form.cljc @@ -70,8 +70,8 @@ (defmethod ->pattern :some [named [_ opts & PS]] (save-pattern! opts named (apply mc/some (map (partial ->pattern named) PS)))) -(defmethod ->pattern :update-at [named [_ opts & PS]] - (save-pattern! opts named (apply mc/update-at PS))) +(defmethod ->pattern :update-at [named [_ opts dest f]] + (save-pattern! opts named (mc/update-at dest (->pattern named f)))) (defmethod ->pattern :pred [named [_ opts & args]] (save-pattern! opts named (apply mc/predicate (map (partial ->pattern named) args)))) @@ -80,7 +80,7 @@ (save-pattern! opts named (mc/guard (->pattern named f)))) (defmethod ->pattern :reshape-by [named [_ opts f P]] - (save-pattern! opts named (mc/reshape-by f (->pattern named P)))) + (save-pattern! opts named (mc/reshape-by (->pattern named f) (->pattern named P)))) (defmethod ->pattern :with-refs [named [_ opts bindings P]] (doall (map #(save-pattern! {:id (first %)} named (->pattern (second %)))