├── resources ├── mimer.jpg ├── pong.png └── log4j.properties ├── .gitmodules ├── .gitignore ├── project.clj ├── test └── mimir │ └── test │ ├── match.clj │ ├── arithmetic.clj │ ├── family.clj │ ├── blocks.clj │ ├── golfers.clj │ ├── peg.txt │ ├── n_queens.clj │ ├── common.clj │ ├── pricing.clj │ ├── prism.txt │ ├── pong.clj │ ├── mk.clj │ ├── C.peg │ └── parse.clj ├── src └── mimir │ ├── mk.clj │ ├── match.clj │ ├── parse.clj │ └── well.clj └── README.md /resources/mimer.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hraberg/mimir/HEAD/resources/mimer.jpg -------------------------------------------------------------------------------- /resources/pong.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hraberg/mimir/HEAD/resources/pong.png -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "docs"] 2 | path = docs 3 | url = git@github.com:hraberg/mimir.git 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /pom.xml 2 | *jar 3 | /lib 4 | /classes 5 | /target 6 | /native 7 | /.lein-failures 8 | /checkouts 9 | /.lein-deps-sum 10 | -------------------------------------------------------------------------------- /resources/log4j.properties: -------------------------------------------------------------------------------- 1 | log4j.rootLogger=INFO, A1 2 | log4j.appender.A1=org.apache.log4j.ConsoleAppender 3 | log4j.appender.A1.layout=org.apache.log4j.PatternLayout 4 | log4j.appender.A1.layout.ConversionPattern=%d %-5p %c: %m%n 5 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject mimir/mimir "0.1.0-SNAPSHOT" 2 | :description "Mímir is an experimental rule engine written in Clojure" 3 | :repositories {"sonatype snapshots" 4 | "https://oss.sonatype.org/content/repositories/snapshots/"} 5 | :dependencies [[org.clojure/clojure "1.5.1"] 6 | [org.flatland/ordered "1.5.1"] 7 | [log4j/log4j "1.2.16"] 8 | [org.clojure/tools.logging "0.2.3"]] 9 | :profiles {:dev {:dependencies [[marginalia "0.7.1"] 10 | [clojure-lanterna "0.9.2"] 11 | [org.clojure/tools.trace "0.7.5"]]}} 12 | :plugins [[lein-swank "1.4.5"] 13 | [lein-difftest "2.0.0"]] 14 | :test-selectors {:default (complement :mk) :mk :mk} 15 | :repl-init mimir.well 16 | :main mimir.well 17 | :min-lein-version "2.0.0") 18 | -------------------------------------------------------------------------------- /test/mimir/test/match.clj: -------------------------------------------------------------------------------- 1 | (ns mimir.test.match 2 | (:use [mimir.match :only (defm condm match)] 3 | [mimir.test.common] 4 | [clojure.walk :only (postwalk prewalk walk postwalk-replace)] 5 | [clojure.test])) 6 | 7 | ; scratchpad, real tests yet to be written 8 | 9 | (defm member? [x & y] 10 | [x & _ ] true 11 | [_ & xs] (member? x xs)) 12 | 13 | (defm filter-m [pred & coll] 14 | [^x pred & xs] (cons x (filter-m pred xs)) 15 | [_ & xs] (filter-m pred xs) 16 | empty? ()) 17 | 18 | (defm map-m [f & coll] 19 | [x & xs] (cons (f x) (map-m f xs))) 20 | 21 | (defm reduce-m [f val & coll] 22 | [x & xs] (reduce-m f (f x val) xs) 23 | empty? val) 24 | 25 | (defn factorial [x] 26 | (condm x 27 | 0 1 28 | x (* x (factorial (dec x))))) 29 | 30 | ;; (defm factorial [& x] 31 | ;; 0 1 32 | ;; x (* x (factorial (dec x)))) 33 | -------------------------------------------------------------------------------- /test/mimir/test/arithmetic.clj: -------------------------------------------------------------------------------- 1 | (ns mimir.test.arithmetic 2 | (:use [mimir.well :only (rule run fact facts all-different)] 3 | [mimir.test.common] 4 | [clojure.test])) 5 | 6 | (with-reset-fixture) 7 | 8 | (deftest simple-arithmetic 9 | (integers) 10 | 11 | (rule xyz 12 | X < Y 13 | Z > 5 14 | Z = (+ X Y) 15 | Z != Y 16 | => 17 | (str X '+ Y '= Z)) 18 | 19 | (matches? "2+4=6")) 20 | 21 | (deftest equals 22 | (integers) 23 | 24 | (rule equals 25 | X = Y 26 | => 27 | (str X '= Y)) 28 | 29 | (matches? "1=1")) 30 | 31 | (deftest send-more-money 32 | (integers) 33 | 34 | (rule send-more-money 35 | (base 10 S E N D 36 | + M O R E 37 | = M O N E Y) 38 | 39 | (all-different S E N D M O R Y) 40 | 41 | => 42 | 43 | (str S E N D '+ M O R E '= M O N E Y)) 44 | 45 | (time (match? "9567+1085=10652"))) 46 | -------------------------------------------------------------------------------- /test/mimir/test/family.clj: -------------------------------------------------------------------------------- 1 | (ns mimir.test.family 2 | (:use [mimir.well :only (rule facts working-memory)] 3 | [mimir.test.common] 4 | [clojure.test])) 5 | 6 | (with-reset-fixture) 7 | 8 | (deftest family 9 | (facts John son Dan 10 | Mary sister Suzan 11 | Harold brother Larry 12 | John married Mary 13 | Larry married Sue 14 | Larry son John) 15 | 16 | (rule father 17 | ?x son ?y 18 | => 19 | ?y father ?x) 20 | 21 | (rule grandfather 22 | ?x father ?y 23 | ?y father ?z 24 | => 25 | ?z grandfather ?x) 26 | 27 | (rule sister-in-law 28 | ?x married ?y 29 | ?y sister ?z 30 | => 31 | ?z sister-in-law ?x) 32 | 33 | (match? Suzan sister-in-law John 34 | Dan father John 35 | John father Larry 36 | Larry grandfather Dan)) 37 | 38 | (deftest socrates 39 | (facts Socrates is human) 40 | 41 | (rule mortal 42 | ?x is human 43 | => 44 | ?x is mortal) 45 | 46 | (match? Socrates is mortal) 47 | 48 | (is (= '#{(Socrates is human) 49 | (Socrates is mortal)} (working-memory)))) 50 | -------------------------------------------------------------------------------- /test/mimir/test/blocks.clj: -------------------------------------------------------------------------------- 1 | (ns mimir.test.blocks 2 | (:use [mimir.well :only (rule run facts fact retract working-memory alpha-network)] 3 | [mimir.test.common] 4 | [clojure.set :only (difference)] 5 | [clojure.test])) 6 | 7 | (with-reset-fixture) 8 | 9 | (deftest blocks 10 | (facts B1 on B2 11 | B1 on B3 12 | B1 color red 13 | B2 on table 14 | B2 left-of B3 15 | B2 color blue 16 | B3 left-of B4 17 | B3 on table 18 | B3 color red) 19 | 20 | (rule find-stack-of-two-blocks-to-the-left-of-a-red-block 21 | ?x on ?y 22 | ?y left-of ?z 23 | ?z color red 24 | => 25 | ?x is on-top) 26 | 27 | (match? B1 is on-top) 28 | 29 | ; retract irrelevant fact 30 | (retract B2 color blue) 31 | (match? B1 is on-top) 32 | 33 | ; retract relevant fact 34 | (let [an ((alpha-network) '(?1 left-of ?2))] 35 | 36 | (retract B2 left-of B3) 37 | 38 | (no-matches?) 39 | (is (= '#{{?1 B2 ?2 B3}} 40 | (difference an ((alpha-network) '(?1 left-of ?2))))) 41 | 42 | ; restate the fact 43 | (facts B2 left-of B3) 44 | 45 | (match? B1 is on-top) 46 | (is (= an ((alpha-network) '(?1 left-of ?2)))))) -------------------------------------------------------------------------------- /test/mimir/test/golfers.clj: -------------------------------------------------------------------------------- 1 | (ns mimir.test.golfers 2 | (:use [mimir.well :only (rule run fact different all-different not-in is-not constrain)] 3 | [mimir.test.common] 4 | [clojure.test]) 5 | (:refer-clojure :exclude [assert])) 6 | 7 | (with-reset-fixture) 8 | 9 | (deftest golfers 10 | (doseq [name ["Fred" "Joe" "Bob" "Tom"] 11 | pants-color [:red :blue :plaid :orange] 12 | position (range 1 (inc 4))] 13 | (fact {:name name :position position :pants-color pants-color})) 14 | 15 | (rule find-solution 16 | {:name "Fred" 17 | :position fred} 18 | 19 | {:name "Joe" 20 | :position 2} 21 | 22 | {:name "Bob" 23 | :pants-color :plaid} 24 | 25 | {:name "Tom" 26 | :position (not-in #{1 4}) 27 | :pants-color (is-not :orange)} 28 | 29 | (constrain {:position (inc ?fred) 30 | :pants-color :blue}) 31 | 32 | (different #{:position :pants-color}) 33 | 34 | => 35 | 36 | (set *matches*)) 37 | 38 | (time (match? #{{:name "Fred", :position 1, :pants-color :orange} 39 | {:name "Joe", :position 2, :pants-color :blue} 40 | {:name "Bob", :position 4, :pants-color :plaid} 41 | {:name "Tom", :position 3, :pants-color :red}}))) 42 | -------------------------------------------------------------------------------- /test/mimir/test/peg.txt: -------------------------------------------------------------------------------- 1 | # Hierarchical syntax 2 | Grammar <- Spacing Definition+ EndOfFile 3 | Definition <- Identifier LEFTARROW Expression 4 | Expression <- Sequence (SLASH Sequence)* 5 | Sequence <- Prefix* 6 | Prefix <- (AND / NOT)? Suffix 7 | Suffix <- Primary (QUESTION / STAR / PLUS)? 8 | Primary <- Identifier !LEFTARROW 9 | / OPEN Expression CLOSE 10 | / Literal / Class / DOT 11 | 12 | # Lexical syntax 13 | Identifier <- IdentStart IdentCont* Spacing 14 | IdentStart <- [a-zA-Z_] 15 | IdentCont <- IdentStart / [0-9] 16 | Literal <- ['] (!['] Char)* ['] Spacing 17 | / ["] (!["] Char)* ["] Spacing 18 | Class <- '[' (!']' Range)* ']' Spacing 19 | Range <- Char '-' Char / Char 20 | Char <- '\\' [nrt'"\[\]\\] 21 | / '\\' [0-2][0-7][0-7] 22 | / '\\' [0-7][0-7]? 23 | / !'\\' . 24 | 25 | LEFTARROW <- '<-' Spacing 26 | SLASH <- '/' Spacing 27 | AND <- '&' Spacing 28 | NOT <- '!' Spacing 29 | QUESTION <- '?' Spacing 30 | STAR <- '*' Spacing 31 | PLUS <- '+' Spacing 32 | OPEN <- '(' Spacing 33 | CLOSE <- ')' Spacing 34 | DOT <- '.' Spacing 35 | 36 | Spacing <- (Space / Comment)* 37 | Comment <- '#' (!EndOfLine .)* EndOfLine 38 | Space <- ' ' / '\t' / EndOfLine 39 | EndOfLine <- '\r\n' / '\n' / '\r' 40 | EndOfFile <- !. 41 | -------------------------------------------------------------------------------- /test/mimir/test/n_queens.clj: -------------------------------------------------------------------------------- 1 | (ns mimir.test.n-queens 2 | (:use [mimir.well :only (rule fact take-unique take-distinct not-same all-different different)] 3 | [mimir.test.common] 4 | [mimir.match :only (match match*)] 5 | [clojure.test])) 6 | 7 | (with-reset-fixture) 8 | 9 | (defn chessboard [n] 10 | (let [size (range 1 (inc n))] 11 | (doall (for [x size y size] 12 | (fact [x y]))))) 13 | 14 | (defn rank [x] (x 0)) 15 | (defn file [x] (x 1)) 16 | 17 | (defn diagonal? [x y] 18 | (= (Math/abs (- (rank x) (rank y))) 19 | (Math/abs (- (file x) (file y))))) 20 | 21 | (def ^:dynamic *n* 5) 22 | 23 | (deftest n-queens-test 24 | (chessboard *n*) 25 | 26 | (rule n-queens 27 | 28 | (take-unique *n*) 29 | (different #{file rank}) 30 | (not-same diagonal?) 31 | 32 | => 33 | 34 | (map file *matches*)) 35 | 36 | (time (match? [4 2 5 3 1] [3 5 2 4 1] [5 3 1 4 2] [4 1 3 5 2] [5 2 4 1 3] 37 | [1 4 2 5 3] [2 5 3 1 4] [1 3 5 2 4] [3 1 4 2 5] [2 4 1 3 5]))) 38 | 39 | (deftest n-queens-test-2 40 | (integers 1 *n*) 41 | 42 | (rule n-queens 43 | (take-distinct *n*) 44 | (all-different (map-indexed + *matches*)) 45 | (all-different (map-indexed - *matches*)) 46 | (all-different) 47 | => 48 | *matches*) 49 | 50 | (time (match? [4 2 5 3 1] [3 5 2 4 1] [5 3 1 4 2] [4 1 3 5 2] [5 2 4 1 3] 51 | [1 4 2 5 3] [2 5 3 1 4] [1 3 5 2 4] [3 1 4 2 5] [2 4 1 3 5]))) 52 | -------------------------------------------------------------------------------- /test/mimir/test/common.clj: -------------------------------------------------------------------------------- 1 | (ns mimir.test.common 2 | (:use [mimir.well :only (run parser quote-fact fact reset *net*)] 3 | [clojure.set :only (subset? difference)] 4 | [clojure.test])) 5 | 6 | (defmacro match? [& expected] 7 | (when expected 8 | `(is (= (set ~(vec (parser expected identity quote-fact false))) (run))))) 9 | 10 | (defn no-matches? [] 11 | (match?)) 12 | 13 | (defmacro matches? [& expected] 14 | (when expected 15 | `(is (subset? ~(set expected) (set (run)))))) 16 | 17 | (defn with-reset-fixture [] 18 | (use-fixtures :each (fn [f] (reset) (require '[mimir.match :reload true]) (f) (reset)))) 19 | 20 | (defn integers 21 | ([] (integers 0 9)) 22 | ([start end] (->> (range start (inc end)) (map fact) doall))) 23 | 24 | (defmacro base [base & expr] 25 | (let [[x [op] y [test] z] (partition-by '#{+ =} expr) 26 | reminders (map (comp symbol (partial str "?") gensym) (reverse z))] 27 | (concat 28 | [`(> ~(first x) 0) `(> ~(first y) 0)] 29 | 30 | (if (= (count z) (count x)) 31 | [`(> ~(first z) 0) `(= ~(last reminders) 0)] 32 | [`(= ~(first z) ~(last (butlast reminders)))]) 33 | 34 | (for [r reminders] 35 | `(or (= 0 ~r) (= 1 ~r))) 36 | 37 | (for [[carry a b c c-rem] (partition 5 (interleave (cons 0 reminders) 38 | (reverse x) 39 | (reverse y) 40 | (reverse z) 41 | reminders))] 42 | `(= (~op ~carry ~a ~b) (~op ~c (* ~base ~c-rem))))))) 43 | -------------------------------------------------------------------------------- /test/mimir/test/pricing.clj: -------------------------------------------------------------------------------- 1 | (ns mimir.test.pricing 2 | (:use [mimir.well :only (rule facts fact run)] 3 | [mimir.test.common] 4 | [clojure.test])) 5 | 6 | (with-reset-fixture) 7 | 8 | (defrecord Order [items customer total]) 9 | (defrecord OrderItem [description partNumber price quantity] 10 | Object 11 | (toString [_] (format "%d %s: %.2f" quantity description price))) 12 | (defrecord CatalogItem [description partNumber price]) 13 | (defrecord Customer [orderCount]) 14 | (defrecord Offer [description amount] 15 | Object 16 | (toString [_] (format "%s: -$%.2f" description amount))) 17 | 18 | (defn order [items customer] 19 | (let [total (reduce + (map #(* (:quantity %) 20 | (:price %)) items))] 21 | (Order. items customer total))) 22 | 23 | (deftest pricing-1 24 | (facts (order [(OrderItem. "CD Writer" 1234 199.99 1) 25 | (OrderItem. "AA Batteries" 4323 4.99 2)] 26 | (Customer. 6))) 27 | 28 | (rule a-10-percent-volume-discount 29 | "Give a 10% discount to everybody who spends more than $100." 30 | (> (.total ?o) 100) 31 | => 32 | (fact (Offer. "10% volume discount" (/ (.total ?o) 10)))) 33 | 34 | (match? (Offer. "10% volume discount" 20.997))) 35 | 36 | (deftest pricing-2 37 | (facts (OrderItem. "Gold-tipped cable" 9876 19.99 4)) 38 | 39 | (rule a-25-percent-multi-item-discount 40 | "Give a 25% discount on items the customer buys three or more of." 41 | (>= (.quantity ?item) 3) 42 | => 43 | (fact (Offer. "25% multi-item discount" (/ (.price ?item) 4)))) 44 | 45 | (match? (Offer. "25% multi-item discount" 4.9975))) 46 | 47 | (deftest pricing-3 48 | (facts (CatalogItem. "CD Writer" 1234 199.99) 49 | (CatalogItem. "CD-RW Disks" 782321 5.99) 50 | (OrderItem. "CD Writer" 1234 199.99 1) 51 | (Customer. 6)) 52 | 53 | (rule free-cd-rw-disks 54 | "If somebody buys a CD writer, send them a free sample of CD-RW 55 | disks, catalog number 782321; but only if they're a repeat customer. 56 | We use a regular expression to match the CD writer's description." 57 | (re-find #"CD Writer" (.description (cast CatalogItem ?catalog-item))) 58 | (= 782321 (.partNumber ?catalog-item-2)) 59 | (= (.partNumber (cast OrderItem ?order-item)) 60 | (.partNumber ?catalog-item)) 61 | (> (.orderCount ?customer) 1) 62 | => 63 | (fact (Offer. "Free CD-RW disks" (.price ?catalog-item-2)))) 64 | 65 | (match? (Offer. "Free CD-RW disks" 5.99))) 66 | -------------------------------------------------------------------------------- /test/mimir/test/prism.txt: -------------------------------------------------------------------------------- 1 | ;; From "A Prism Primer", David A. Mundie, 1991, p 203-204 2 | ;; http://www.dtic.mil/cgi-bin/GetTRDoc?AD=ADA240565 3 | ;; Just slightly cleaned up from the OCR, not matching any specific grammar syntax. 4 | ;; The grammar is explained in the next paper, "Grammar 0.5" ibid. p 205. 5 | 6 | ;; "Prismatic Samples", p 217: 7 | ;; "Prism's view that interacting with a computer is a kind of dialog, 8 | ;; its commitment to supporting intensionality and incompleteness, and its avoidance of overspecification, 9 | ;; all require a language quite different from the purely extensional languages of the past." 10 | 11 | ;; Appendix A.- Collected Syntax 12 | 13 | name => np 14 | 15 | quantifier [premodifier] type_literal [postmodifier] => np 16 | 17 | text_literal | graphic_literal | pronoun => name 18 | 19 | name ['\'' name] => name 20 | 21 | '(' np ')' => name 22 | 23 | type_name '[' np [',' np] ']' => name 24 | 25 | ['at least' | 'at most' | 'exactly'] number_name => quantifier 26 | 27 | 'some' | 'few' | 'many' | 'most' => quantifier 28 | 29 | 'all' [number_name] => quantifier 30 | 31 | 'every' [ordinal] => quantifier 32 | 33 | 'any' [number_name] => quantifier 34 | 35 | 'a' | 'an' | 'the' [number_name] => quantifier 36 | 37 | property_name | type_name => premodifier 38 | 39 | number_name [unit_np] => measure_np 40 | 41 | measure_np [x measure_np] => premodifier 42 | 43 | preposition noun_phrase => prepositional phrase 44 | 45 | prepositional_phrase => postmodifler 46 | 47 | 'in' ['reverse'] [binaryBooleanFunction_name] 'order' => postmodifier 48 | 49 | 'such that' claim => postmodifier 50 | 51 | 'that' vp => postmodifier 52 | 53 | Boolean_np => claim 54 | 55 | np vp => claim 56 | 57 | claim '.' => declaration 58 | 59 | np '=def' np => claim 60 | 61 | np '=imp' np => claim 62 | 63 | np '=def' np => claim 64 | 65 | np '=imp' np => claim 66 | 67 | action_verb [prepositional phrase] '(' [np [',' np]] ')' => action_vp 68 | 69 | action_verb [prepositional phrase] [np ['to' np]] => action_yp 70 | 71 | action_vp => vp 72 | 73 | copulative [np | premodifier | postmodifler] => vp 74 | 75 | action_vp => imperation 76 | 77 | variable '<-' np => imperation 78 | 79 | premodifier | postmodifier | np | vp | claim => form 80 | 81 | form ',' [form ','] ['and' | 'or'] form => type of form 82 | 83 | form conjunction form => type of form 84 | 85 | 'and' | 'or' | 'xor' | 'iff | 'implies' => conjunction 86 | 87 | 'not' form => form 88 | 89 | np | declaration | imperation | interrogation => computation 90 | 91 | '<' simple_name '>' computation => type of computation 92 | 93 | 'with' np 'do' computation => type of computation 94 | 95 | 'case' ['when' claim '=>' computation] => type of computation 96 | 97 | 'case' np ['when' np '=>' computation] => type of computation 98 | 99 | 'others' => claim | np 100 | 101 | 'if' claim 'then' computation => type of computation 102 | 103 | 'for' np 'do' computation => type of computation 104 | 105 | declaration | impernation => sentence 106 | 107 | claim '!' => interactive_declaration 108 | 109 | vp '!' => interactive_imperation 110 | 111 | claim '?' => interactive_nterrogation 112 | 113 | np '!' => interactive_calculation 114 | 115 | interactive_calculation | interactive_declaration | interactive_imperation | interactive_interrogation => sentence 116 | -------------------------------------------------------------------------------- /test/mimir/test/pong.clj: -------------------------------------------------------------------------------- 1 | (ns mimir.test.pong 2 | (:use [mimir.well :only (update rule reset run* is-not)]) 3 | (:require [lanterna.screen :as s])) 4 | 5 | (reset) 6 | 7 | (def axis {:x 0 :y 1}) 8 | (def paddle-size 5) 9 | (defn half [n] (bit-shift-right n 1)) 10 | 11 | (rule ball-keeps-moving 12 | {:speed [dx dy]} 13 | => 14 | (update :ball [:ball] #(mapv + [dx dy] %))) 15 | 16 | (defn place-ball-at-center [width height] 17 | (update {:ball =} merge {:ball [(half width) (rand-int height)]})) 18 | 19 | (defn score [who] 20 | (update {:player who} [:score] inc)) 21 | 22 | (rule computer-scores 23 | {:screen [width height]} 24 | {:ball [0 _]} 25 | => 26 | (place-ball-at-center width height) 27 | (score :computer)) 28 | 29 | (rule player-scores 30 | {:screen [width height]} 31 | {:ball [width _]} 32 | => 33 | (place-ball-at-center width height) 34 | (score :human)) 35 | 36 | (defn bounce [axis] 37 | (update :speed [:speed axis] -)) 38 | 39 | (rule ball-hits-paddle 40 | {:ball [bx by] :speed [dx _]} 41 | {:paddle [(+ ?dx ?bx) #(<= % ?by (+ paddle-size %))]} 42 | => 43 | (bounce (:x axis))) 44 | 45 | (rule ball-hits-floor 46 | {:ball [_ 0] :speed [_ neg?]} 47 | => 48 | (bounce (:y axis))) 49 | 50 | (rule ball-hits-ceiling 51 | {:screen [_ height]} 52 | {:ball [_ height] :speed [_ pos?]} 53 | => 54 | (bounce (:y axis))) 55 | 56 | (defn move-paddle [who direction] 57 | (update {:player who} [:paddle (:y axis)] direction)) 58 | 59 | (rule player-moves-paddle-up 60 | {:key :up} 61 | => 62 | (move-paddle :human dec)) 63 | 64 | (rule player-moves-paddle-down 65 | {:key :down} 66 | => 67 | (move-paddle :human inc)) 68 | 69 | (defn middle-of-paddle [y] 70 | (+ (half paddle-size) y)) 71 | 72 | (rule computer-moves-paddle-up 73 | {:ball [_ by]} 74 | {:player :computer :paddle [_ py]} 75 | (< ?by (middle-of-paddle ?py)) 76 | => 77 | (move-paddle :computer dec)) 78 | 79 | (rule computer-moves-paddle-down 80 | {:ball [_ by]} 81 | {:player :computer :paddle [_ py]} 82 | (> ?by (middle-of-paddle ?py)) 83 | => 84 | (move-paddle :computer inc)) 85 | 86 | (rule paddle-hits-ceiling 87 | {:player who :paddle [_ (complement pos?)]} 88 | => 89 | (move-paddle who 0)) 90 | 91 | (rule paddle-hits-floor 92 | {:screen [_ height]} 93 | {:player who :paddle [_ py]} 94 | (> (+ paddle-size ?py) ?height) 95 | => 96 | (move-paddle who (inc (- height paddle-size)))) 97 | 98 | (declare screen) 99 | 100 | (def colors {:fg :white :bg :black}) 101 | (def reverse-video {:fg (:bg colors) :bg (:fg colors)}) 102 | 103 | (defn puts 104 | ([x y s] (puts x y s colors)) 105 | ([x y s opts] (s/put-string screen x y (str s) opts))) 106 | 107 | (rule player-exits-game 108 | {:key :escape} 109 | => 110 | (s/stop screen) 111 | (System/exit 0)) 112 | 113 | (rule draw-ball 114 | {:ball [x y]} 115 | => 116 | (s/move-cursor screen x y)) 117 | 118 | (rule draw-paddle 119 | {:paddle [x y]} 120 | => 121 | (doseq [y (range y (+ y paddle-size))] 122 | (puts x y " " reverse-video)) 123 | (puts x (dec y) " ") 124 | (puts x (+ y paddle-size) " ")) 125 | 126 | (rule draw-score :salience 1 127 | {:paddle [x y] :score s} 128 | => 129 | (puts x 2 s)) 130 | 131 | (defn blank [x y] 132 | (s/clear screen) 133 | (s/redraw screen) 134 | (doseq [y (range 0 y)] 135 | (puts 0 y (apply str (repeat x " "))))) 136 | 137 | (defn center [total length] 138 | (half (- total length))) 139 | 140 | (defn centered-text [width y s] 141 | (puts (center width (count s)) y s)) 142 | 143 | (defn draw-net [x y] 144 | (doseq [y (range 0 y 3)] 145 | (puts (half x) y " " reverse-video))) 146 | 147 | (defn create-paddle [who x y] 148 | (update {:player who} merge {:paddle [x y] :score 0})) 149 | 150 | (defn header [width] 151 | (centered-text width 0 "Welcome to Mímir Pong!") 152 | (centered-text width 1 "Press Esc to exit")) 153 | 154 | (defn draw-background [x y] 155 | (blank x y) 156 | (draw-net x y) 157 | (header x)) 158 | 159 | (defn start-game [x y] 160 | (place-ball-at-center x y) 161 | (update :ball merge {:speed [1 1]}) 162 | (create-paddle :human 2 (center y paddle-size)) 163 | (create-paddle :computer (- x 2) (center y paddle-size))) 164 | 165 | (defn resize-screen [x y] 166 | (update :screen {:screen (mapv dec [x y])}) 167 | (draw-background x y) 168 | (start-game x y)) 169 | 170 | (defn frame [] 171 | (s/redraw screen) 172 | (Thread/sleep 20) 173 | (update :key {:key (->> (repeatedly #(s/get-key screen)) 174 | (take-while identity) last)})) 175 | 176 | (defn -main [& [screen-type _]] 177 | (def screen (s/get-screen (read-string (or screen-type ":text")))) 178 | (s/add-resize-listener screen resize-screen) 179 | (s/in-screen screen (dorun (interleave (run*) (repeatedly frame))))) 180 | -------------------------------------------------------------------------------- /src/mimir/mk.clj: -------------------------------------------------------------------------------- 1 | (ns mimir.mk 2 | (:use [clojure.tools.logging :only (debug info warn error spy)] 3 | [mimir.match :only (filter-walk prepare-matcher *match-var?* match-any bind-vars MatchAny MatchSeq)] 4 | [clojure.walk :only (postwalk-replace postwalk)]) 5 | (:import [java.io Writer] 6 | [clojure.lang Symbol Seqable]) 7 | (:refer-clojure :exclude [reify var? ==])) 8 | 9 | ;; mímirKanren: loosely based on "Implementation I: Core miniKanren", Chapter 3 in Byrd. 10 | 11 | (defprotocol MatchVar (match-var [this x acc])) 12 | 13 | (extend-protocol MatchVar 14 | Object 15 | (match-var [x this acc] (when-let [x (-> x meta :tag)] 16 | (match-any x this acc))) 17 | nil 18 | (match-var [x this acc]) 19 | Symbol 20 | (match-var [x this acc])) 21 | 22 | (extend-protocol MatchAny 23 | Object 24 | (match-any [this x acc] (if (= this x) acc 25 | (match-var x this acc))) 26 | Symbol 27 | (match-any [this x acc] (if (= this x) acc 28 | (match-var x this acc))) 29 | nil 30 | (match-any [this x acc] (if (nil? x) acc 31 | (match-var x this acc)))) 32 | 33 | (deftype LVar [name] 34 | MatchAny 35 | (match-any [this x acc] (if (= this x) acc 36 | (bind-vars x this acc))) 37 | MatchVar 38 | (match-var [x this acc] (match-any x this acc)) 39 | MatchSeq 40 | (match-seq [x this acc] (when ((every-pred sequential? seq) (acc x)) 41 | (match-any this (acc x) acc))) 42 | Object 43 | (hashCode [this] (if name (.hashCode name) 0)) 44 | (equals [this o] (and (instance? LVar o) (= (.name this) (.name ^LVar o))))) 45 | 46 | (defmethod print-method LVar [o ^Writer w] 47 | (.write w (str (.name o)))) 48 | 49 | (defmacro alias-macro [m a] 50 | `(doto (intern *ns* '~a (var ~m)) .setMacro)) 51 | 52 | (defn var? [x] (instance? LVar x)) 53 | 54 | (defn cons-pairs-to-seqs [x] 55 | (if (and (sequential? x) (= 3 (count x)) (= '. (second x)) 56 | ((some-fn sequential? nil?) (last x))) 57 | (cons (first x) (last x)) 58 | x)) 59 | 60 | (defmacro unify [u v s] 61 | (let [[u v] (map #(prepare-matcher % &env) [u v])] 62 | `(binding [*match-var?* var?] 63 | (merge (match-any ~u ~v ~s) (match-any ~v ~u ~s))))) 64 | 65 | (def ^:private subscripts '[₀ ₁ ₂ ₃ ₄ ₅ ₆ ₇ ₈ ₉]) 66 | 67 | (defn reify-name [n] 68 | (symbol (apply str "–" (map (comp subscripts int bigdec str) (str n))))) 69 | 70 | (defn reify [v s] 71 | (loop [v v s s check #{v}] 72 | (let [v' (postwalk-replace s v)] 73 | (debug v') 74 | (if (contains? check v') 75 | v' 76 | (recur v' s (conj check v')))))) 77 | 78 | (defmacro ≡ [u v] 79 | `(fn ≡ [a#] 80 | [(unify ~u ~v a#)])) 81 | (alias-macro ≡ ==) 82 | 83 | (defmacro ≠ [u v] 84 | `(fn ≠ [a#] 85 | [(when-not (seq (select-keys (unify ~u ~v a#) (keys a#))) a#)])) 86 | (alias-macro ≠ !=) 87 | 88 | (defn interleave-all [& colls] 89 | (when-let [ss (seq (remove nil? (map seq colls)))] 90 | (concat (map first ss) (lazy-seq (apply interleave-all (map rest ss)))))) 91 | 92 | (defmacro condᵉ [& gs] 93 | (let [a (gensym "a")] 94 | `(fn condᵉ [~a] 95 | (interleave-all ~@(map #(do `(run-internal ~(vec %) [~a])) gs))))) 96 | (alias-macro condᵉ conde) 97 | 98 | (defmacro fresh [[& x] & gs] 99 | `(let [~@(mapcat (fn [x] `[~x (LVar. (gensym '~x))]) x)] 100 | [~@gs])) 101 | 102 | (defmacro project [[& x] & gs] 103 | (let [a (gensym "a")] 104 | `(fn project [~a] 105 | (let [~@(mapcat (fn [x] `[~x (~a ~x)]) x)] 106 | (run-internal ~(vec gs) [~a]))))) 107 | 108 | (defn run-internal [gs s] 109 | (lazy-seq 110 | (let [[g & gs] (flatten gs) 111 | s (remove nil? s)] 112 | (if-not g 113 | s 114 | (mapcat #(when-let [s (g %)] 115 | (concat (run-internal gs [(first s)]) 116 | (run-internal gs (rest s)))) s))))) 117 | 118 | (defn reify-goal [xs s] 119 | (let [xs (map #(reify % s) xs) 120 | vs (loop [[v & vs] (distinct (filter-walk var? xs)) 121 | acc {}] 122 | (if-not v 123 | acc 124 | (recur vs (assoc acc v (or (acc (s v)) (reify-name (count acc)))))))] 125 | (postwalk cons-pairs-to-seqs (postwalk-replace vs xs)))) 126 | 127 | (defmacro run* [[& x] & g] 128 | (let [g (postwalk-replace {'_ '(mimir.mk.LVar. (gensym '_))} g)] 129 | `(binding [*match-var?* var?] 130 | (run-internal (fresh [~@x] ~@g (partial reify-goal ~(vec x))) [{}])))) 131 | 132 | (defmacro run [n [& x] & g] 133 | `(take ~n (run* [~@x] ~@g))) 134 | 135 | (def succeed (≡ false false)) 136 | (def fail (≡ false true)) 137 | 138 | (defn consᵒ [a d l] 139 | (if (var? l) 140 | (let [d (if (var? d) ['. d] d)] 141 | (≡ (cons a d) l)) 142 | [(≡ a (first l)) 143 | (≡ d (rest l))])) 144 | 145 | (defn firstᵒ [l a] 146 | (fresh [d] 147 | (consᵒ a d l))) 148 | 149 | (defn restᵒ [l d] 150 | (fresh [a] 151 | (consᵒ a d l))) 152 | 153 | (defn memberᵒ [x ls] 154 | (fresh [a d] 155 | (consᵒ a d ls) 156 | (condᵉ 157 | ((≡ a x)) 158 | ((memberᵒ x d))))) 159 | 160 | (defn appendᵒ [l1 l2 o] 161 | (condᵉ 162 | ((≡ l1 ()) (≡ l2 o)) 163 | ((fresh [a d r] 164 | (consᵒ a d l1) 165 | (consᵒ a r o) 166 | (appendᵒ d l2 r))))) 167 | -------------------------------------------------------------------------------- /src/mimir/match.clj: -------------------------------------------------------------------------------- 1 | (ns mimir.match 2 | (:use [clojure.set :only (intersection map-invert rename-keys difference union join)] 3 | [clojure.tools.logging :only (debug info warn error spy enabled?)] 4 | [clojure.walk :only (postwalk prewalk walk postwalk-replace)]) 5 | (:import [java.util.regex Pattern] 6 | [clojure.lang IPersistentMap IPersistentSet Sequential Symbol Fn Keyword])) 7 | 8 | (defprotocol MatchAny (match-any [this x acc])) 9 | (defprotocol MatchMap (match-map [this x acc])) 10 | (defprotocol MatchSeq (match-seq [this x acc])) 11 | 12 | (defn filter-walk 13 | [pred coll] 14 | (let [acc (transient [])] 15 | (postwalk #(when (pred %) (conj! acc %)) coll) 16 | (distinct (persistent! acc)))) 17 | 18 | (defn singleton-coll? [x] 19 | (and (coll? (first x)) (not (next x)))) 20 | 21 | (defn maybe-singleton-coll [x] 22 | (if (singleton-coll? x) (first x) x)) 23 | 24 | (def default-match-var? #(and (symbol? %) 25 | (not (or (resolve %) ('#{do fn* let* if} %) 26 | (re-matches #".*/.*"(str %)) (re-matches #"\..*"(name %)) 27 | (re-matches #".*\."(name %)) (re-matches #".*#"(name %)))))) 28 | (def ^:dynamic *match-var?* default-match-var?) 29 | 30 | (def ^:dynamic *var-symbol* symbol) 31 | 32 | (defn bind-vars [x pattern acc] 33 | (if-let [var (if (*match-var?* pattern) 34 | pattern 35 | (-> pattern meta :tag))] 36 | (if (contains? acc var) 37 | (let [v (acc var)] 38 | (if-not (= v var) 39 | (if (= (acc v) var) 40 | (assoc acc var x) 41 | (match-any v x acc)) 42 | acc)) 43 | (assoc acc var x)) 44 | acc)) 45 | 46 | (defn preserve-meta [form meta] 47 | (if (and (instance? clojure.lang.IMeta form) 48 | (not (and (list? form) 49 | (= 'quote (first form)) 50 | (symbol (second form))))) 51 | (list 'if (list 'instance? 'clojure.lang.IMeta form) 52 | (list 'with-meta form (list 'quote meta)) 53 | form) 54 | form)) 55 | 56 | (defn meta-walk [form] 57 | (let [m (dissoc (meta form) :line)] 58 | (if (seq m) 59 | (preserve-meta (walk meta-walk identity form) m) 60 | (if (*match-var?* form) 61 | (list 'quote form) 62 | (walk meta-walk identity form))))) 63 | 64 | (defn bound-vars [x] 65 | (let [vars (transient []) 66 | var-walk (fn this [form] 67 | (let [v (or (-> form meta :tag) form)] 68 | (when (*match-var?* v) 69 | (conj! vars v))) 70 | form)] 71 | (prewalk var-walk x) 72 | (distinct (persistent! vars)))) 73 | 74 | (defn regex-vars [x] 75 | (let [vars (transient []) 76 | regex-walk (fn this [form] 77 | (when (instance? Pattern form) 78 | (reduce conj! vars 79 | (map (comp symbol second) 80 | (re-seq #"\(\?<(.+?)>.*?\)" (str form))))) 81 | form)] 82 | (postwalk regex-walk x) 83 | (distinct (persistent! vars)))) 84 | 85 | (extend-type Object 86 | MatchAny (match-any [this x acc] (when (= this x) acc)) 87 | MatchMap (match-map [this x acc]) 88 | MatchSeq (match-seq [this x acc])) 89 | 90 | (extend-type nil 91 | MatchAny (match-any [this x acc] (when (nil? x) acc)) 92 | MatchMap (match-map [this x acc]) 93 | MatchSeq (match-seq [this x acc] (when-not (seq x) acc))) 94 | 95 | (extend-type IPersistentMap 96 | MatchAny 97 | (match-any [this x acc] (match-map x this acc)) 98 | MatchMap 99 | (match-map [x this acc] (loop [[k & ks] (keys this) 100 | acc acc] 101 | (if-not k 102 | (bind-vars x this acc) 103 | (when (contains? x k) 104 | (when-let [acc (match-any (this k) (x k) acc)] 105 | (recur ks (bind-vars (x k) (this k) acc)))))))) 106 | 107 | (extend-type Symbol 108 | MatchAny 109 | (match-any [this x acc] (if (*match-var?* this) 110 | (bind-vars x this acc) 111 | (when (= this x) acc)))) 112 | 113 | (extend-type Pattern 114 | MatchAny 115 | (match-any [this x acc] (let [re (re-matcher this (str x)) 116 | groups (regex-vars this)] 117 | (when (.matches re) 118 | (reduce #(assoc % (*var-symbol* %2) 119 | (.group re (str %2))) 120 | acc groups))))) 121 | 122 | (extend-type Class 123 | MatchAny 124 | (match-any [this x acc] (when (instance? this x) acc))) 125 | 126 | (extend-type Fn 127 | MatchAny 128 | (match-any [this x acc] (when (try (this x) (catch RuntimeException _)) 129 | (bind-vars x this acc)))) 130 | 131 | (extend-type Keyword 132 | MatchAny 133 | (match-any [this x acc] (when (or (and (coll? x) 134 | (contains? x this)) 135 | (= x this)) 136 | (bind-vars x this acc))) 137 | 138 | MatchMap 139 | (match-map [this x acc] (when (contains? x this) 140 | (bind-vars x this acc)))) 141 | 142 | (extend-type IPersistentSet 143 | MatchAny 144 | (match-any [this x acc] (loop [[k & ks] (seq this) 145 | acc acc] 146 | (when k 147 | (if-let [acc (match-any k x acc)] 148 | (bind-vars x this acc) 149 | (recur ks acc)))))) 150 | 151 | (def rest? '#{& .}) 152 | 153 | (extend-type Sequential 154 | MatchAny 155 | (match-any [this x acc] (match-seq x this acc)) 156 | MatchSeq 157 | (match-seq [x this acc] (loop [[p & ps] this 158 | [y & ys] x 159 | acc acc] 160 | (if (rest? y) 161 | (when (rest? p) (recur ps ys acc)) 162 | (if (and (not p) (not y)) 163 | (bind-vars x this acc) 164 | (if (rest? p) 165 | (let [rst (when y (vec (cons y ys)))] 166 | (when-let [acc (if (*match-var?* (first ps)) 167 | acc 168 | (match-seq rst (repeat (count rst) 169 | (first ps)) acc))] 170 | (bind-vars (or rst ()) (first ps) acc))) 171 | (when-let [acc (match-any p y acc)] 172 | (recur ps ys (bind-vars y p acc))))))))) 173 | 174 | (defn truth [& _] true) 175 | 176 | (defn unquote-vars-in-scope [&env form] 177 | (if &env 178 | (postwalk #(if (and (list? %) 179 | (= 'quote (first %)) 180 | (&env (second %))) 181 | (second %) %) form) 182 | form)) 183 | 184 | (defn prepare-matcher [m &env] 185 | (->> (preserve-meta (walk identity meta-walk m) (meta m)) 186 | (postwalk-replace {'_ truth :else truth '. ''.}) 187 | (unquote-vars-in-scope &env))) 188 | 189 | (defn match* [x pattern] (match-any pattern x {})) 190 | 191 | (defmacro match [x m] 192 | `(match* ~x ~(prepare-matcher m &env))) 193 | 194 | (defn all-vars [lhs] 195 | (vec (concat (bound-vars lhs) 196 | (map *var-symbol* (regex-vars lhs))))) 197 | 198 | (defmacro condm* [match-var [lhs rhs & ms]] 199 | `(if-let [{:syms ~(remove (set (keys &env)) (all-vars lhs))} 200 | (mimir.match/match ~match-var ~lhs)] 201 | ~rhs 202 | ~(when ms 203 | `(condm* ~match-var ~ms)))) 204 | 205 | (defmacro condm [x & ms] 206 | (let [match-var (if-let [v (-> x meta :tag)] v '*match*)] 207 | `(let [~match-var ~(if (and (instance? clojure.lang.IMeta x) 208 | (not (and (list? x) 209 | (= 'quote (first x)) 210 | (symbol? (second x))))) 211 | (with-meta x {}) 212 | x)] 213 | (condm* ~match-var ~ms)))) 214 | 215 | (defn single-arg? [ms] 216 | (not-any? coll? (take-nth 2 ms))) 217 | 218 | (defmacro fm [& ms] 219 | `(fn ~'this [& ~'args] 220 | (condm (if ~(single-arg? ms) (first ~'args) ~'args) ~@ms))) 221 | 222 | (defmacro defm [name args & ms] 223 | (let [[doc ms] (split-with string? ms) 224 | [_ _ [match-var & _ ]] (partition-by '#{&} args)] 225 | `(do 226 | (defn ~name ~args 227 | ~(when (seq ms) 228 | `(condm ~(list 'first (if (single-arg? ms) 229 | (list 'first match-var) 230 | match-var)) ~@ms))) 231 | (alter-meta! (var ~name) merge {:doc (apply str ~doc)}) 232 | ~name))) 233 | -------------------------------------------------------------------------------- /test/mimir/test/mk.clj: -------------------------------------------------------------------------------- 1 | (ns mimir.test.mk 2 | (:use [mimir.mk] 3 | [mimir.match :only (*match-var?*)] 4 | [clojure.test]) 5 | (:refer-clojure :exclude [reify var? ==])) 6 | 7 | ;; Mess of compile time and runtime requires this atm: 8 | (def mv *match-var?*) 9 | (alter-var-root #'*match-var?* (constantly var?)) 10 | 11 | (deftest ^:mk introduction-to-core-minikanren 12 | (are [a _ e] (is (= a e)) 13 | 14 | (run 1 [q] 15 | (fresh [x y z] 16 | (≡ x z) 17 | (≡ 3 y))) ⇒ '(–₀) 18 | 19 | (run 1 [y] 20 | (fresh [x z] 21 | (≡ x z) 22 | (≡ 3 y))) ⇒ '(3) 23 | 24 | (run 1 [q] 25 | (fresh [x z] 26 | (≡ x z) 27 | (≡ 3 z) 28 | (≡ q x))) ⇒ '(3) 29 | 30 | (run 1 [y] 31 | (fresh [x y] 32 | (≡ 4 x) 33 | (≡ x y)) 34 | (≡ 3 y)) ⇒ '(3) 35 | 36 | (run 1 [y] 37 | (≡ 3 4)) ⇒ () 38 | 39 | (run 2 [q] 40 | (fresh [x y z] 41 | (condᵉ 42 | ((≡ [x y z x] q)) 43 | ((≡ [z y x z] q))))) 44 | ⇒ '((–₀ –₁ –₂ –₀) (–₀ –₁ –₂ –₀))) 45 | 46 | ;; StackOverflow when compiling using are, something about symbols 47 | (is (= '((a 1 d) (b 2 e) (c 3 f)) 48 | (run 5 [q] 49 | (fresh [x y z] 50 | (condᵉ 51 | ((≡ 'a x) (≡ 1 y) (≡ 'd z)) 52 | ((≡ 2 y) (≡ 'b x) (≡ 'e z)) 53 | ((≡ 'f z) (≡ 'c x) (≡ 3 y))) 54 | (≡ [x y z] q))))) 55 | 56 | (defn anyᵒ [g] 57 | (condᵉ 58 | (g) 59 | ((anyᵒ g)))) 60 | 61 | (def alwaysᵒ (anyᵒ succeed)) 62 | (def neverᵒ (anyᵒ fail)) 63 | 64 | (are [a _ e] (is (= a e)) 65 | 66 | (run 5 [q] 67 | (condᵉ 68 | ((anyᵒ (≡ false q))) 69 | ((≡ true q)))) 70 | ⇒ '(false true false false false) 71 | 72 | ;; Does order matter? Returns nested interleave: (1 1 2 1 3 2 1 3 2 1) 73 | ;; (run 10 [q] 74 | ;; (anyᵒ 75 | ;; (condᵉ 76 | ;; ((≡ 1 q)) 77 | ;; ((≡ 2 q)) 78 | ;; ((≡ 3 q))))) 79 | ;; ⇒ '(1 2 3 1 2 3 1 2 3 1) 80 | 81 | 82 | ;; StackOverflow 83 | ;; (run 5 [x] 84 | ;; (condᵉ 85 | ;; ((≡ true x)) 86 | ;; ((≡ false x))) 87 | ;; alwaysᵒ 88 | ;; (≡ false x)) 89 | ;; ⇒ '(false false false false false) 90 | 91 | ;; (run 3 [q] 92 | ;; (condᵉ 93 | ;; ((≡ 1 q)) 94 | ;; (neverᵒ) 95 | ;; ((condᵉ 96 | ;; ((≡ 2 q)) 97 | ;; (neverᵒ) 98 | ;; ((≡ 3 q)))))) 99 | ;; ⇒ '(1 2 3) 100 | 101 | (run* [q] 102 | (fresh [x] 103 | (≡ 5 x) 104 | (project [x] 105 | (≡ (* x x) q)))) 106 | ⇒ '(25))) 107 | 108 | (deftest ^:mk unification 109 | (are [a _ e] (is (= a e)) 110 | 111 | (run* [q] 112 | (≡ 5 5)) ⇒ '(–₀) 113 | 114 | (run* [q] 115 | (≡ 5 4)) ⇒ () 116 | 117 | (run* [q] 118 | (≡ 5 q) 119 | (≡ 5 q)) ⇒ '(5) 120 | 121 | (run* [q] 122 | (≡ 5 q) 123 | (≡ 4 q)) ⇒ () 124 | 125 | ;; works, but not in suite with *match-var*? mess 126 | ;; (run* [q] 127 | ;; (fresh [x y] 128 | ;; (≡ [x 2] [1 y]) 129 | ;; (≡ q [x y]))) 130 | ;; ⇒ '([1 2]) 131 | 132 | (run* [q] 133 | (fresh [x y] 134 | (≡ x y) 135 | (≡ q [x y]))) 136 | ⇒ '([–₀ –₀]) 137 | 138 | (run* [q] 139 | (fresh [x y] 140 | (≡ x y) 141 | (≡ y 1) 142 | (≡ q [x y]))) 143 | ⇒ '([1 1]))) 144 | 145 | (deftest ^:mk consᵒ-the-magnificent 146 | (are [a _ e] (is (= a e)) 147 | 148 | (run* [q] 149 | (consᵒ 1 [2 3] q)) 150 | ⇒ '((1 2 3)) 151 | 152 | (run* [q] 153 | (consᵒ 1 q [1 2 3])) 154 | ⇒ '((2 3)) 155 | 156 | (run* [q] 157 | (consᵒ q [2 3] [1 2 3])) 158 | ⇒ '(1) 159 | 160 | (run* [q] 161 | (consᵒ 1 [2 q] [1 2 3])) 162 | ⇒ '(3) 163 | 164 | (run* [q w] 165 | (consᵒ q w [1 2 3])) 166 | ⇒ '(1 (2 3)) 167 | 168 | (run* [q w z] 169 | (consᵒ q w z)) 170 | ⇒ '(–₀ –₁ (–₀ . –₁)) 171 | 172 | (run* [q w z] 173 | (consᵒ q w z) 174 | (≡ q 1)) 175 | ⇒ '(1 –₀ (1 . –₀)) 176 | 177 | (run* [q w z] 178 | (consᵒ q w z) 179 | (firstᵒ z 1)) 180 | ⇒ '(1 –₀ (1 . –₀)) 181 | 182 | (run* [q w z] 183 | (consᵒ q w z) 184 | (≡ w [2 3])) 185 | ⇒ '(–₀ (2 3) (–₀ 2 3)) 186 | 187 | (run* [q w z] 188 | (consᵒ q w z) 189 | (restᵒ z [2 3])) 190 | ⇒ '(–₀ (2 3) (–₀ 2 3)) 191 | 192 | (run* [q] 193 | (restᵒ [1 2 3 4] q)) 194 | ⇒ '((2 3 4)) 195 | 196 | (run* [q] 197 | (restᵒ q [2 3 4])) 198 | ⇒ '((–₀ 2 3 4)) 199 | 200 | (run* [q] 201 | (firstᵒ [1 2 3 4] q)) 202 | ⇒ '(1) 203 | 204 | (run* [q] 205 | (firstᵒ q 1)) 206 | ⇒ '((1 . –₀)) 207 | 208 | (run* [q] 209 | (consᵒ 1 [2 3] q) 210 | (firstᵒ q 1) 211 | (restᵒ q [2 3])) 212 | ⇒ '((1 2 3)) 213 | 214 | (run* [q] 215 | (consᵒ 1 [2 3] q) 216 | (firstᵒ q 0)) 217 | ⇒ '() 218 | 219 | (run* [q] 220 | (consᵒ 1 [2 3] q) 221 | (restᵒ q [0])) 222 | ⇒ '() 223 | 224 | (run* [x q] 225 | (consᵒ x [2 3] q) 226 | (firstᵒ q x)) 227 | ⇒ '(–₀ (–₀ 2 3)) 228 | 229 | (run* [x q] 230 | (consᵒ 1 x q) 231 | (restᵒ q x)) 232 | ⇒ '(–₀ (1 . –₀)))) 233 | 234 | (deftest ^:mk memberᵒ-the-divergent 235 | (are [a _ e] (is (= a e)) 236 | 237 | (run* [q] 238 | (memberᵒ q [1 2 3])) 239 | ⇒ '(1 2 3) 240 | 241 | (run* [q] 242 | (memberᵒ 7 [1 3 8 q])) 243 | ⇒ '(7) 244 | 245 | (run 3 [q] 246 | (memberᵒ 3 q)) 247 | ⇒ '((3 . –₀) (–₀ 3 . –₁) (–₀ –₁ 3 . –₂)))) 248 | 249 | ;; Partly from http://objectcommando.com/blog/2011/10/13/appendo-the-great/ 250 | (deftest ^:mk appendᵒ-the-great 251 | (defn sublistᵒ [x y] 252 | (fresh [a b c] 253 | (appendᵒ a b y) 254 | (appendᵒ x c b))) 255 | 256 | (defn prefixᵒ [x y] 257 | (fresh [a] 258 | (appendᵒ x a y))) 259 | 260 | (defn lastᵒ [x y] 261 | (fresh [a] 262 | (appendᵒ a [x] y))) 263 | 264 | (are [a _ e] (is (= a e)) 265 | 266 | (run* [q] 267 | (appendᵒ '(1 2 3) '(4 5) q)) 268 | ⇒ '((1 2 3 4 5)) 269 | 270 | (run* [q] 271 | (appendᵒ [1 2] [3 4] q)) 272 | ⇒ '((1 2 3 4)) 273 | 274 | (run* [q] 275 | (appendᵒ [1 2] q [1 2 3 4])) 276 | ⇒ '((3 4)) 277 | 278 | (run* [q] 279 | (appendᵒ q [3 4] [1 2 3 4])) 280 | ⇒ '((1 2)) 281 | 282 | (run* [w q] 283 | (appendᵒ w q [1 2 3 4])) 284 | ⇒ '(() (1 2 3 4) 285 | (1) (2 3 4) 286 | (1 2) (3 4) 287 | (1 2 3) (4) 288 | (1 2 3 4) ()) 289 | 290 | (run* [q] 291 | (prefixᵒ [1 2 3] q)) 292 | ⇒ '((1 2 3 . –₀)) 293 | 294 | ;; StackOverflow 295 | ;; (run 3 [q] 296 | ;; (lastᵒ "Hail to the king baby" q) 297 | ;; (prefixᵒ [1 2 3] q)) 298 | ;; ⇒ '((1 2 3 "Hail to the king baby") 299 | ;; (1 2 3 –₀ "Hail to the king baby") 300 | ;; (1 2 3 –₀ –₁ "Hail to the king baby")) 301 | 302 | ;; Only returns prefixed lists 303 | ;; (set (run* [q] 304 | ;; (sublistᵒ q [1 2 3 4 5]))) 305 | ;; ⇒ '#{() (1) (2) (1 2 3) (2 3) (3) (3 4) (4 5) (2 3 4) 306 | ;; (1 2 3 4 5) (1 2) (2 3 4 5) (4) (3 4 5) (1 2 3 4) (5)} 307 | )) 308 | 309 | (deftest ^:mk anonymous-vars 310 | (is (= (run* [q] (≡ q _)) '(–₀)))) 311 | 312 | ;; From https://github.com/swannodette/logic-tutorial 313 | (deftest ^:mk zebra 314 | (defn rightᵒ [x y l] 315 | (condᵉ 316 | ((prefixᵒ [x y] l)) 317 | ((fresh [d] 318 | (restᵒ l d) 319 | (rightᵒ x y d))))) 320 | 321 | (defn nextᵒ [x y l] 322 | (condᵉ 323 | ((rightᵒ x y l)) 324 | ((rightᵒ y x l)))) 325 | 326 | (are [a _ e] (is (= a e)) 327 | 328 | (run* [q] 329 | (rightᵒ 1 2 [1 2])) 330 | ⇒ '(–₀) 331 | 332 | (run* [q] 333 | (rightᵒ 1 2 [0 1 2 3])) 334 | ⇒ '(–₀) 335 | 336 | (run* [q] 337 | (rightᵒ 1 2 [1])) 338 | ⇒ '() 339 | 340 | (run* [q] 341 | (rightᵒ 1 2 [0 1 3 2 3])) 342 | ⇒ '() 343 | 344 | (run* [q] 345 | (nextᵒ 1 2 [3 2 1])) 346 | ⇒ '(–₀) 347 | 348 | (run* [q] 349 | (nextᵒ 1 2 [1 3 2])) 350 | ⇒ '()) 351 | 352 | ;; Doesn't run yet, small subsets "work". 353 | ;; (is (= (run 1 [hs] 354 | ;; (≡ [_ _ [_ _ 'milk _ _] _ _] hs) 355 | ;; (firstᵒ hs ['norwegian _ _ _ _]) 356 | ;; (nextᵒ ['norwegian _ _ _ _] [_ _ _ _ 'blue] hs) 357 | ;; (rightᵒ [_ _ _ _ 'ivory] [_ _ _ _ 'green] hs) 358 | ;; (memberᵒ ['englishman _ _ _ 'red] hs) 359 | ;; (memberᵒ [_ 'kools _ _ 'yellow] hs) 360 | ;; (memberᵒ ['spaniard _ _ 'dog _] hs) 361 | ;; (memberᵒ [_ _ 'coffee _ 'green] hs) 362 | ;; (memberᵒ ['ukrainian _ 'tea _ _] hs) 363 | ;; (memberᵒ [_ 'lucky-strikes 'oj _ _] hs) 364 | ;; (memberᵒ ['japanese 'parliaments _ _ _] hs) 365 | ;; (memberᵒ [_ 'oldgolds _ 'snails _] hs) 366 | ;; (nextᵒ [_ _ _ 'horse _] [_ 'kools _ _ _] hs) 367 | ;; (nextᵒ [_ _ _ 'fox _] [_ 'chesterfields _ _ _] hs)) 368 | 369 | ;; '([[norwegian kools –₀ fox yellow] 370 | ;; [ukrainian chesterfields tea horse blue] 371 | ;; [englishman oldgolds milk snails red] 372 | ;; [spaniard lucky-strikes oj dog ivory] 373 | ;; [japanese parliaments coffee –₁ green]]))) 374 | ) 375 | 376 | (alter-var-root #'*match-var?* (constantly mv)) -------------------------------------------------------------------------------- /src/mimir/parse.clj: -------------------------------------------------------------------------------- 1 | (ns mimir.parse 2 | (:require [clojure.core.reducers :as r] 3 | [clojure.walk :as w] 4 | [flatland.ordered.map :as om] 5 | [flatland.ordered.set :as os]) 6 | (:import [java.util.regex Pattern] 7 | [java.util Map Set List] 8 | [clojure.lang Keyword ArityException Fn] 9 | [flatland.ordered.set OrderedSet])) 10 | 11 | ;; Mímir Parse 12 | 13 | ;; Experimental parser, this isn't built on some nice theoretical basis. 14 | ;; Inspired by the awesome Instaparse: https://github.com/Engelberg/instaparse 15 | 16 | ;; Started out as an experiment in Ced: https://github.com/hraberg/ced/ 17 | ;; This parser like the other parts of Mímir was written as a learning exercise. 18 | 19 | ;; See mimir.test.parse for examples (in various broken states). 20 | 21 | (set! *warn-on-reflection* true) 22 | 23 | (declare node maybe-singleton depth column) 24 | 25 | (def ^:private ^:dynamic *rule* nil) 26 | (def ^:private ^:dynamic *current-state* nil) 27 | (def ^:private ^:dynamic *rules-seen-at-point* #{}) 28 | 29 | (def ^:dynamic *allow-split-tokens* true) ;; Overrides post-delimiter. 30 | (def ^:dynamic *memoize* true) 31 | (def ^:dynamic *capture-literals* false) 32 | (def ^:dynamic *pre-delimiter* #"\s*") 33 | (def ^:dynamic *post-delimiter* #"(:?\s+|$)") 34 | (def ^:dynamic *first-line* 1) 35 | (def ^:dynamic *default-result* []) 36 | (def ^:dynamic *token-fn* conj) 37 | (def ^:dynamic *suppress-tags* false) 38 | (def ^:dynamic *node-fn* #'node) 39 | (def ^:dynamic *default-action* #'maybe-singleton) 40 | (def ^:dynamic *actions* {}) 41 | (def ^:dynamic *grammar-actions* true) 42 | (def ^:dynamic *alternatives-rank* #'depth) 43 | (def ^:dynamic *grammar* {}) 44 | (def ^:dynamic *failure-grammar* {:no-match [#"\S+" #(throw (IllegalStateException. 45 | (format "Don't know how to parse: '%s' at %d:%d" 46 | % (:line *current-state*) (column *current-state*))))]}) 47 | (def ^:dynamic *start-rule* first) 48 | (def ^:dynamic *extract-result* (comp first :result)) 49 | (def ^:dynamic *read-string* read-string) 50 | 51 | 52 | ;; Not sure this name is right 53 | (defn maybe-singleton 54 | ([]) 55 | ([x] x) 56 | ([x & args] (when-let [v (seq (remove nil? (cons x args)))] 57 | (vec v)))) 58 | 59 | (defn suppressed-rule? [r] 60 | (when-let [[ _ r] (re-find #"^<(.+)>$" (name r))] 61 | (keyword r))) 62 | 63 | (defn node? [x] 64 | (and (vector? x) (keyword? (first x)))) 65 | 66 | (defn node [& args] 67 | (let [args (apply maybe-singleton args)] 68 | (if (or *suppress-tags* (suppressed-rule? *rule*)) 69 | args 70 | (if (and (sequential? args) (not (node? args))) 71 | (vec (cons *rule* args)) 72 | [*rule* args])))) 73 | 74 | (defn depth [x] 75 | (if (node? x) (inc (apply max (map depth x))) 0)) 76 | 77 | (defn suppressed-defintion? [r] 78 | (let [suppressed-defintion (keyword (str "<" (name r) ">"))] 79 | (if (*grammar* suppressed-defintion) 80 | suppressed-defintion 81 | r))) 82 | 83 | (defprotocol IParser 84 | (parse [this] [this in])) 85 | 86 | (defrecord StringParser [string offset line token result] 87 | IParser 88 | (parse [this] (parse *grammar* this)) 89 | (parse [this parser] 90 | (parse parser this))) 91 | 92 | (defrecord ZeroOrMore [m] 93 | IParser 94 | (parse [this in] 95 | (loop [in in] 96 | (if-let [in (parse m in)] 97 | (recur in) 98 | in)))) 99 | 100 | (defrecord OneOrMore [m] 101 | IParser 102 | (parse [this in] 103 | (when-let [in (parse m in)] 104 | (parse (ZeroOrMore. m) in)))) 105 | 106 | (defrecord Optional [m] 107 | IParser 108 | (parse [this in] 109 | (or (parse m in) in))) 110 | 111 | (defrecord Not [m] 112 | IParser 113 | (parse [this in] 114 | (and (not (parse m in)) in))) 115 | 116 | (defrecord And [m] 117 | IParser 118 | (parse [this in] 119 | (and (parse m in) in))) 120 | 121 | ;; Not sure what to call these guys. 122 | (def take+ ->OneOrMore) 123 | (def take* ->ZeroOrMore) 124 | (def take? ->Optional) 125 | (def ! ->Not) 126 | (def & ->And) 127 | 128 | (defn string-parser 129 | ([s] (if (instance? StringParser s) s (string-parser s *default-result*))) 130 | ([s result] (StringParser. s 0 *first-line* nil result))) 131 | 132 | (defn at-end? [{:keys [string offset] :as in}] 133 | (= offset (count string))) 134 | 135 | (defn column [{:keys [string offset] :as in}] 136 | (let [eol (.lastIndexOf ^String string (int \newline) (int (dec offset)))] 137 | (if (= -1 eol) 138 | offset 139 | (dec (- offset eol))))) 140 | 141 | (defn lines [s] 142 | (count (re-seq #"\n" s))) 143 | 144 | (defn try-parse [{:keys [string offset result line] :as in} ^Pattern re] 145 | (when in 146 | (let [m (re-matcher re (subs string offset))] 147 | (when (.lookingAt m) 148 | (assoc in 149 | :offset (+ offset (.end m 0)) 150 | :line (+ line (lines (.group m 0))) 151 | :token (.group m 0)))))) 152 | 153 | (defn try-parse-skip-delimiter [in m] 154 | (when-let [{:keys [token] :as in} (if-let [result (try-parse in m)] 155 | result 156 | (-> in 157 | (try-parse *pre-delimiter*) 158 | (try-parse m)))] 159 | (when-let [in (if *allow-split-tokens* in (try-parse in *post-delimiter*))] 160 | (assoc in :token token)))) 161 | 162 | (defn next-token [in m capture?] 163 | (when-let [{:keys [token offset] :as in} (try-parse-skip-delimiter in m)] 164 | (assoc (if capture? 165 | (binding [*current-state* in] 166 | (-> in 167 | (update-in [:result] *token-fn* token))) 168 | in) :token nil))) 169 | 170 | (defn name-and-predicate [n] 171 | (let [[_ predicate n] (re-find #"^([!&]?)(.+)" (name n))] 172 | [(keyword n) (when (seq predicate) (symbol predicate))])) 173 | 174 | (defn name-and-quantifier [n] 175 | (let [[_ n quantifier] (re-find #"(.+?)([+*?]?)$" (name n))] 176 | [(keyword n) (when (seq quantifier) (symbol quantifier))])) 177 | 178 | (defn fold-into [ctor coll] 179 | (r/fold (r/monoid into ctor) conj coll)) 180 | 181 | ;; This could potentially be a tree, but requires to restructure and use reducers all over the place. 182 | (defn valid-choices [in ms] 183 | (fold-into vector (r/remove nil? (r/map #(parse % in) (vec ms))))) 184 | 185 | (extend-protocol IParser 186 | Pattern 187 | (parse [this in] 188 | (next-token in this true)) 189 | 190 | Character 191 | (parse [this in] 192 | (parse (str this) in)) 193 | 194 | String 195 | (parse 196 | ([this] (parse (string-parser this))) 197 | ([this in] 198 | (next-token in (re-pattern (Pattern/quote this)) *capture-literals*))) 199 | 200 | ;; Aim to implement left recursion (and rewrite memoize) using http://www.dcomp.ufs.br/~sergio/docs/leftpeglist.pdf 201 | ;; IronMeta contains a C# implementation of the algorithm: http://ironmeta.sourceforge.net/ 202 | Keyword 203 | (parse [this in] 204 | (when-not (*rules-seen-at-point* [this in]) ;; Only guards against StackOverflow, doesn't actually handle left recursion. 205 | (binding [*rules-seen-at-point* (conj *rules-seen-at-point* [this in])] 206 | (let [[this quantifier] (name-and-quantifier this) 207 | [this predicate] (name-and-predicate this) 208 | suppressed (suppressed-rule? this) 209 | this (suppressed-defintion? this)] 210 | (if-let [[rule action] (some *grammar* [this suppressed])] 211 | (letfn [(parse-one [in] 212 | (let [current-result (:result in)] 213 | (when-let [result (parse rule (assoc in :result *default-result*))] 214 | (binding [*rule* this 215 | *current-state* in] 216 | (update-in result [:result] 217 | #(*token-fn* current-result 218 | (*node-fn* (try 219 | (apply (or (when *grammar-actions* 220 | (or (when (contains? *actions* this) 221 | (let [action (this *actions*)] 222 | (if (fn? action) 223 | action 224 | (constantly action)))) 225 | (this *actions*) 226 | action)) 227 | *default-action*) %) 228 | (catch ArityException _ 229 | (apply *default-action* %))))))))))] 230 | (let [parser (case quantifier 231 | ? (Optional. parse-one) 232 | * (ZeroOrMore. parse-one) 233 | + (OneOrMore. parse-one) 234 | parse-one)] 235 | (parse (case predicate 236 | ! (Not. parser) 237 | & (And. parser) 238 | parser) in))) 239 | (throw (IllegalStateException. (str "Unknown rule: " this)))))))) 240 | 241 | Set 242 | (parse [this in] 243 | (when-let [alternatives (seq (distinct (valid-choices in this)))] 244 | (apply max-key :offset (sort-by *alternatives-rank* alternatives)))) 245 | 246 | OrderedSet 247 | (parse [this in] 248 | (first (valid-choices in this))) 249 | 250 | Map 251 | (parse [this in] 252 | (binding [*grammar* this] 253 | (parse (*start-rule* (os/into-ordered-set (keys this))) (string-parser in)))) 254 | 255 | List 256 | (parse [this in] 257 | (loop [in in 258 | [m & m-rst] this] 259 | (if (and in m) 260 | (recur (parse m in) m-rst) 261 | in))) 262 | 263 | Fn 264 | (parse [this in] 265 | (this in))) 266 | 267 | (def choice os/ordered-set) 268 | 269 | (defn fun [s] 270 | (resolve (symbol (str s)))) 271 | 272 | (defn op 273 | ([op x] ((fun op) x)) 274 | ([x op y] ((fun op) x y))) 275 | 276 | ;; This feels a bit clunky 277 | (defmacro dynamic-reader [] 278 | (let [locals (vec (keys &env))] 279 | `#(eval `(let [~'~locals ~~locals] 280 | ~(read-string %))))) 281 | 282 | (defn action? [x] 283 | ((some-fn fn? var?) x)) 284 | 285 | (defn rule? [r] 286 | (and (vector? r) (= 2 (count r)) (action? (last r)))) 287 | 288 | (defn grammar [& rules] 289 | (let [rules (mapcat (fn [[rs [f]]] (if f (conj (vec (butlast rs)) [(last rs) f]) rs)) 290 | (partition-all 2 (partition-by action? rules)))] 291 | (into (om/ordered-map) (map (fn [[name rule]] 292 | [name (if (rule? rule) 293 | rule 294 | [rule])]) 295 | (partition 2 rules))))) 296 | 297 | (defn parser-option [option] 298 | (letfn [(unknown-option [option] (throw (IllegalArgumentException. (str "Unknown option: " option))))] 299 | (if (keyword? option) 300 | (or (when-let [option (resolve (symbol (str "*" (name option) "*")))] 301 | (when-not (:private (meta option)) 302 | option)) 303 | (unknown-option option)) 304 | option))) 305 | 306 | (defn parser-options [options] 307 | (into {} (map (fn [[k v]] [(parser-option k) v]) options))) 308 | 309 | ;; Starts getting clunky, holding off to macrofiy it as this is not the core issue. 310 | (defn create-parser 311 | ([& rules] 312 | (let [[[default-options] rules] (split-with map? rules) 313 | default-options (parser-options default-options) 314 | grammar (apply grammar rules)] 315 | (fn parser 316 | ([in & options] 317 | (with-bindings (merge default-options (parser-options (apply hash-map options))) 318 | (let [real-parse parse] 319 | (try 320 | (when *memoize* ;; Just rebinding doesn't work for some reason 321 | (alter-var-root #'parse memoize)) 322 | (or (when-let [in (parse grammar in)] 323 | (when (at-end? in) 324 | (*extract-result* in))) 325 | (parse *failure-grammar* in)) 326 | (finally 327 | (when *memoize* 328 | (alter-var-root #'parse (constantly real-parse)))))))))))) 329 | 330 | ;; Should be folded into the above, but requires some messing about. 331 | (defn create-parser-from-map 332 | ([m] (create-parser-from-map {} m)) 333 | ([options m] 334 | (apply create-parser options (apply concat m)))) 335 | -------------------------------------------------------------------------------- /test/mimir/test/C.peg: -------------------------------------------------------------------------------- 1 | 2 | //=========================================================================== 3 | // 4 | // Parsing Expression Grammar of C for Mouse 1.1 - 1.4. 5 | // Based on standard ISO/IEC 9899.1999:TC2, without preprocessor. 6 | // Requires semantics class to process Typedefs. 7 | // 8 | //--------------------------------------------------------------------------- 9 | // 10 | // Copyright (C) 2007, 2009, 2010 by Roman R Redziejowski (www.romanredz.se). 11 | // 12 | // The author gives unlimited permission to copy and distribute 13 | // this file, with or without modifications, as long as this notice 14 | // is preserved, and any changes are properly documented. 15 | // 16 | // This file is distributed in the hope that it will be useful, 17 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 19 | // 20 | //--------------------------------------------------------------------------- 21 | // 22 | // Latest update 2010-11-19 23 | // 24 | //--------------------------------------------------------------------------- 25 | // 26 | // Modifications to the standard grammar: 27 | // 28 | // Defined # as start of line comment. 29 | // Added FunctionSpecifier "_stdcall". 30 | // Added TypeQualifier "__declspec()". 31 | // Added TypeSpecifier "__attribute__()". 32 | // The scope of TypedefNames is not implemented. 33 | // 34 | //--------------------------------------------------------------------------- 35 | // 36 | // Implementation of typedefs. 37 | // 38 | // A TypedefName is an Identifier that has been declared as such 39 | // by a previous typedef declaration. It can be used as TypeSpecifier 40 | // in DeclarationSpecifiers and SpecifierQualifierList. 41 | // Recognizing it as such is essential for correct parsing. 42 | // In other contexts, TypedefName is treated as an ordinary Identifier. 43 | // 44 | // According to 6.7.2, comment 2, of the Standard, TypedefName can appear 45 | // in DeclarationSpecifiers or SpecifierQualifierList at most once, 46 | // and then as the only TypeSpecifier. To make sure that an Identifer 47 | // is recognized as TypedefName only in these contexts, definitions 48 | // of these items are changed as follows: 49 | // 50 | // - TypedefName is removed as an alternative of TypeSpecifier. 51 | // 52 | // - DeclarationSpecifiers and SpecifierQualifierList are redefined 53 | // to allow either single TypedefName or one or more TypeSpecifiers. 54 | // 55 | // The semantics class, via semantic actions, maintains a table of TypedefNames. 56 | // 57 | // The rule defining TypedefName as Identifier has a semantic action 58 | // that returns true iff the Identifier is in the table. 59 | // That means TypedefName is accepted iff it is in the table. 60 | // 61 | // According to 6.7.7, comment 3, of the Standard, 62 | // in a Declaration whose StorageClassSpecifier is TYPEDEF, 63 | // each Declarator defines an Identifier to be a TypedefName. 64 | // These Identifiers are entered into the table as follows. 65 | // 66 | // - Each Identifier has itself as semantic value. 67 | // 68 | // - Each DirectDeclarator starts with either Identifier 69 | // or Declarator in parentheses. 70 | // Its semantic value is either that Identifier, 71 | // or the Identifier obtained as semantic value of that Declarator. 72 | // 73 | // - Each Declarator has as semantic value the Identifier 74 | // appearing in its DirectDeclarator, 75 | // 76 | // - Each InitDeclarator has as semantic value the Identifier 77 | // appearing in its Declarator. 78 | // 79 | // - InitDeclaratorList has as semantic value 80 | // the list of Identifiers appearing in its InitDeclarators. 81 | // 82 | // - DeclarationSpecifiers has semantic value "typedef" 83 | // if any of the specifiers is "typedef" or null otherwise. 84 | // 85 | // - Declaration has a semantic action that enters Identifiers 86 | // delivered by InitDeclaratorList into typedef table 87 | // if DeclarationSpecifiers indicate "typedef". 88 | // 89 | // 90 | //--------------------------------------------------------------------------- 91 | // 92 | // Change log 93 | // 2009-07-13 Posted on Internet. 94 | // 2010-11-19 Removed superfluous '?' after 'Spacing'. 95 | // 96 | //=========================================================================== 97 | 98 | //------------------------------------------------------------------------- 99 | // A.2.4 External definitions 100 | //------------------------------------------------------------------------- 101 | 102 | TranslationUnit 103 | = Spacing ExternalDeclaration+ EOT 104 | ; 105 | 106 | ExternalDeclaration 107 | = FunctionDefinition 108 | / Declaration 109 | ; 110 | 111 | FunctionDefinition 112 | = DeclarationSpecifiers Declarator DeclarationList? CompoundStatement 113 | ; 114 | 115 | DeclarationList 116 | = Declaration+ 117 | ; 118 | 119 | 120 | //------------------------------------------------------------------------- 121 | // A.2.2 Declarations 122 | //------------------------------------------------------------------------- 123 | 124 | Declaration 125 | = DeclarationSpecifiers InitDeclaratorList? SEMI {} 126 | ; 127 | 128 | DeclarationSpecifiers 129 | = (( StorageClassSpecifier 130 | / TypeQualifier 131 | / FunctionSpecifier 132 | )* 133 | TypedefName 134 | ( StorageClassSpecifier 135 | / TypeQualifier 136 | / FunctionSpecifier 137 | )* 138 | ) {DeclarationSpecifiers} 139 | / ( StorageClassSpecifier 140 | / TypeSpecifier 141 | / TypeQualifier 142 | / FunctionSpecifier 143 | )+ {DeclarationSpecifiers} 144 | ; 145 | 146 | InitDeclaratorList 147 | = InitDeclarator (COMMA InitDeclarator)* {} 148 | ; 149 | 150 | InitDeclarator 151 | = Declarator (EQU Initializer)? {} 152 | ; 153 | 154 | StorageClassSpecifier 155 | = TYPEDEF 156 | / EXTERN 157 | / STATIC 158 | / AUTO 159 | / REGISTER 160 | / ATTRIBUTE LPAR LPAR (!RPAR _)* RPAR RPAR 161 | ; 162 | 163 | TypeSpecifier 164 | = VOID 165 | / CHAR 166 | / SHORT 167 | / INT 168 | / LONG 169 | / FLOAT 170 | / DOUBLE 171 | / SIGNED 172 | / UNSIGNED 173 | / BOOL 174 | / COMPLEX 175 | / StructOrUnionSpecifier 176 | / EnumSpecifier 177 | ; 178 | 179 | StructOrUnionSpecifier 180 | = StructOrUnion 181 | ( Identifier? LWING StructDeclaration+ RWING 182 | / Identifier 183 | ) 184 | ; 185 | 186 | StructOrUnion 187 | = STRUCT 188 | / UNION 189 | ; 190 | 191 | StructDeclaration 192 | = SpecifierQualifierList StructDeclaratorList SEMI 193 | ; 194 | 195 | SpecifierQualifierList 196 | = ( TypeQualifier* 197 | TypedefName 198 | TypeQualifier* 199 | ) 200 | / ( TypeSpecifier 201 | / TypeQualifier 202 | )+ 203 | ; 204 | 205 | StructDeclaratorList 206 | = StructDeclarator (COMMA StructDeclarator)* 207 | ; 208 | 209 | StructDeclarator 210 | = Declarator? COLON ConstantExpression 211 | / Declarator 212 | ; 213 | 214 | EnumSpecifier 215 | = ENUM 216 | ( Identifier? LWING EnumeratorList COMMA? RWING 217 | / Identifier 218 | ) 219 | ; 220 | 221 | EnumeratorList 222 | = Enumerator (COMMA Enumerator)* 223 | ; 224 | 225 | Enumerator 226 | = EnumerationConstant (EQU ConstantExpression)? 227 | ; 228 | 229 | TypeQualifier 230 | = CONST 231 | / RESTRICT 232 | / VOLATILE 233 | / DECLSPEC LPAR Identifier RPAR 234 | ; 235 | 236 | FunctionSpecifier 237 | = INLINE 238 | / STDCALL 239 | ; 240 | 241 | Declarator 242 | = Pointer? DirectDeclarator {} 243 | ; 244 | 245 | DirectDeclarator 246 | = ( Identifier 247 | / LPAR Declarator RPAR 248 | ) 249 | ( LBRK TypeQualifier* AssignmentExpression? RBRK 250 | / LBRK STATIC TypeQualifier* AssignmentExpression RBRK 251 | / LBRK TypeQualifier+ STATIC AssignmentExpression RBRK 252 | / LBRK TypeQualifier* STAR RBRK 253 | / LPAR ParameterTypeList RPAR 254 | / LPAR IdentifierList? RPAR 255 | )* {} 256 | ; 257 | 258 | Pointer 259 | = ( STAR TypeQualifier* )+ 260 | ; 261 | 262 | ParameterTypeList 263 | = ParameterList (COMMA ELLIPSIS)? 264 | ; 265 | 266 | ParameterList 267 | = ParameterDeclaration (COMMA ParameterDeclaration)* 268 | ; 269 | 270 | ParameterDeclaration 271 | = DeclarationSpecifiers 272 | ( Declarator 273 | / AbstractDeclarator 274 | )? 275 | ; 276 | 277 | IdentifierList 278 | = Identifier (COMMA Identifier)* 279 | ; 280 | 281 | TypeName 282 | = SpecifierQualifierList AbstractDeclarator? 283 | ; 284 | 285 | AbstractDeclarator 286 | = Pointer? DirectAbstractDeclarator 287 | / Pointer 288 | ; 289 | 290 | DirectAbstractDeclarator 291 | = ( LPAR AbstractDeclarator RPAR 292 | / LBRK (AssignmentExpression / STAR)? RBRK 293 | / LPAR ParameterTypeList? RPAR 294 | ) 295 | ( LBRK (AssignmentExpression / STAR)? RBRK 296 | / LPAR ParameterTypeList? RPAR 297 | )* 298 | ; 299 | 300 | TypedefName 301 | = Identifier {&TypedefName} 302 | ; 303 | 304 | Initializer 305 | = AssignmentExpression 306 | / LWING InitializerList COMMA? RWING 307 | ; 308 | 309 | InitializerList 310 | = Designation? Initializer (COMMA Designation? Initializer)* 311 | ; 312 | 313 | Designation 314 | = Designator+ EQU 315 | ; 316 | 317 | Designator 318 | = LBRK ConstantExpression RBRK 319 | / DOT Identifier 320 | ; 321 | 322 | 323 | //------------------------------------------------------------------------- 324 | // A.2.3 Statements 325 | //------------------------------------------------------------------------- 326 | 327 | Statement 328 | = LabeledStatement 329 | / CompoundStatement 330 | / ExpressionStatement 331 | / SelectionStatement 332 | / IterationStatement 333 | / JumpStatement 334 | ; 335 | 336 | LabeledStatement 337 | = Identifier COLON Statement 338 | / CASE ConstantExpression COLON Statement 339 | / DEFAULT COLON Statement 340 | ; 341 | 342 | CompoundStatement 343 | = LWING ( Declaration / Statement )* RWING 344 | ; 345 | 346 | ExpressionStatement 347 | = Expression? SEMI 348 | ; 349 | 350 | SelectionStatement 351 | = IF LPAR Expression RPAR Statement (ELSE Statement)? 352 | / SWITCH LPAR Expression RPAR Statement 353 | ; 354 | 355 | IterationStatement 356 | = WHILE LPAR Expression RPAR Statement 357 | / DO Statement WHILE LPAR Expression RPAR SEMI 358 | / FOR LPAR Expression? SEMI Expression? SEMI Expression? RPAR Statement 359 | / FOR LPAR Declaration Expression? SEMI Expression? RPAR Statement 360 | ; 361 | 362 | JumpStatement 363 | = GOTO Identifier SEMI 364 | / CONTINUE SEMI 365 | / BREAK SEMI 366 | / RETURN Expression? SEMI 367 | ; 368 | 369 | 370 | //------------------------------------------------------------------------- 371 | // A.2.1 Expressions 372 | //------------------------------------------------------------------------- 373 | 374 | PrimaryExpression 375 | = Identifier 376 | / Constant 377 | / StringLiteral 378 | / LPAR Expression RPAR 379 | ; 380 | 381 | PostfixExpression 382 | = ( PrimaryExpression 383 | / LPAR TypeName RPAR LWING InitializerList COMMA? RWING 384 | ) 385 | ( LBRK Expression RBRK 386 | / LPAR ArgumentExpressionList? RPAR 387 | / DOT Identifier 388 | / PTR Identifier 389 | / INC 390 | / DEC 391 | )* 392 | ; 393 | 394 | ArgumentExpressionList 395 | = AssignmentExpression (COMMA AssignmentExpression)* 396 | ; 397 | 398 | UnaryExpression 399 | = PostfixExpression 400 | / INC UnaryExpression 401 | / DEC UnaryExpression 402 | / UnaryOperator CastExpression 403 | / SIZEOF (UnaryExpression / LPAR TypeName RPAR ) 404 | ; 405 | 406 | UnaryOperator 407 | = AND 408 | / STAR 409 | / PLUS 410 | / MINUS 411 | / TILDA 412 | / BANG 413 | ; 414 | 415 | CastExpression 416 | = (LPAR TypeName RPAR)* UnaryExpression 417 | ; 418 | 419 | MultiplicativeExpression 420 | = CastExpression ((STAR / DIV / MOD) CastExpression)* 421 | ; 422 | 423 | AdditiveExpression 424 | = MultiplicativeExpression ((PLUS / MINUS) MultiplicativeExpression)* 425 | ; 426 | 427 | ShiftExpression 428 | = AdditiveExpression ((LEFT / RIGHT) AdditiveExpression)* 429 | ; 430 | 431 | RelationalExpression 432 | = ShiftExpression ((LE / GE / LT / GT) ShiftExpression)* 433 | ; 434 | 435 | EqualityExpression 436 | = RelationalExpression ((EQUEQU / BANGEQU) RelationalExpression)* 437 | ; 438 | 439 | ANDExpression 440 | = EqualityExpression (AND EqualityExpression)* 441 | ; 442 | 443 | ExclusiveORExpression 444 | = ANDExpression (HAT ANDExpression)* 445 | ; 446 | 447 | InclusiveORExpression 448 | = ExclusiveORExpression (OR ExclusiveORExpression)* 449 | ; 450 | 451 | LogicalANDExpression 452 | = InclusiveORExpression (ANDAND InclusiveORExpression)* 453 | ; 454 | 455 | LogicalORExpression 456 | = LogicalANDExpression (OROR LogicalANDExpression)* 457 | ; 458 | 459 | ConditionalExpression 460 | = LogicalORExpression (QUERY Expression COLON LogicalORExpression)* 461 | ; 462 | 463 | AssignmentExpression 464 | = UnaryExpression AssignmentOperator AssignmentExpression 465 | / ConditionalExpression 466 | ; 467 | 468 | AssignmentOperator 469 | = EQU 470 | / STAREQU 471 | / DIVEQU 472 | / MODEQU 473 | / PLUSEQU 474 | / MINUSEQU 475 | / LEFTEQU 476 | / RIGHTEQU 477 | / ANDEQU 478 | / HATEQU 479 | / OREQU 480 | ; 481 | 482 | Expression 483 | = AssignmentExpression (COMMA AssignmentExpression)* 484 | ; 485 | 486 | ConstantExpression 487 | = ConditionalExpression 488 | ; 489 | 490 | 491 | //------------------------------------------------------------------------- 492 | // A.1.1 Lexical elements 493 | // Tokens are: Keyword, Identifier, Constant, StringLiteral, Punctuator. 494 | // Tokens are separated by Spacing. 495 | //------------------------------------------------------------------------- 496 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [Mímir - Image Copyright © Peter Madsen](http://www.petermadsen.info/pages/vh/hv-er-hv/mimir.html) 2 | 3 | # Mímir 4 | 5 | *The god Odin carries around [Mímir's head](http://clojure.org/lazy#Making Clojure Lazier--Don't hang \(onto\) your head) and it recites secret knowledge and counsel to him.* 6 | 7 | ### Mímir is an experimental rule engine written in Clojure. 8 | 9 | [Marginalia](https://hraberg.github.io/mimir/) 10 | 11 | Mímir aims to implement a Rete network as a base. I don't vouch for its correctness, soundness or anything, actually. Like Mímir surely would attest, using it would be somewhat headless. Here's how it looks: 12 | 13 | 14 | ```clojure 15 | ; The first example from chapter 2, "The Basic Rete Algorithm" in Doorenbos: 16 | (facts B1 on B2 17 | B1 on B3 18 | B1 color red 19 | B2 on table 20 | B2 left-of B3 21 | B2 color blue 22 | B3 left-of B4 23 | B3 on table 24 | B3 color red) 25 | 26 | (rule find-stack-of-two-blocks-to-the-left-of-a-red-block 27 | ?x on ?y 28 | ?y left-of ?z 29 | ?z color red 30 | => 31 | ?x is on-top) 32 | 33 | (match? B1 is on-top) 34 | ``` 35 | 36 | [This example](https://github.com/hraberg/mimir/blob/master/test/mimir/test/blocks.clj) uses basic triplets, where each value in a fact is a Clojure atom, and in a rule a condition an atom or a var, prefixed with `?`. This mode is the raw mode the Rete network is operating in, but is somewhat limited in it's applicability. In theory, other representations are possible to compile into this format, but no work has been done on making it so, as I'm doubtful about the practical use case for the triplets. 37 | 38 | The test macro `match?` uses `mimir.well/run` under the hood, which keeps running (potentially forever) until the working memory is stable. The values returned by run are the returned values of the right hand side bodies, which may not have been added to the working memory. When using triplets, a bare triplet returned on the right hand side is automatically `assert`ed into the working memory, but this isn't the case when returning normal Clojure data structures. 39 | 40 | ```clojure 41 | ; Dudeney's SEND + MORE = MONEY: 42 | (integers) 43 | 44 | (rule send-more-money 45 | (base 10 S E N D 46 | + M O R E 47 | = M O N E Y) 48 | 49 | (all-different S E N D M O R Y) 50 | 51 | => 52 | 53 | (str S E N D '+ M O R E '= M O N E Y)) 54 | 55 | (match? "9567+1085=10652") 56 | ``` 57 | 58 | [This example](https://github.com/hraberg/mimir/blob/master/test/mimir/test/arithmetic.clj) uses real Clojure code as its conditions. The left hand side, before the `=>`, contains of one or more conditions, which all must be satisfied for the rule to fire the right hand side, the code after `=>`. The right hand side is normal Clojure code, which will be invoked once for each matching set of variables found by the left hand side (in this case, only once). `(integers)` fills the working memory with 10 single digit facts. 59 | 60 | `base` is a macro that expands into many more conditions, and introduces variables for the reminders of the addition to limit the amount of unknown variables that has to be found at any given moment. `all-different` is just `distinct?`, but could also be written as a macro expanded into to several sub conditions. 61 | 62 | ```clojure 63 | ; N Queens 64 | (chessboard *n*) 65 | 66 | (rule n-queens 67 | 68 | (take-unique *n*) 69 | (different #{file rank}) 70 | (not-same diagonal?) 71 | 72 | => 73 | 74 | (map file *matches*)) 75 | 76 | ; n = 5 77 | (match? [4 2 5 3 1] [3 5 2 4 1] [5 3 1 4 2] [4 1 3 5 2] [5 2 4 1 3] 78 | [1 4 2 5 3] [2 5 3 1 4] [1 3 5 2 4] [3 1 4 2 5] [2 4 1 3 5]) 79 | ``` 80 | 81 | [This example](https://github.com/hraberg/mimir/blob/master/test/mimir/test/n_queens.clj) demonstrates a group of `*n*` queens that are selected by the `take-unique` macro. This expands into several conditions to ensure that the set of working memory elements picked are unique regardless of variable "position". This is done using `compare` behind the scenes in the expanded conditions. 82 | 83 | `different` is a macro expanding into a `distinct?` call for each fn. `not-same` is a binary predicate which ensures `diagonal?` isn't `true` for any combinations of queens. This could be expanded into several conditions, but isn't at the moment; there's a balance between brute force search and the overhead of doing more joins - still to be explored. 84 | 85 | Evaluation of `mimir.well/run-once` is lazy, so you can do: `(take 1 (n-queens))` when calling a rule directly. In contrast, all results are realized by `mimir.well/run` each iteration to figure out if another run is needed. 86 | 87 | And as [Martin](http://martinsprogrammingblog.blogspot.co.uk/) pointed out, this example is "at least two orders of magnitude" too slow! 88 | 89 | ```clojure 90 | ; Rosencrantz' problem from chapter 1, "Rules to the Rescue" in Jess in Action: 91 | (doseq [name ["Fred" "Joe" "Bob" "Tom"] 92 | pants-color [:red :blue :plaid :orange] 93 | position (range 1 (inc 4))] 94 | (fact {:name name :position position :pants-color pants-color})) 95 | 96 | (rule find-solution 97 | {:name "Fred" 98 | :position fred} 99 | 100 | {:name "Joe" 101 | :position 2} 102 | 103 | {:name "Bob" 104 | :pants-color :plaid} 105 | 106 | {:name "Tom" 107 | :position (not-in #{1 4}) 108 | :pants-color (is-not :orange)} 109 | 110 | (constrain {:position (inc ?fred) 111 | :pants-color :blue}) 112 | 113 | (different #{:position :pants-color}) 114 | 115 | => 116 | 117 | (set *matches*)) 118 | 119 | (match? #{{:name "Fred", :position 1, :pants-color :orange} 120 | {:name "Joe", :position 2, :pants-color :blue} 121 | {:name "Bob", :position 4, :pants-color :plaid} 122 | {:name "Tom", :position 3, :pants-color :red}}) 123 | ``` 124 | 125 | [This example](https://github.com/hraberg/mimir/blob/master/test/mimir/test/golfers.clj) is demonstrating the pattern matcher (see below) operating on normal Clojure maps. `not-in` and `is-not` are predicates for the values. Keys not specified in the match are ignored. The maps introduces new (anonymous) variables, matching the working memory, while the `constrain` and `different` macros works on the current set of matches, not the working memory itself. 126 | 127 | For more, see [`mimir.test`](https://github.com/hraberg/mimir/tree/master/test/mimir/test). 128 | 129 | ### Pong 130 | 131 | [This example](https://github.com/hraberg/mimir/blob/master/test/mimir/test/pong.clj) is an attempt to write something less trivial where the working memory keeps changing. It doesn't fully work yet but has shown a few weaknesses in the assumptions made in Mímir which needs addressing. It uses [`clojure-lanterna`](https://github.com/sjl/clojure-lanterna/) for text UI. 132 | 133 | lein trampoline run -m mimir.test.pong 134 | 135 | [Mímir Pong](https://github.com/hraberg/mimir/blob/master/test/mimir/test/pong.clj) 136 | 137 | **Known Issues** 138 | 139 | * The computer occasionally gets stuck or can only move in one direction 140 | * Some variations of conditions that seem valid just doesn't work as expected (potentially related to the above). 141 | * The match vars are bound to normal vars using a simple aliasing hack, hence the name mismatch (`dx` vs `?dx`). 142 | * Using :swing doesn't work properly. 143 | * Resizing the window resets the game, and leaves some noise on the screen. 144 | 145 | 146 | #### Pattern Matching 147 | 148 | Mimir contains an even more experimental [pattern matcher](https://github.com/hraberg/mimir/blob/master/src/mimir/match.clj), which can be seen in action on maps in the [Rosencrantz golfers example](https://github.com/hraberg/mimir/blob/master/test/mimir/test/golfers.clj) and in [Pong](https://github.com/hraberg/mimir/blob/master/test/mimir/test/pong.clj) above. This pattern matcher and it's relationship and influence on Mimir proper is still a bit up in the air. It can be used on it's own: 149 | 150 | ```clojure 151 | (defm member? [x & y] 152 | [x & _ ] true 153 | [_ & xs] (member? x xs)) 154 | 155 | (defm filter-m [pred & coll] 156 | [^x pred & xs] (cons x (filter-m pred xs)) 157 | [_ & xs] (filter-m pred xs) 158 | empty? ()) 159 | 160 | (defm map-m [f & coll] 161 | [x & xs] (cons (f x) (map-m f xs))) 162 | 163 | (defm reduce-m [f val & coll] 164 | [x & xs] (reduce-m f (f x val) xs) 165 | empty? val) 166 | 167 | (defn factorial [x] 168 | (condm x 169 | 0 1 170 | x (* x (factorial (dec x))))) 171 | ``` 172 | 173 | It currently performs the match on the var arg by an arbitrary convention, and can use meta data tags to introduce new bindings in a match. 174 | A symbol which isn't already bound will also introduce a binding, like in `member?` above, `x` matches the actual `x` argument to the fn, but `xs` creates a new var bound to the rest. 175 | 176 | When used inside rules, the bindings currently has to be referenced with a `?` prefix in other conditions, for examples, see [Pong](https://github.com/hraberg/mimir/blob/master/test/mimir/test/pong.clj). 177 | 178 | No performance tuning has been made - partly because there are no tests for this beast yet. 179 | 180 | 181 | #### Goals: mímirKanren 182 | 183 | Mímir contains some initial functionality to write goals in ["mímirKanren"](https://github.com/hraberg/mimir/blob/master/src/mimir/mk.clj), based on [miniKanren](http://gradworks.umi.com/3380156.pdf), using Mimir's [matcher](https://github.com/hraberg/mimir/blob/master/src/mimir/match.clj) to unify. This was inspired by seeing David Nolen's [unsession](http://www.youtube.com/watch?v=A7de6pC-tnU) on [core.logic](https://github.com/clojure/core.logic/) at StrangeLoop 2012. There's currently no clear way to use this together with Mimir proper, early days. 184 | 185 | 186 | ```clojure 187 | (run* [q w z] 188 | (consᵒ q w z) 189 | (firstᵒ z 1)) 190 | ⇒ '(1 –₀ (1 . –₀)) 191 | 192 | (run 3 [q] 193 | (memberᵒ 3 q)) 194 | ⇒ '((3 . –₀) (–₀ 3 . –₁) (–₀ –₁ 3 . –₂)) 195 | 196 | (run* [q] 197 | (appendᵒ [1 2] q [1 2 3 4])) 198 | ⇒ '((3 4)) 199 | ``` 200 | 201 | #### Parsing 202 | 203 | Mímir now also contains an [experimental parser](https://github.com/hraberg/mimir/blob/master/src/mimir/parse.clj), inspired by the awesome [Instaparse](https://github.com/Engelberg/instaparse) by Mark Engelberg. 204 | 205 | See [`mimir.test.parse`](https://github.com/hraberg/mimir/blob/master/test/mimir/test/parse.clj) for examples (but an absolute lack of proper tests). Many things doesn't work properly yet, and the theoretical foundations are shaky to say the least. It doesn't support left-recursion - and a few things are broken. I'm currently backing off to read a few papers, so the references list will hopefully be updated in a few days, once I understand more about what I don't understand. 206 | 207 | The idea is to eventually fold this together with Mímir's normal matcher so rules can descend into strings as well, inspired by [OMeta](http://tinlizzie.org/ometa/). 208 | 209 | ```clojure 210 | (def right-recursive ;; Note: right associative. 211 | (create-parser ;; This returns a parser function. 212 | {:suppress-tags true} ;; Options, can also be given when invoking, see below. 213 | 214 | :goal :expr ;; A rule which is just an alias. 215 | :expr #{[:term #"[+-]" :expr] ;; Sets are (unordered) choices. Keywords refer to rules. 216 | :term} op ;; op is the action, invoked with the result of the parse. 217 | :term #{[:factor #"[*/]" :term] 218 | :factor} op ;; op resolves the regexp match to clojure.core/* etc. 219 | :factor #{#"[0-9]+" #"\w+"} #'*read-string*)) 220 | 221 | (let [x 1 y 3] 222 | (right-recursive "x - 2 * y" :read-string (dynamic-reader))) ;; dynamic-reader wraps read-string + local scope. 223 | ;=> -5 224 | ``` 225 | This example is (somewhat changed) from these [lecture notes](http://www.cs.umd.edu/class/fall2002/cmsc430/lec4.pdf) form Univeristy of Maryland. 226 | 227 | 228 | ## References 229 | 230 | [Production Matching for Large Learning Systems](http://reports-archive.adm.cs.cmu.edu/anon/1995/CMU-CS-95-113.pdf) Robert B. Doorenbos, 1995 231 | 232 | [Jess in Action: Java Rule-based Systems](http://www.manning.com/friedman-hill/) Ernest Friedman-Hill, 2003 233 | 234 | [OPS5](https://github.com/briangu/OPS5) "This Common Lisp version of OPS5 is in the public domain. It is based in part on based on a Franz Lisp implementation done by Charles L. Forgy" 235 | 236 | [Clara](https://github.com/rbrush/clara-rules) "Clara is a forward-chaining rules engine written in Clojure" Ryan Brush, 2013 237 | 238 | [Rule-Based Expert Systems: The MYCIN Experiments of the Stanford Heuristic Programming Project](http://www.amia.org/staff/eshortliffe/Buchanan-Shortliffe-1984/MYCIN%20Book.htm) Bruce G. Buchanan and Edward H. Shortliffe, 1984. Full out-of-print book free online. 239 | 240 | [Relational Programming in miniKanren: Techniques, Applications, and Implementations](http://gradworks.umi.com/3380156.pdf) William Byrd, 2009 241 | 242 | [Transliterating Prolog into Scheme](http://www.cs.indiana.edu/pub/techreports/TR182.pdf) Matthias Felleisen, 1985. Great, short paper, the "Prolog" fits on one page. Most my projects could be said to have been inspired by this transliterate style (into Clojure) - if only I had read it earlier. 243 | 244 | [core.logic - A Tutorial Reconstruction](http://www.youtube.com/watch?v=A7de6pC-tnU) David Nolen, 2012 245 | 246 | [HANSEI as a Declarative Logic Programming Language](http://okmij.org/ftp/kakuritu/logic-programming.html) Oleg Kiselyov, 2010-12 247 | 248 | [Rule Solver: Constraint Programming with OpenRules](http://openrules.com/pdf/RulesSolver.UserManual.pdf) Jacob Feldman, 2012 249 | 250 | * [JSR-331](http://jcp.org/aboutJava/communityprocess/final/jsr331/index.html) 251 | 252 | [Paradigms of AI Programming](http://norvig.com/Lisp-retro.html) Peter Norvig, 1997 253 | 254 | [Artificial Intelligence: A Modern Approach](http://aima.cs.berkeley.edu/) Stuart Russell and Peter Norvig, 2011 255 | 256 | * "Pseudo-code algorithms from the book in [pdf](http://aima.cs.berkeley.edu/algorithms.pdf)" 257 | * [aima-java](http://code.google.com/p/aima-java/) [Ravi Mohan](http://pindancing.blogspot.co.uk/) et al. 258 | 259 | [Approaches to Automatic Programming](http://www.merl.com/papers/docs/TR92-04.pdf) Charles Rich and Richard C. Waters, 1992 260 | 261 | * ["Myths and Prosopects"](http://www.isr.uci.edu/~andre/ics228s2006/richwaters.pdf) 1988, original IEEE Computer article 262 | 263 | [Experimenting with Programming Languages](http://www.vpri.org/pdf/tr2008003_experimenting.pdf) Alessandro Warth, 2009 264 | 265 | [PEG-based transformer provides front-, middleand back-end stages in a simple compiler](http://www.vpri.org/pdf/tr2010003_PEG.pdf) Ian Piumarta, 2010 266 | 267 | [Instaparse](https://github.com/Engelberg/instaparse) Mark Engelberg, 2013 - "What if context-free grammars were as easy to use as regular expressions?" 268 | 269 | [Parsing Expression Grammars](http://www.brynosaurus.com/pub/lang/peg.pdf) Brian Ford, 2004 270 | 271 | [Packrat Parsers Can Support Left Recursion](http://www.tinlizzie.org/~awarth/papers/pepm08.pdf) Alessandro Warth et al, 2008 272 | 273 | [Left Recursion in Parsing Expression Grammars](http://arxiv.org/pdf/1207.0443.pdf) Sergio Medeiros et al, 2012 274 | 275 | [Scannerless Generalized-LR Parsing](file:///home/hraberg/Downloads/10.1.1.37.7828.pdf) Eelco Visser, 1997 276 | 277 | [Generalized Parser Combinators](http://www.cs.uwm.edu/~dspiewak/papers/generalized-parser-combinators.pdf) Daniel Spiewak, 2010 278 | 279 | [Metafor: Visualising Stories as Code](http://web.media.mit.edu/~hugo/publications/drafts/IUI2005-metafor.4.pdf) Hugo Liu and Henery Lieberman, 2005 280 | 281 | [Subtext](http://www.subtextual.org/) [Jonathan Edwards](http://alarmingdevelopment.org), 2005 .. 282 | 283 | [Natural Language, Semantic Analysis and Interactive Fiction](http://inform7.com/learn/documents/WhitePaper.pdf) Graham Nelson, 2005, revised 2006 284 | 285 | [A Conceptual Overview of Prism (Languages Beyond Ada and Lisp)](http://www.dtic.mil/cgi-bin/GetTRDoc?AD=ADA240565) David Fisher and David Mundie et al, 1991 - "Our means of achieving this integrated framework is a language emphasizing expressivity and serving as a medium for dialogue, rather than one-way communication, between user and machine." 286 | 287 | [Patterns of Software](http://www.dreamsongs.com/Files/PatternsOfSoftware.pdf) Richard Gabriel, 1996 288 | 289 | [Aramis or the Love of Technology](http://www.bruno-latour.fr/node/106) Bruno Latour, 1996 290 | 291 | 292 | ### Notes 293 | 294 | The letter `í` in Mímir can conveniently be typed using `C-x 8 ' i` in Emacs. 295 | 296 | 297 | ## License 298 | 299 | Mímir, Copyright © 2012-2013 Håkan Råberg 300 | 301 | Distributed under the Eclipse Public License, the same as Clojure. 302 | 303 | Mimir image from [Valhalla Comics](http://www.valhalla-comics.dk) Copyright © [Peter Madsen](http://www.petermadsen.info/) 304 | 305 | ᚠᚢᚦᚬᚱᚴ 306 | -------------------------------------------------------------------------------- /test/mimir/test/parse.clj: -------------------------------------------------------------------------------- 1 | (ns mimir.test.parse 2 | (:require [flatland.ordered.map :as om] 3 | [clojure.string :as s]) 4 | (:use [mimir.parse])) 5 | 6 | ;; This is not yet a real test, just experiments and examples in various broken states. 7 | 8 | ;; Figure 1. PEG formally describing its own ASCII syntax 9 | ;; from Parsing Expression Grammars: A Recognition-Based Syntactic Foundation 10 | ;; http://bford.info/pub/lang/peg.pdf 11 | (def peg-grammar (slurp "test/mimir/test/peg.txt")) 12 | 13 | ;; Grammar to transform PEG into a Mímir grammar. 14 | ;; Some places could be simplified using regular expressions, but trying to keep it close to the original. 15 | ;; Note that some actions rely on ArityException falling back to *default-action* instead of providing an implementation. 16 | (def peg-options {:suppress-tags true 17 | :capture-literals true 18 | :pre-delimiter #"" 19 | :post-delimiter #"" 20 | 21 | :actions {:Grammar (fn [& xs] (apply om/ordered-map (mapcat eval xs))) 22 | :Expression (fn ([x] x) ([x & xs] (apply list `choice (remove nil? (cons x xs))))) 23 | :Prefix (fn [prefix x] (list prefix x)) 24 | :Suffix (fn [x suffix] (list suffix x)) 25 | :Primary (fn [open x close] x) 26 | 27 | :Identifier (comp keyword str) 28 | :Literal (fn [& xs] 29 | (reduce (fn [s [m r]] 30 | (s/replace s m r)) (s/replace (apply str xs) #"(^'|'$)" "") 31 | [["\\\\" "\\"] ["\\n" "\n"] ["\\r" "\r"] ["\\t" "\t"]])) 32 | :Class (fn [& xs] (re-pattern (apply str xs))) 33 | :Range (fn ([start dash end] (str start dash end))) 34 | :Char str 35 | 36 | :LEFTARROW nil 37 | :SLASH nil 38 | :AND `& 39 | :NOT `! 40 | :QUESTION `take? 41 | :STAR `take* 42 | :PLUS `take+ 43 | :OPEN nil 44 | :CLOSE nil 45 | :DOT #"." 46 | 47 | :Spacing nil}}) 48 | 49 | ;; Bootstrap grammar, same as peg.txt in Mimir's format. 50 | (def peg (create-parser 51 | peg-options 52 | 53 | ;; # Hierarchical syntax 54 | :Grammar [:Spacing :Definition+ :EndOfFile] 55 | :Definition [:Identifier :LEFTARROW :Expression] 56 | :Expression [:Sequence (take* [:SLASH :Sequence])] 57 | :Sequence :Prefix* 58 | :Prefix [(take? (choice :AND :NOT)) :Suffix] 59 | :Suffix [:Primary (take? (choice :QUESTION :STAR :PLUS))] 60 | :Primary (choice [:Identifier (! :LEFTARROW)] 61 | [:OPEN :Expression :CLOSE] 62 | :Literal :Class :DOT) 63 | ;; # Lexical syntax 64 | :Identifier [:IdentStart :IdentCont* :Spacing] 65 | :IdentStart #"[a-zA-Z_]" 66 | :IdentCont (choice :IdentStart #"[0-9]") 67 | :Literal (choice ["'" (take* [(! "'") :Char]) "'" :Spacing] 68 | ["\"" (take* [(! "\"") :Char]) "\"" :Spacing]) 69 | :Class ["[" (take* [(! "]") :Range]) "]" :Spacing] 70 | :Range (choice [:Char "-" :Char] :Char) 71 | :Char (choice [#"\\" #"[nrt'\"\[\]\\]"] 72 | [#"\\" #"[0-2][0-7][0-7]"] 73 | [#"\\" #"[0-7][0-7]?"] 74 | [(! "\\") #"."]) 75 | 76 | :LEFTARROW ["<-" :Spacing] 77 | :SLASH ["/" :Spacing] 78 | :AND ["&" :Spacing] 79 | :NOT ["!" :Spacing] 80 | :QUESTION ["?" :Spacing] 81 | :STAR ["*" :Spacing] 82 | :PLUS ["+" :Spacing] 83 | :OPEN ["(" :Spacing] 84 | :CLOSE [")" :Spacing] 85 | :DOT ["." :Spacing] 86 | 87 | :Spacing (take* (choice :Space :Comment)) 88 | 89 | :Comment ["#" (take* [(! :EndOfLine) #"."]) :EndOfLine] 90 | :Space (choice " " "\t" :EndOfLine) 91 | :EndOfLine (choice "\r\n" "\n" "\r") 92 | :EndOfFile (! #"."))) 93 | 94 | ;; We use the bootstrap to parse the real PEG grammar: 95 | (def mimir-peg (peg peg-grammar)) 96 | 97 | ;; Reparse the grammar using the created parser: 98 | (def peg-peg ((create-parser-from-map peg-options mimir-peg) peg-grammar)) 99 | 100 | ;; mimir-peg and peg-peg are now functionally equal, but contains fns that aren't, string equality holds: 101 | (= (pr-str mimir-peg) (pr-str peg-peg)) 102 | 103 | ;; Not Memoizing is faster here: 104 | (comment 105 | (time (peg peg-grammar :memoize false))) 106 | 107 | ;; This grammar is from the "Transforming the tree" section of Instaparser: 108 | ;; https://github.com/Engelberg/instaparse#transforming-the-tree 109 | 110 | (def expression (create-parser 111 | :expr :add-sub 112 | : #{:mul-div :add :sub} 113 | :add [:add-sub "+" :mul-div] 114 | :sub [:add-sub "-" :mul-div] 115 | : #{:term :mul :div} 116 | :mul [:mul-div "*" :term] 117 | :div [:mul-div "/" :term] 118 | : #{:number ["(" :add-sub ")"]} 119 | :number #"[0-9]+")) 120 | 121 | (expression "1") 122 | 123 | ;; Stopped working after starting from first rule only, now needs left recurision. 124 | ;(expression "1/2") 125 | ;(expression "2+5*2") 126 | ;; Doesn't work yet 127 | ;(expression "1+2+3") 128 | ;; Need to handle left recursion, tree from instaparse: 129 | ;; [:expr [:add [:add [:number "1"] [:number "2"]] [:number "3"]]] 130 | 131 | ;;(expression "1-2/(3-4)+5*6") 132 | 133 | ;; PEG example from http://bford.info/pub/lang/packrat-icfp02-slides.pdf 134 | ;; Additive → Multitive '+' Additive 135 | ;; | Multitive 136 | ;; Multitive → Primary '*' Multitive 137 | ;; | Primary 138 | ;; Primary → '(' Additive ')' 139 | ;; | Decimal 140 | ;; Decimal → '0' | ... | '9' 141 | 142 | (def peg-expression (create-parser 143 | {:suppress-tags true} 144 | 145 | :additive (choice [:multitive #"[+-]" :additive] 146 | :multitive) op 147 | :multitive (choice [:primary #"[*/]" :multitive] 148 | :primary) op 149 | :primary (choice ["(" :additive ")"] 150 | :decimal) 151 | :decimal #"[0-9]+" read-string)) 152 | 153 | ;; This gets wrong precedence, regardless of using choice / OrderedSet or not. So something else. 154 | ;; This also seems right associtive? 155 | ;; Should return 33. 156 | (peg-expression "1-2/(3-4)+5*6") 157 | 158 | (peg-expression "2+5*2") 159 | (peg-expression "2+5*2" :grammar-actions false :suppress-tags false) 160 | 161 | ;; A different expression grammar from: 162 | ;; http://www.cs.umd.edu/class/fall2002/cmsc430/lec4.pdf 163 | 164 | ;; Left recursive 165 | ;; 1 ::= 166 | ;; 2 ::= + 167 | ;; 3 | - 168 | ;; 4 | 169 | ;; 5 ::= * 170 | ;; 6 | = 171 | ;; 7 | 172 | ;; 8 ::= number 173 | ;; 9 | id 174 | 175 | (def left-recursive (create-parser 176 | :goal :expr 177 | :expr #{[:expr #"\+" :term] 178 | [:expr #"-" :term] 179 | :term} 180 | :term #{[:term #"\*" :factor] 181 | [:term #"/" :factor] 182 | :factor} 183 | :factor #{#"[0-9]+" #"\w+"})) 184 | ;; Doesn't work 185 | ;; (left-recursive "x - 2 * y") 186 | 187 | ;; Right recursive 188 | ;; 1 ::= 189 | ;; 2 ::= + 190 | ;; 3 | - 191 | ;; 4 | 192 | ;; 5 ::= * 193 | ;; 6 | / 194 | ;; 7 | 195 | ;; 8 ::= number 196 | ;; 9 | id 197 | 198 | (def right-recursive (create-parser 199 | {:suppress-tags true} 200 | 201 | :goal :expr 202 | :expr #{[:term #"[+-]" :expr] 203 | :term} op 204 | :term #{[:factor #"[*/]" :term] 205 | ["(" :expr ")"] 206 | :factor} op 207 | :factor #{#"[0-9]+" #"\w+"} #'*read-string*)) 208 | 209 | (let [x 1 y 3] 210 | (right-recursive "x - 2 * y" :read-string (dynamic-reader))) 211 | 212 | ;; Extended the grammar to support parenthesis, now this fails the same way as peg-expression: 213 | (right-recursive "1-2/(3-4)+5*6") 214 | ;; Gives -27, should be 33. 215 | 216 | ;; Here's a simpler tree that fails: 217 | ;; Gives -4, should be 2. 218 | (right-recursive "1-2+3") 219 | ;; Actually, the slides says: "Note: This grammar is right-associative." ! 220 | 221 | ;; But the tree is much nicer, and could hint to the answer: 222 | (right-recursive "1-2/(3-4)+5*6" :grammar-actions false :suppress-tags false) 223 | 224 | ;; Check that memoization actually works. 225 | (comment 226 | (let [x 1 y 3] 227 | (time (right-recursive "x - 2 * y" :read-string (dynamic-reader) :memoize false)))) 228 | 229 | 230 | ;; This variant handles left-associative without being left recursive: 231 | ;; http://stackoverflow.com/questions/6148705/relation-between-grammar-and-operator-associativity?rq=1 232 | 233 | ;; Expr ::= Term ( ("+"|"-") Term )*; 234 | ;; Term ::= Factor ( ( "*" | "/" ) Factor )* ; 235 | ;; Factor ::= INTEGER | "(" Expr ")" 236 | 237 | ;; But the tree is not very clear: 238 | (defn expr-eval [& args] 239 | (let [args (apply maybe-singleton args)] 240 | (if (sequential? args) 241 | (reduce (fn [x [op y]] ((fun op) x y)) 242 | (first args) (partition-all 2 (rest args))) 243 | args))) 244 | 245 | ;; As seen above, named after the site, not the exception. 246 | (def stackoverflow (create-parser 247 | {:suppress-tags true} 248 | 249 | :expr [:term (take* [#"[+-]" :term])] expr-eval 250 | :term [:factor (take* [#"[*/]" :factor])] expr-eval 251 | :factor #{:integer ["(" :expr ")"]} 252 | :integer #"[0-9]+" read-string)) 253 | 254 | ;; Gives 2 as expected: 255 | (stackoverflow "1-2+3") 256 | (stackoverflow "1-2+3" :grammar-actions false :suppress-tags false) 257 | ;; Gives -4 as it should: 258 | (stackoverflow "1-(2+3)") 259 | ;; Even this beast of mathematical wonder works: 260 | (stackoverflow "1-2/(3-4)+5*6") 261 | 262 | ;; Mark Engelberg's examples from the Clojure mailing list. 263 | ;; (def addition-associate-right 264 | ;; (insta/parser 265 | ;; "plus = num <'+'> plus | num 266 | ;; num = #'[0-9]'+")) 267 | 268 | ;; (def addition-associate-left 269 | ;; (insta/parser 270 | ;; "plus = plus <'+'> num | num 271 | ;; num = #'[0-9]'+")) 272 | 273 | (def addition-associate-right (create-parser 274 | {:suppress-tags true} 275 | 276 | :plus (choice [:num "+" :plus] :num) + 277 | :num #"[0-9]+" read-string)) 278 | 279 | (addition-associate-right "1+2+3") 280 | 281 | (def addition-associate-left (create-parser 282 | {:suppress-tags true} 283 | 284 | :plus (choice [:plus #"[+]" :num] :num) + 285 | :num #"[0-9]+" read-string)) 286 | 287 | ;; This requires left recursion 288 | ;; (addition-associate-left "1+2+3") 289 | 290 | ;; "As example use of our combinators, consider the following ambiguous grammar from Tomita (1986)." 291 | ;; http://cs.uwindsor.ca/~richard/PUBLICATIONS/PADL_08.pdf 292 | 293 | ;; s ::= np vp | s pp np ::= noun | det noun | np pp 294 | ;; pp ::= prep np vp ::= verb np 295 | ;; det ::= "a" | "the" noun ::= "i" | "man" | "park" | "bat" 296 | ;; verb ::= "saw" prep ::= "in" | "with" 297 | (def ambiguous (create-parser 298 | {:capture-literals true} 299 | 300 | :s #{[:np :vp] [:s :pp]} 301 | :pp [:prep :np] 302 | :det #{"a" "the"} 303 | :verb "saw" 304 | :np #{:noun [:det :noun] [:np :pp]} 305 | :vp [:verb :np] 306 | :noun #{"i" "man" "park" "bat"} 307 | :prep #{"in" "with"})) 308 | 309 | (ambiguous "i saw a man in the park with a bat") 310 | 311 | ;; Different ways to specify greedy quanitifers, either in the keyword or via a fn. 312 | (def helloworld (create-parser 313 | {:capture-literals true} 314 | 315 | :helloworld [:hello* (take? :world)] 316 | :hello "Hello" 317 | :world "World")) 318 | 319 | (helloworld "Hello Hello World") 320 | 321 | ;; This grammar is from Mouse, but uses slightly different PEG syntax: 322 | ;; http://www.romanredz.se/freesoft.htm 323 | (def c-grammar (slurp "test/mimir/test/C.peg")) 324 | ;; (peg c-grammar) 325 | 326 | ;; Some comments and example about left recursion from the PEG mailing list: 327 | ;; 328 | 329 | ;; I've settled on a strategy that tries to expand out as much left 330 | ;; recursion as possible, from left to right. 331 | 332 | ;; Some example parse trees: 333 | 334 | ;; S -> SS / a 335 | ;; with "aaaa" gives S(S(S(S(a), S(a)), S(a)), S(a)) 336 | 337 | ;; S -> ST / a 338 | ;; T -> S 339 | ;; with "aaaa" gives S(S(S(S(a), T(S(a))), T(S(a))), T(S(a))) 340 | 341 | ;; S -> S S T / S c / a / b 342 | ;; T -> d 343 | 344 | ;; with "abcd" gives S(S(a), S(S(b), c), T(d)) 345 | ;; with "abcdabcdd gives S(S(S(a), S(S(b), c), T(d)), S(S(a), S(S(b), c), 346 | ;; T(d)), T(d)) 347 | 348 | ;; It goes left-to-right in the sense that it will try to expand the 349 | ;; first left recursion it encounters. Once it can't keep going with 350 | ;; that, it will try to expand out any other left-recursive invocations 351 | ;; of the same variable later in the string, regardless of if they appear 352 | ;; in the same production as the left recursive invocation. 353 | 354 | ;; If one needs a right leaning tree with left recursion then now (with 355 | ;; my system) it is no longer possible, i.e. left lean for left recursion 356 | ;; is forced. 357 | 358 | ;; A very high level description of my algorithm is that I group the 359 | ;; parser stack into chunks representing continuations. When I detect 360 | ;; left recursion, I copy of chunk of the top-most continuation on the 361 | ;; stack, store it in the memo table, and then advance the topmost parser 362 | ;; frame to the next production. When parsing of a variable is completed, 363 | ;; all continuations stored in that variable's memo entry at that 364 | ;; position are attempted in the order with which they were added into 365 | ;; the memo table. Updating the results of a memo table entry (i.e. 366 | ;; successfully parsing something) resets the memo entry's next 367 | ;; continuation pointer to the first continuation added to the memo 368 | ;; entry. The big trick is that if we are in the continuation of a 369 | ;; variable (i.e. the size of the continuation stack > 1) and we detect a 370 | ;; left recursive invocation of the same variable then instead of adding 371 | ;; it to the memo entry for the variable at the current string position, 372 | ;; we add it to the memo entry of the start of the current continuation's 373 | ;; string position. 374 | 375 | ;; Best Regards, 376 | 377 | ;; Peter Goodman, 378 | 379 | ;; Fun with left recursion 380 | 381 | ;; Left recursion in PEGs indeed seems like an interesting can of worms. For those interested, I'm wondering 382 | ;; how a few example grammars behave under your preferred left-recursive parsing technique, and how you 383 | ;; think they should behave. 384 | 385 | ;; First, a trivially evil left-recursive grammar: 386 | 387 | ;; S <- S 388 | 389 | ;; For example, does your parser detect and reject this somehow, or does it behave the same as 'S <- f'? (I hope it 390 | ;; doesn't result in an infinite loop at runtime anyway. :) ) 391 | 392 | ;; Now a grammar that's weird, not necessarily evil, in a slightly more subtle way: 393 | 394 | ;; S <- S / a 395 | 396 | ;; Does this behave the same as 'S <- a', or do something else? How should it behave? 397 | 398 | ;; Cranking up the evilness factor one notch with a mutually left-recursive grammar… 399 | 400 | ;; S <- T / a 401 | ;; T <- S / &a 402 | 403 | ;; Given the input string "a", does this behave the same as 'S <- a' (succeeding and consuming) or the same as 'S 404 | ;; <- &a' (succeeding but consuming no input)? Do S and T behave the same way or differently? Should they? 405 | 406 | ;; Now, another grammar that's not necessarily evil but strange in a slightly different way: 407 | 408 | ;; S <- Saa / a / 409 | 410 | ;; Given the input string 'aaaa', for example, does/should this grammar consume just 3 or all 4 a's, or does it 411 | ;; do something else? What should it do? 412 | 413 | ;; Cheers, 414 | ;; Bryan -------------------------------------------------------------------------------- /src/mimir/well.clj: -------------------------------------------------------------------------------- 1 | (ns mimir.well 2 | (:use [clojure.set :only (intersection map-invert rename-keys difference union join)] 3 | [clojure.tools.logging :only (debug info warn error spy)] 4 | [clojure.walk :only (postwalk postwalk-replace)] 5 | [mimir.match :only (filter-walk maybe-singleton-coll match all-vars *match-var?* default-match-var?)]) 6 | (:require [clojure.core.reducers :as r]) 7 | (:refer-clojure :exclude [assert]) 8 | (:gen-class)) 9 | 10 | (defn create-net [] 11 | {:productions #{} 12 | :working-memory #{} 13 | :predicates {} 14 | :predicate-invokers {} 15 | :expression-cache {} 16 | :alpha-network {} 17 | :beta-join-nodes {}}) 18 | 19 | (def ^:dynamic *net* (atom (create-net))) 20 | 21 | (defn dbg [x] (println x) x) 22 | 23 | (doseq [k (keys @*net*)] 24 | (eval `(defn ~(symbol (name k)) [] (~k @*net*)))) 25 | 26 | (defn triplet? [x] 27 | (and (sequential? x) (= 3 (count x)) (symbol? (second x)))) 28 | 29 | (defn is-var? [x] 30 | (when-let [^String s (and (symbol? x) (name x))] 31 | (or (.startsWith s "?") 32 | (re-matches #"[A-Z]+" s)))) 33 | 34 | (defn var-sym [x] 35 | (symbol (str "?" x))) 36 | 37 | (alter-var-root #'*match-var?* (constantly (every-pred default-match-var? (complement is-var?)))) 38 | 39 | (defn is-matcher? [x xs] 40 | (and (is-var? x) (not (symbol? (first xs))))) 41 | 42 | (defn matcher? [c] 43 | (and (sequential? c) 44 | (= 'mimir.match/match* (first c)))) 45 | 46 | (defn parser 47 | ([x] (parser x identity identity)) 48 | ([x atom-fn triplet-fn] (parser x atom-fn triplet-fn true)) 49 | ([[x & xs] atom-fn triplet-fn match] 50 | (when x 51 | (cond (and match ((some-fn map? set? vector?) x)) (cons (atom-fn (list 'mimir.match/match (gensym "?") x)) 52 | (parser xs atom-fn triplet-fn match)) 53 | ((some-fn sequential? map? set? string?) x) (cons (atom-fn x) 54 | (parser xs atom-fn triplet-fn match)) 55 | (and match (is-matcher? x xs)) (cons (atom-fn (list 'mimir.match/match x (first xs))) 56 | (parser (rest xs) atom-fn triplet-fn match)) 57 | (triplet? (cons x (take 2 xs))) (cons (triplet-fn (cons x (take 2 xs))) 58 | (parser (drop 2 xs) atom-fn triplet-fn match)) 59 | :else (cons x (parser xs atom-fn triplet-fn match)))))) 60 | 61 | (defn quote-non-vars [rhs] 62 | (postwalk #(if (and (symbol? %) 63 | (not (is-var? %))) (list 'quote %) %) rhs)) 64 | 65 | (defn vars [x] (filter-walk is-var? x)) 66 | 67 | (defn quote-fact [t] 68 | (list 'quote t)) 69 | 70 | (defn expand-rhs [t] 71 | (cons 'mimir.well/assert t)) 72 | 73 | (def relations (reduce (fn [m rel] (assoc m rel rel)) 74 | '{<- mimir.well/bind = mimir.match/match* != not=} '[< > <= => not=])) 75 | 76 | (defn macroexpand-conditions [lhs] 77 | (loop [[c & cs] (map macroexpand lhs) 78 | acc []] 79 | (if-not c 80 | acc 81 | (recur cs 82 | (if (every? seq? c) 83 | (into acc c) 84 | (conj acc c)))))) 85 | 86 | (defn expand-lhs [t] 87 | (if-let [rel (relations (second t))] 88 | (let [[var _ & [rest]] t] 89 | (if-let [rest (and (seq? rest) 90 | (macroexpand-conditions [rest]))] 91 | (concat (butlast rest) [(list rel var (last rest))]) 92 | (list rel var rest))) 93 | t)) 94 | 95 | (defn ellipsis 96 | ([x] (ellipsis 5 x)) 97 | ([n x] 98 | (let [[start more] (split-at n (take (inc n) x))] 99 | (str (seq start) 100 | (when more 101 | (str "... [total: " (count x) "]")))))) 102 | 103 | (defn binding? [c] 104 | (and (sequential? c) 105 | (= 'mimir.well/bind (first c)))) 106 | 107 | (defn binding-var [c] 108 | (when (binding? c) (second c))) 109 | 110 | (defn binding-vars-for-rule [cs] 111 | (set (map binding-var (filter binding? cs)))) 112 | 113 | (defn purge-match-vars [xs] 114 | (let [match-vars (remove is-var? (keys xs))] 115 | (apply dissoc xs (concat (map var-sym match-vars) match-vars)))) 116 | 117 | (defmacro rule [name & body] 118 | (let [body (if ('#{=>} (first body)) (cons (list (gensym "?") '<- true) body) body) 119 | [body salience] (if (#{:salience} (first body)) [(drop 2 body) (second body)] [body 0]) 120 | [lhs _ rhs] (partition-by '#{=>} body) 121 | [doc lhs] (split-with string? lhs) 122 | expanded-lhs (->> (macroexpand-conditions (parser lhs expand-lhs expand-lhs)) 123 | (map #(with-meta % {:ns *ns*}))) 124 | rhs (parser rhs identity expand-rhs false) 125 | binding-vars (binding-vars-for-rule expanded-lhs)] 126 | `(let [f# (defn ~name 127 | ([] (~name {})) 128 | ([{:syms ~(vec (vars lhs)) :as ~'args}] (~name (working-memory) ~'args)) 129 | ([~'wm ~'args] 130 | (debug "rule" '~name '~*ns*) 131 | (for [vars# (check-rule '~(vec expanded-lhs) ~'wm ~'args) 132 | :let [{:syms ~(vec (concat (all-vars lhs) (vars lhs)))} vars# 133 | ~'*matches* (map val (sort-by key (dissoc (purge-match-vars vars#) '~@binding-vars)))]] 134 | (do 135 | (debug "rhs" vars#) 136 | ~@rhs))))] 137 | (debug "defining rule" '~name) 138 | (when-not (= '~lhs '~expanded-lhs) 139 | (debug "expanded" '~lhs) 140 | (debug " into" '~expanded-lhs)) 141 | (alter-meta! f# merge {:lhs '~lhs :rhs '~rhs :doc ~(apply str doc) :salience ~salience}) 142 | (swap! *net* update-in [:productions] conj f#) 143 | f#))) 144 | 145 | (defmacro with-cache [cache-name key & f] 146 | (let [cache-name (keyword cache-name)] 147 | `(let [key# ~key] 148 | (if-not (contains? ('~cache-name @*net*) key#) 149 | (let [v# (do ~@f)] 150 | (swap! *net* assoc-in ['~cache-name key#] v#) 151 | v#) 152 | (get-in @*net* ['~cache-name key#]))))) 153 | 154 | (defn join-on [x y] 155 | (let [vars-and-match-vars #(set (concat (remove '#{_} (all-vars %)) (vars %)))] 156 | (intersection (vars-and-match-vars x) (vars-and-match-vars y)))) 157 | 158 | (defn var-to-index [c] 159 | (loop [[v & vs] (vars c) 160 | acc {}] 161 | (if v 162 | (recur vs (if (acc v) 163 | acc 164 | (assoc acc v (var-sym (inc (count acc)))))) 165 | acc))) 166 | 167 | (defn ordered-vars [c] 168 | (->> (var-to-index c) vals sort vec)) 169 | 170 | (defn tree-eval-walk [locals] 171 | (fn [form] 172 | (condp some [form] 173 | seq? (with-cache expression-cache form 174 | (eval form)) 175 | locals (locals form) 176 | form))) 177 | 178 | (defmacro tree-eval [tree] 179 | (let [locals (keys (select-keys &env (filter-walk symbol? tree))) 180 | locals (into {} (map #(vector (list 'quote %) %) locals))] 181 | `(let [real-locals# ~locals] 182 | (postwalk (tree-eval-walk real-locals#) '~tree)))) 183 | 184 | (defn uses-*matches*? [c] 185 | (boolean (some '#{*matches*} (flatten c)))) 186 | 187 | (defn predicate-for [c] 188 | (with-cache predicate c 189 | (let [args (ordered-vars c) 190 | src `(fn [~@args & [~'*matches*]] ~c) 191 | meta (meta c)] 192 | (debug " compiling" c) 193 | (binding [*ns* (or (:ns meta) *ns*)] 194 | (with-meta (eval src) (merge meta {:src c :args args :uses-*matches* (uses-*matches*? c)})))))) 195 | 196 | (defn alias-match-vars [m] 197 | (merge m 198 | (zipmap (map (comp var-sym name) (keys m)) (vals m)))) 199 | 200 | (defn match-using-predicate [c wme] 201 | (let [predicate (predicate-for c)] 202 | (try 203 | (when-let [result (predicate wme)] 204 | (debug " evaluated to true" wme) 205 | (merge 206 | {'?1 wme} 207 | (when (matcher? c) (alias-match-vars result)))) 208 | (catch RuntimeException e 209 | (debug " threw non fatal" e))))) 210 | 211 | (defn match-triplet [c wme] 212 | (loop [[v & vs] wme [t & ts] c m {}] 213 | (if v 214 | (condp some [t] 215 | #{v} (recur vs ts m) 216 | is-var? (recur vs ts (assoc m t v)) 217 | nil) 218 | (do 219 | (debug " evaluated to true" wme) 220 | m)))) 221 | 222 | (defn predicate? [c] 223 | (-> c first 224 | ((some-fn 225 | (every-pred 226 | symbol? (partial ns-resolve (or (-> c meta :ns) *ns*))) 227 | (every-pred 228 | (complement symbol?) ifn?))))) 229 | 230 | (defn bind [to expr] expr) 231 | (defn constraint [expr] expr) 232 | 233 | (defn constraint? [c] 234 | (and (sequential? c) 235 | (= 'mimir.well/constraint (first c)))) 236 | 237 | (defn multi-var-predicate? [c] 238 | (and (predicate? c) (or (> (count (vars c)) 1) (constraint? c)))) 239 | 240 | (defn multi-var-predicate-placeholder [c] 241 | (let [pred (predicate-for c)] 242 | (debug " more than one argument, needs beta network") 243 | (with-meta (zipmap (-> pred meta :args) (repeat pred)) 244 | (assoc (meta pred) :pred pred)))) 245 | 246 | (defn match-wme [c wme] 247 | (if (predicate? c) 248 | (match-using-predicate c wme) 249 | (match-triplet c wme))) 250 | 251 | (defn ^:private wm-crud [action test msg fact] 252 | (when (test (working-memory) fact) 253 | (debug msg " fact" fact) 254 | (swap! *net* update-in [:working-memory] action fact) 255 | (doseq [c (keys (:alpha-network @*net*)) 256 | :let [match (match-wme c fact)] 257 | :when match] 258 | (debug " alpha network change" match) 259 | (swap! *net* update-in [:alpha-network] #(merge-with action % {c match})))) 260 | fact) 261 | 262 | (defn fact [fact] 263 | (wm-crud conj (complement contains?) "asserting" fact)) 264 | 265 | (defn retract* [fact] 266 | (wm-crud disj contains? "retracting" fact)) 267 | 268 | (defn update [fact f & args] 269 | (let [wm (or (first (filter #(match % fact) (working-memory))) 270 | fact)] 271 | (retract* wm) 272 | (mimir.well/fact (condp some [f] 273 | fn? (apply f wm args) 274 | vector? (let [[a & _] args 275 | args (if (fn? a) args [(constantly a)])] 276 | (apply update-in wm f args)) 277 | f)))) 278 | 279 | (defmacro facts [& wms] 280 | (when wms 281 | `(doall 282 | (for [wm# ~(vec (parser wms identity quote-fact false))] 283 | (fact wm#))))) 284 | 285 | (defn fold-into [ctor coll] 286 | (r/fold (r/monoid into ctor) conj coll)) 287 | 288 | (defn matching-wmes 289 | ([c] (matching-wmes c (working-memory) false)) 290 | ([c wm needs-beta?] 291 | (debug "condition" c) 292 | (if (or ((some-fn multi-var-predicate? binding?) c) 293 | needs-beta?) 294 | #{(multi-var-predicate-placeholder c)} 295 | (->> wm 296 | (map #(match-wme c %)) 297 | (remove nil?) 298 | set)))) 299 | 300 | (defn alpha-network-lookup [c wm needs-beta?] 301 | (with-cache alpha-network c 302 | (matching-wmes c wm needs-beta?))) 303 | 304 | (defn alpha-memory 305 | ([c] (alpha-memory c (working-memory) false)) 306 | ([c wm needs-beta?] 307 | (let [var-to-index (var-to-index c) 308 | vars-by-index (map-invert var-to-index)] 309 | (->> (alpha-network-lookup (with-meta (postwalk-replace var-to-index c) (meta c)) wm needs-beta?) 310 | (map #(rename-keys (with-meta % (merge (meta %) (postwalk-replace vars-by-index (meta %)))) vars-by-index)))))) 311 | 312 | (defn cross [left right] 313 | (debug " nothing to join on, treating as or") 314 | (set 315 | (for [x left y right] 316 | (merge x y)))) 317 | 318 | (defn multi-var-predicate-node? [am] 319 | (and (seq? am) (= 1 (count am)) 320 | (fn? (-> am first meta :pred)))) 321 | 322 | (defn permutations* [n coll] 323 | (if (zero? n) 324 | [[]] 325 | (->> (permutations* (dec n) coll) 326 | (r/mapcat #(r/map (fn [x] (cons x %)) coll))))) 327 | 328 | (defn permutations 329 | ([coll] (permutations (count coll) coll)) 330 | ([n coll] 331 | (fold-into vector (permutations* n coll)))) 332 | 333 | (defn predicate-invoker [args join-on binding-vars uses-*matches*] 334 | (with-cache predicate-invokers [args join-on binding-vars uses-*matches*] 335 | (eval `(fn [pred# {:syms [~@(filter join-on args)] :as matches#}] 336 | (let [matches# (when ~uses-*matches* 337 | (vals (dissoc (purge-match-vars matches#) '~@binding-vars)))] 338 | (fn [[~@(remove join-on args)]] 339 | (pred# ~@args matches#))))))) 340 | 341 | (defn deal-with-multi-var-predicates [c1-am c2-am join-on c2 binding-vars] 342 | (let [pred (-> c2-am first meta :pred) 343 | args (-> c2-am first meta :args) 344 | bind-var (binding-var c2) 345 | matcher ((some-fn matcher? constraint? c2)) 346 | uses-*matches* (-> pred meta :uses-*matches*) 347 | join-on (if bind-var (conj join-on bind-var) join-on) 348 | needed-args (vec (remove join-on args)) 349 | permutated-wm (permutations (count needed-args) (working-memory)) 350 | invoker (predicate-invoker args join-on binding-vars uses-*matches*) 351 | join-fn (fn [m] 352 | (let [invoker (invoker pred m)] 353 | (->> permutated-wm 354 | (r/map (fn [wm] 355 | (try 356 | (when-let [r (invoker wm)] 357 | (merge m 358 | (zipmap needed-args wm) 359 | (when matcher 360 | (alias-match-vars r)) 361 | (when bind-var 362 | {bind-var r}))) 363 | (catch RuntimeException e 364 | (debug " threw non fatal" e))))) 365 | (r/remove nil?))))] 366 | (debug " multi-var-predicate") 367 | (debug " args" args) 368 | (debug " known args" join-on "- need to find" needed-args) 369 | (debug " permutations of wm" (ellipsis permutated-wm)) 370 | (->> c1-am 371 | (r/mapcat join-fn) 372 | (fold-into vector)))) 373 | 374 | (defn beta-join-node [c2 c1-am binding-vars wm] 375 | (let [c2-am (alpha-memory c2 wm (some binding-vars (vars c2)))] 376 | (with-cache beta-join-nodes [c1-am c2-am] 377 | (let [join-on (join-on (-> c1-am first keys) c2)] 378 | (debug "join" join-on) 379 | (debug " left" (ellipsis c1-am)) 380 | (debug " right" (ellipsis c2-am)) 381 | (let [result (cond 382 | (multi-var-predicate-node? c2-am) (deal-with-multi-var-predicates 383 | c1-am c2-am 384 | join-on c2 binding-vars) 385 | (empty? join-on) (cross c1-am c2-am) 386 | :else (join c1-am c2-am))] 387 | (debug "result" (ellipsis result)) 388 | result))))) 389 | 390 | (defn order-conditions [cs] 391 | (mapcat #(concat (sort-by (comp count vars) (remove constraint? %)) 392 | (filter constraint? %)) 393 | (partition-by binding? cs))) 394 | 395 | (defn check-rule [cs wm args] 396 | (debug "conditions" cs) 397 | (let [binding-vars (binding-vars-for-rule cs)] 398 | (loop [[c & cs] (order-conditions cs) 399 | matches #{args}] 400 | (if-not c 401 | matches 402 | (recur cs (beta-join-node c matches binding-vars wm)))))) 403 | 404 | (defn salience [p] 405 | (or (-> p meta :salience) 0)) 406 | 407 | (defn run-once 408 | ([] (run-once (working-memory) (productions))) 409 | ([wm productions] 410 | (->> productions (sort-by salience) vec 411 | ;; This is not thread safe. 412 | ;; (r/mapcat #(% wm {})) 413 | ;; (fold-into vector) 414 | (mapcat #(% wm {})) 415 | doall))) 416 | 417 | (defn run* 418 | ([] (repeatedly run-once))) 419 | 420 | (defn run 421 | ([] (run *net*)) 422 | ([net] 423 | (binding [*net* net] 424 | (loop [wm (working-memory) 425 | productions (:productions @net) 426 | acc #{}] 427 | (let [acc (union (set (run-once wm productions)) acc)] 428 | (if (seq (difference (working-memory) wm)) 429 | (recur (working-memory) productions acc) 430 | acc)))))) 431 | 432 | (defn reset [] 433 | (reset! *net* (create-net))) 434 | 435 | ;; rule writing fns 436 | 437 | (defmacro assert 438 | ([fact] 439 | `(let [fact# (list ~@(quote-non-vars fact))] 440 | (fact fact#))) 441 | ([id rel attr] 442 | `(assert ~(list id rel attr)))) 443 | 444 | (defmacro retract 445 | ([fact] 446 | `(let [fact# (list ~@(quote-non-vars fact))] 447 | (retract* fact#))) 448 | ([id rel attr] 449 | `(retract ~(list id rel attr)))) 450 | 451 | (defn different* [f xs] 452 | (apply distinct? (map f (maybe-singleton-coll xs)))) 453 | 454 | (defmacro different 455 | ([f] `(different ~f ~'*matches*)) 456 | ([f xs] 457 | (if ((some-fn set? vector?) f) 458 | (map #(do `(constraint (different ~% ~xs))) f) 459 | `(constraint (different* ~f ~xs))))) 460 | 461 | (defmacro all-different 462 | ([] `(different identity)) 463 | ([& xs] 464 | `(different identity ~(vec xs)))) 465 | 466 | (defn same* 467 | ([test pred xs] 468 | (test (for [x xs y (remove #{x} xs)] 469 | (pred x y))))) 470 | 471 | (defmacro not-same 472 | ([pred] `(not-same ~pred ~'*matches*)) 473 | ([pred xs] 474 | (if ((some-fn set? vector?) pred) 475 | (map #(do `(constraint (not-same ~% ~xs))) pred) 476 | `(constraint (same* (partial not-any? true?) ~pred (maybe-singleton-coll ~xs)))))) 477 | 478 | (defn same [pred & xs] 479 | (if ((some-fn set? vector?) pred) 480 | (map #(list 'same % xs) pred) 481 | `(same* (partial every? true?) ~pred (maybe-singleton-coll ~xs)))) 482 | 483 | (defmacro gen-vars 484 | ([n] `(gen-vars ~n ~(gensym))) 485 | ([n prefix] 486 | `(vec (map #(var-sym (str '~prefix "-" %)) 487 | (range 1 (inc ~n)))))) 488 | 489 | (defmacro unique [xs] 490 | (concat 491 | (for [[x y] (partition 2 1 xs)] 492 | `(pos? (compare ~x ~y))) 493 | (list (list 'identity xs)))) 494 | 495 | (defmacro take-unique [n] 496 | `(unique ~(gen-vars (eval n)))) 497 | 498 | (defmacro take-distinct [n] 499 | `(identity ~(gen-vars (eval n)))) 500 | 501 | (defn not-in [set] 502 | (complement set)) 503 | 504 | (defn is-not [x] 505 | (partial not= x)) 506 | 507 | (defmacro constrained-match [m x] 508 | `(some #(match % ~m) ~x)) 509 | 510 | (defmacro constrain 511 | ([m] `(constraint (constrained-match ~m ~'*matches*))) 512 | ([x m]`(constraint (constrained-match ~m ~x)))) 513 | 514 | (defn version [] 515 | (-> "project.clj" clojure.java.io/resource 516 | slurp read-string (nth 2))) 517 | 518 | (defn -main [& args] 519 | (println) 520 | (println "Welcome to Mímir |" (version) "| Copyright © 2012-13 Håkan Råberg") 521 | (println) 522 | (require 'clojure.main) 523 | (clojure.main/repl :init #(in-ns 'mimir.well))) 524 | --------------------------------------------------------------------------------