Skip to content

Instantly share code, notes, and snippets.

@KingCode
Last active November 28, 2020 17:30
Show Gist options
  • Save KingCode/86d0c7748b40dd38dcdd3a89a62567f7 to your computer and use it in GitHub Desktop.
Save KingCode/86d0c7748b40dd38dcdd3a89a62567f7 to your computer and use it in GitHub Desktop.
(defn monoid* [init body]
`(fn f#
([]
(fn [& ~'xs] ~init))
([~'r]
(fn [& ~'xs] (~body (apply ~'r ~'xs))))
([~'r1 ~'r2]
(fn [& ~'xs] (~body(apply ~'r1 ~'xs) (apply ~'r2 ~'xs))))
([~'r1 ~'r2 & ~'rs]
(fn [& ~'xs]
(~body(apply ~'r1 ~'xs)
(~body (apply ~'r2 ~'xs)
(apply (apply f# ~'rs) ~'xs)))))))
(defn ->1+2ary [ary-1 ary-2]
`(fn ([~'x] (~ary-1 ~'x))
([~'x ~'y] (~ary-2 ~'x ~'y))))
(defmacro defmonoid
([rule-name-sym init cdecl]
`(def ~rule-name-sym ~(monoid* init cdecl)))
([rule-name-sym init ary1-body ary2-body]
`(def ~rule-name-sym ~(monoid* init (->1+2ary ary1-body
ary2-body)))))
;; utilities for rule counting combinators
(defn ->bit [bool-or-bit]
(cond
(= 0 bool-or-bit) 0
(number? bool-or-bit) bool-or-bit
bool-or-bit 1
:else 0))
(defn +bool
([] 0)
([x] (+ (->bit x)))
([x y]
(+ (->bit x) (->bit y))))
;; COMBINATORS
(defmonoid rule-and true and)
(defmonoid rule-or false or)
(def rule-not complement)
(defn rule-if [p q]
(rule-or (rule-not p) q))
(defn rule-iff [p q]
(rule-and (rule-if p q) (rule-if q p)))
(defn rule-xor [p q]
(rule-and (rule-or p q) (rule-not (rule-and p q))))
(defmonoid rule-oneof (comp boolean identity) identity
#(= 1 (+ (->bit %) (->bit %2))))
;; A combinator yielding the number of satisfied rules.
;; Each argument rule is a boolean predicate, or results are undetermined.
(defmonoid rule-count* (+bool) +bool)
;; Same as rule-count*, but rule return types are auto-converted to booleans.
(defn rule-count [& rules]
(->> rules (map #(comp boolean %))
(apply rule-count*)))
;; Yields a rule returning the result of applying 'pred to the number
;; of satisfied rules; 'rules are wrapped/converted to boolean predicates
(defn rule-filter-count [pred rules]
(let [cmbtr (apply rule-count rules)]
(fn [& xs]
(apply (comp pred cmbtr) xs))))
(defn rule-at-least [n & rules]
(rule-filter-count #(<= n %) rules))
(defn rule-at-most [n & rules]
(rule-filter-count #(<= % n) rules))
(defn rule-eactly [n & rules]
(rule-filter-count #(= n %) rules))
;; tests
(-> (rule-and odd? #(< 2 %) #(< % 6))
(map (range 2 7))) ;; => (false, true, false, true, false)
(-> (rule-or even? #(zero? (rem % 5)))
(map [2 7 15 300])) ;;=> (true false true true)
(-> (rule-if #(zero? (rem % 4)) even?)
(map [10 16 3])) ;;=> (true true true)
(-> (rule-iff #(zero? (rem % 2)) even?)
(map (range 4))) ;;=> (true true true true)
(-> (rule-xor even? odd?)
(map (range 4))) ;;=> (true true true true)
(-> (rule-xor #(zero? (rem % 5)) #(zero? (rem % 3)))
(map '(1 2 3 5 10 15 25 30)))
;;=> (false false true true true false true false)
(-> (rule-oneof :berlin :rome :new-york)
(map '({:berlin true} {:rome true} {:new-york :work :rome :home})))
;;=> (true true false)
(-> (rule-oneof :berlin :rome :new-york)
(map '({} {:rome :ok} {:new-york :work :rome :home})))
;;=> (false true false)
(-> (rule-at-least 2 :berlin :rome :new-york)
(map '({:berlin :sales} {:new-york :home :rome :overseas} {})))
;;=> (false true false
(-> (rule-at-most 2 :berlin :rome :new-york)
(map '({:berlin :away :rome :summer} {:rome :summer :berlin 1 :new-york 2} {:new-york :sales})))
;;=> (true false true)
(def can-vote? (rule-and
(rule-and #(<= 18 (:age %)) :citizen?)
(rule-at-least 1 :affiliated? :registered?)))
(->> '({:age 17 :citizen? :acquired} {:age 40 :citizen? :at-birth :registered? :yes})
(map can-vote?)) ;;=> (false true)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment