├── src └── paip │ ├── core.clj │ ├── 11_logic │ ├── unification_test.clj │ └── unification.clj │ ├── utils_test.clj │ ├── 6_tools │ ├── search_test.clj │ ├── pat_match_test.clj │ ├── search.clj │ └── pat_match.clj │ ├── utils.clj │ ├── 2_grammar │ ├── grammar_as_lisp.clj │ └── grammar_rule_based.clj │ └── 4_gps │ └── gps_basic.clj ├── .gitignore ├── project.clj ├── README.rst └── LICENSE /src/paip/core.clj: -------------------------------------------------------------------------------- 1 | (ns paip.core 2 | (:gen-class)) 3 | 4 | (defn -main 5 | "I don't do a whole lot ... yet." 6 | [& args] 7 | (println "Hello, World!")) 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | pom.xml 2 | pom.xml.asc 3 | *jar 4 | /lib/ 5 | /classes/ 6 | target 7 | /checkouts/ 8 | .lein-deps-sum 9 | .lein-repl-history 10 | .lein-plugins/ 11 | .lein-failures 12 | .nrepl-port 13 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject paip "0.1.0-SNAPSHOT" 2 | :description "FIXME: write description" 3 | :url "http://example.com/FIXME" 4 | :license {:name "Public Domain" 5 | :url "http://unlicense.org"} 6 | :dependencies [[org.clojure/clojure "1.8.0"] 7 | [org.clojure/tools.trace "0.7.9"]] 8 | :main ^:skip-aot paip.core 9 | :target-path "target/%s" 10 | :plugins [[lein-cljfmt "0.9.0"]] 11 | :profiles {:uberjar {:aot :all}}) 12 | -------------------------------------------------------------------------------- /README.rst: -------------------------------------------------------------------------------- 1 | PAIP in Clojure 2 | --------------- 3 | 4 | Peter Norvig's *"Paradigms of Artificial Intelligence Programming: Case Studies 5 | in Common Lisp"* (a.k.a. PAIP) is one of my all-time favorite programming books. 6 | I think it's amazing and well worth going through even if you're not interested 7 | in Lisp or AI, just for the depth and breadth of solid advice and excellent code 8 | it contains. 9 | 10 | This project is my attempt to go through PAIP again, this time meticulously 11 | reimplementing all programs in `Clojure `_, a modern flavor 12 | of Lisp running on the JVM or in the browser. 13 | -------------------------------------------------------------------------------- /src/paip/11_logic/unification_test.clj: -------------------------------------------------------------------------------- 1 | (ns paip.11-logic.unification-test 2 | (:use clojure.test) 3 | (:use paip.11-logic.unification)) 4 | 5 | (deftest unify-simple 6 | (is (= {} (unify 'a 'a))) 7 | (is (= {} (unify '(?x ?y) '(?x ?y)))) 8 | (is (nil? (unify 'a 'b))) 9 | 10 | (is (= {'?x 2} (unify '(?x + 1) '(2 + 1)))) 11 | (is (= {'?y 1} (unify '(2 + 1) '(2 + ?y)))) 12 | 13 | (is (= {'?x 2, '?y 1} (unify '(?x + 1) '(2 + ?y)))) 14 | (is (= {'?x '?y} (unify '?x '?y))) 15 | (is (= {'?x '?y} (unify '(?x ?x) '(?y ?y)))) 16 | (is (= {'?x '?y} (unify '(?x ?x ?x) '(?y ?y ?y)))) 17 | (is (= {'?x '?y} (unify '(?x ?y) '(?y ?x)))) 18 | (is (= {'?x '?y, '?a '?y} (unify '(?x ?y ?a) '(?y ?x ?x)))) 19 | 20 | (is (nil? (unify '(?x aa) 'aa)))) 21 | 22 | (deftest unify-occurs-fail 23 | (is (nil? (unify '?x '(f ?x)))) 24 | (is (nil? (unify '(?x ?y) '((f ?y) (f ?x)))))) 25 | 26 | (run-tests) 27 | -------------------------------------------------------------------------------- /src/paip/utils_test.clj: -------------------------------------------------------------------------------- 1 | (ns paip.utils-test 2 | (:use clojure.test) 3 | (:use paip.utils)) 4 | 5 | (deftest index-in-seq-test 6 | (is (= 0 (index-in-seq '(10 20 30) 10))) 7 | (is (= 1 (index-in-seq '(10 20 30) 20))) 8 | (is (= 2 (index-in-seq '(10 20 30) 30))) 9 | (is (= -1 (index-in-seq '(10 20 30) 50))) 10 | 11 | (is (= 1 (index-in-seq '(10 20 30 20) 20))) 12 | (is (= 3 (index-in-seq '(10 20 30 20) 20 2))) 13 | (is (= -1 (index-in-seq '(10 20 30 20 50) 20 4))) 14 | 15 | (is (= -1 (index-in-seq [10 20 30 20] 22))) 16 | (is (= 1 (index-in-seq [10 20 30 20] 20))) 17 | (is (= 3 (index-in-seq [10 20 30 20] 20 2))) 18 | 19 | (is (= -1 (index-in-seq '() 10)))) 20 | 21 | (deftest cons?-test 22 | (is (cons? '(1))) 23 | (is (cons? '(1 2))) 24 | (is (cons? '(1 2 3))) 25 | 26 | (is (not (cons? [1 2 3]))) 27 | (is (not (cons? '()))) 28 | (is (not (cons? nil))) 29 | (is (not (cons? 'sdf)))) 30 | 31 | (run-tests) 32 | -------------------------------------------------------------------------------- /src/paip/6_tools/search_test.clj: -------------------------------------------------------------------------------- 1 | ; To run these tests from the lein REPL, run: 2 | ; => (require '[paip.6-tools.search-test] :reload-all) 3 | ; 4 | ; and the tests will run because of the (run-tests) invocation at the bottom. 5 | (ns paip.6-tools.search-test 6 | (:use clojure.test) 7 | (:use paip.6-tools.search)) 8 | 9 | (deftest depth-first-search-test 10 | (is (= 12 (depth-first-search 1 #(= % 12) (finite-binary-tree 15)))) 11 | (is (nil? (depth-first-search 1 #(= % 22) (finite-binary-tree 15))))) 12 | 13 | (deftest breadth-first-search-test 14 | (is (= 12 (breadth-first-search 1 #(= % 12) (finite-binary-tree 15)))) 15 | (is (nil? (breadth-first-search 1 #(= % 22) (finite-binary-tree 15))))) 16 | 17 | (deftest best-first-search-test 18 | (is (= 12 (best-first-search 1 #(= % 12) (finite-binary-tree 15) (diff 12)))) 19 | (is (nil? (best-first-search 1 #(= % 22) (finite-binary-tree 15) (diff 12))))) 20 | 21 | (deftest sorter-test 22 | (is (= '(8 5 10 20 124 9991) 23 | ((sorter #(count (str %))) '(10 8 5) '(124 20 9991))))) 24 | 25 | (deftest beam-search-test 26 | (is (nil? (beam-search 1 #(= % 12) (finite-binary-tree 15) (diff 12) 2))) 27 | (is (= 12 (beam-search 1 #(= % 12) (finite-binary-tree 15) (diff 12) 3)))) 28 | 29 | (run-tests) 30 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This is free and unencumbered software released into the public domain. 2 | 3 | Anyone is free to copy, modify, publish, use, compile, sell, or 4 | distribute this software, either in source code form or as a compiled 5 | binary, for any purpose, commercial or non-commercial, and by any 6 | means. 7 | 8 | In jurisdictions that recognize copyright laws, the author or authors 9 | of this software dedicate any and all copyright interest in the 10 | software to the public domain. We make this dedication for the benefit 11 | of the public at large and to the detriment of our heirs and 12 | successors. We intend this dedication to be an overt act of 13 | relinquishment in perpetuity of all present and future rights to this 14 | software under copyright law. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 19 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR 20 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 21 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | For more information, please refer to 25 | -------------------------------------------------------------------------------- /src/paip/utils.clj: -------------------------------------------------------------------------------- 1 | ;;; Foundational utility functions useful for translating for Common Lisp, but 2 | ;;; that don't have trivial translations in Clojure. 3 | (ns paip.utils) 4 | 5 | (defn index-in-seq 6 | "Finds the index of item in the given sequence; the optional start parameter 7 | specifies the starting index to start looking from. Returns -1 when not found. 8 | Note that this is using a generic approach unoptimized for vectors." 9 | ([seq item start] 10 | (let [idx (.indexOf (nthrest seq start) item)] 11 | (if (>= idx 0) 12 | (+ start idx) 13 | -1))) 14 | ([seq item] (.indexOf seq item))) 15 | 16 | (defn cons? 17 | "Is x a 'cons cell'? Non empty lists return true, otherwise false. 18 | 19 | Doesn't raise an exception on non-sequence inputs. 20 | See http://eli.thegreenplace.net/2016/common-lisps-consp-and-listp-in-clojure/ 21 | for more details." 22 | [x] 23 | (and (list? x) (not (empty? x)))) 24 | 25 | ;;; printv variant that prints only when the dynamic *verbose* is true. A 26 | ;;; convenience wrapper macro with-verbose is provided. 27 | (def ^:dynamic *verbose* false) 28 | 29 | (defmacro printfv 30 | [fmt & args] 31 | `(when *verbose* 32 | (printf ~fmt ~@args))) 33 | 34 | (defmacro with-verbose 35 | [& body] 36 | `(binding [*verbose* true] ~@body)) 37 | -------------------------------------------------------------------------------- /src/paip/2_grammar/grammar_as_lisp.clj: -------------------------------------------------------------------------------- 1 | ;;; Chapter 2: "A simple Lisp Program" - generative grammar as Lisp functions. 2 | ;;; 3 | ;;; Notes: 4 | ;;; - Using lists, similar to the original PAIP code. 5 | ;;; - Clojure code gets compiled, so functions need to be known before they are 6 | ;;; used. We can either modify the definition order or use 'declare'. 7 | 8 | (ns paip.2-grammar.grammar_as_lisp) 9 | 10 | (defn one-of 11 | "Pick one element of s and make a list of it" 12 | [s] 13 | (list (rand-nth s))) 14 | 15 | (declare noun-phrase) 16 | 17 | (defn Prep [] (one-of '(to in by with on))) 18 | (defn PP [] (concat (Prep) (noun-phrase))) 19 | (defn Adj [] (one-of '(bit little blue green adiabatic))) 20 | 21 | (defn Adj* [] 22 | ;; One approach to selection with 50% probability 23 | (if (= (rand-int 2) 0) 24 | nil 25 | (concat (Adj) (Adj*)))) 26 | 27 | (defn PP* [] 28 | ;; Another approach to selection with 50% probability 29 | (if (rand-nth '(true false)) 30 | (concat (PP) (PP*)) 31 | nil)) 32 | 33 | (defn Article [] (one-of '(the a))) 34 | (defn Noun [] (one-of '(man ball woman table))) 35 | (defn Verb [] (one-of '(hit took saw liked))) 36 | (defn noun-phrase [] (concat (Article) (Adj*) (Noun) (PP*))) 37 | (defn verb-phrase [] (concat (Verb) (noun-phrase))) 38 | (defn sentence [] (concat (noun-phrase) (verb-phrase))) 39 | 40 | ;; Generate some sentences 41 | (dotimes [_ 10] 42 | (println (sentence))) 43 | -------------------------------------------------------------------------------- /src/paip/11_logic/unification.clj: -------------------------------------------------------------------------------- 1 | (ns paip.11-logic.unification 2 | (:use clojure.tools.trace) 3 | (:use paip.utils)) 4 | 5 | (def fail 6 | "Denotes a failure in matching" 7 | nil) 8 | 9 | (def no-bindings 10 | "Denotes successful match with no variable bindings" 11 | {}) 12 | 13 | (defn variable? 14 | [x] 15 | (and (symbol? x) (= \? (get (str x) 0)))) 16 | 17 | (defn get-binding 18 | "Find a variable->value binding in the given binding." 19 | [v bindings] 20 | (get bindings v)) 21 | 22 | (defn extend-bindings 23 | "Add a v -> value mappping to bindings." 24 | [v value bindings] 25 | (assoc bindings v value)) 26 | 27 | (defn match-variable 28 | "Does v match input? Uses (or updates) and returns bindings." 29 | [v input bindings] 30 | (let [b (get-binding v bindings)] 31 | (cond (nil? b) (extend-bindings v input bindings) 32 | (= input b) bindings 33 | :else fail))) 34 | 35 | (declare unify-variable occurs-check?) 36 | 37 | (defn unify 38 | "Unify x and y with the given bindings." 39 | ([x y] (unify x y no-bindings)) 40 | ([x y bindings] 41 | (cond (= bindings fail) fail 42 | (= x y) bindings 43 | (variable? x) (unify-variable x y bindings) 44 | (variable? y) (unify-variable y x bindings) 45 | (and (list? x) (list? y)) (unify 46 | (rest x) 47 | (rest y) 48 | (unify (first x) (first y) bindings)) 49 | :else fail))) 50 | 51 | (defn unify-variable 52 | "Unify v with x, using and maybe extending bindings." 53 | [v x bindings] 54 | (cond (get-binding v bindings) (unify (get-binding v bindings) x bindings) 55 | (and (variable? x) (get-binding x bindings)) (unify 56 | v 57 | (get-binding x bindings) 58 | bindings) 59 | (occurs-check? v x bindings) fail 60 | :else (extend-bindings v x bindings))) 61 | 62 | (defn occurs-check? 63 | "Does v occur anywhere inside x?" 64 | [v x bindings] 65 | (cond (= v x) true 66 | (and (variable? x) 67 | (get-binding x bindings)) (occurs-check? 68 | v 69 | (get-binding x bindings) 70 | bindings) 71 | (cons? x) (or (occurs-check? v (first x) bindings) 72 | (occurs-check? v (rest x) bindings)) 73 | :else false)) 74 | 75 | ;(trace-vars occurs-check) 76 | 77 | (unify '(?x + 1) '(2 + ?y)) 78 | -------------------------------------------------------------------------------- /src/paip/6_tools/pat_match_test.clj: -------------------------------------------------------------------------------- 1 | (ns paip.6-tools.pat-match-test 2 | (:use clojure.test) 3 | (:use paip.6-tools.pat-match)) 4 | 5 | (deftest pat-match-basic-var-test 6 | (is (= {'?v 'a} (pat-match '(?v) '(a)))) 7 | 8 | (is (= {'?v 'c} (pat-match '(a ?v b) '(a c b)))) 9 | (is (nil? (pat-match '(a ?v b) '(a c d)))) 10 | 11 | (is (= {'?v 'b} (pat-match '(a t ?v) '(a t b)))) 12 | 13 | (is (= {'?v 'b, '?u 'a} (pat-match '(?u t ?v) '(a t b)))) 14 | 15 | (is (= {'?v 'b} (pat-match '(?v t ?v) '(b t b)))) 16 | (is (nil? (pat-match '(?v t ?v) '(a t b)))) 17 | 18 | (is (= {'?v '(t k)} (pat-match '(a ?v) '(a (t k)))))) 19 | 20 | (deftest pat-match-is-test 21 | (is (= {'?v 8} (pat-match '(a = (?is ?v number?)) '(a = 8)))) 22 | (is (nil? (pat-match '(a = (?is ?v number?)) '(a = jk))))) 23 | 24 | (deftest pat-match-and-test 25 | (is (nil? (pat-match '(a (?and (?is ?v number?) (?is ?v odd?))) '(a 8)))) 26 | (is (= {'?v 7} (pat-match '(a (?and (?is ?v number?) (?is ?v odd?))) '(a 7))))) 27 | 28 | (deftest pat-match-or-test 29 | (is (= {'?v 7} (pat-match '(a (?or (?is ?v odd?) (?is ?v zero?))) '(a 7)))) 30 | (is (= {'?v 0} (pat-match '(a (?or (?is ?v odd?) (?is ?v zero?))) '(a 0)))) 31 | (is (nil? (pat-match '(a (?or (?is ?v odd?) (?is ?v zero?))) '(a 2))))) 32 | 33 | (deftest pat-match-not-test 34 | (is (= {'?v 7} (pat-match '(a ?v (?not ?v)) '(a 7 8)))) 35 | (is (nil? (pat-match '(a ?v (?not ?v)) '(a 7 7))))) 36 | 37 | (deftest pat-match-*-test 38 | (is (= {'?v '(b c)} (pat-match '(a (?* ?v) d) '(a b c d)))) 39 | (is (= {'?v '(b)} (pat-match '(a (?* ?v) d) '(a b d)))) 40 | (is (= {'?v '()} (pat-match '(a (?* ?v) d) '(a d)))) 41 | 42 | (is (= {'?v '(b c)} (pat-match '(a (?* ?v) d ?v) '(a b c d (b c))))) 43 | (is (nil? (pat-match '(a (?* ?v) b c d ?v) '(a b c d (b k))))) 44 | (is (= {'?v '()} (pat-match '(a (?* ?v) b c d ?v) '(a b c d ())))) 45 | 46 | (is (= {'?x '(), '?y '(b c)} (pat-match '(a (?* ?x) (?* ?y) d) '(a b c d)))) 47 | (is (= {'?x '(b c), '?y '(d)} (pat-match '(a (?* ?x) (?* ?y) ?x ?y) 48 | '(a b c d (b c) (d)))))) 49 | 50 | (deftest pat-match-+-test 51 | ;; ?+ can't match empty lists 52 | (is (nil? (pat-match '(a (?+ ?v) d) '(a d)))) 53 | 54 | (is (= {'?v '(t)} (pat-match '(a (?+ ?v) d) '(a t d)))) 55 | (is (= {'?v '(t), '?u '(p a)} (pat-match '(a (?+ ?v) (?+ ?u) d) '(a t p a d))))) 56 | 57 | (deftest pat-match-?-test 58 | (is (= {'?v 'k} (pat-match '((?? ?v) d) '(k d) {}))) 59 | (is (= {} (pat-match '((?? ?v) d) '(d) {}))) 60 | 61 | (is (nil? (pat-match '(g (?? ?v) d) '(d) {}))) 62 | (is (= {} (pat-match '(g (?? ?v) d) '(g d) {}))) 63 | (is (= {'?v 'i} (pat-match '(g (?? ?v) d) '(g i d) {}))) 64 | (is (nil? (pat-match '(g (?? ?v) d) '(g i x d) {})))) 65 | 66 | (run-tests) 67 | -------------------------------------------------------------------------------- /src/paip/6_tools/search.clj: -------------------------------------------------------------------------------- 1 | ;;; Chapter 6, section 6.4: a set of searching tools 2 | 3 | (ns paip.6-tools.search 4 | (:use paip.utils)) 5 | 6 | (defn tree-search 7 | "Finds a state that satisfies goal?-fn; Starts with states, and searches 8 | according to successors and combiner. If successful, returns the state; 9 | otherwise returns nil." 10 | [states goal?-fn successors combiner] 11 | (printfv ";; Search: %s%n" (pr-str states)) 12 | (cond (empty? states) nil 13 | (goal?-fn (first states)) (first states) 14 | :else (tree-search (combiner (successors (first states)) 15 | (rest states)) 16 | goal?-fn 17 | successors 18 | combiner))) 19 | 20 | (defn depth-first-search 21 | "Search new states first until goal is reached." 22 | [start goal?-fn successors] 23 | (tree-search (list start) goal?-fn successors concat)) 24 | 25 | (defn prepend 26 | [x y] 27 | (concat y x)) 28 | 29 | (defn breadth-first-search 30 | "Search old states first until goal is reached." 31 | [start goal?-fn successors] 32 | (tree-search (list start) goal?-fn successors prepend)) 33 | 34 | (defn binary-tree 35 | "A successors function representing a binary tree." 36 | [x] 37 | (list (* 2 x) (+ 1 (* 2 x)))) 38 | 39 | (defn finite-binary-tree 40 | "Returns a successor function that generates a binary tree with n nodes." 41 | [n] 42 | (fn [x] 43 | (filter #(<= % n) (binary-tree x)))) 44 | 45 | ;(with-verbose 46 | ;(depth-first-search 1 #(= % 32) binary-tree)) 47 | 48 | ;(with-verbose 49 | ;(depth-first-search 1 #(= % 22) (finite-binary-tree 15))) 50 | 51 | ;(with-verbose 52 | ;(breadth-first-search 1 #(= % 32) binary-tree)) 53 | 54 | (defn diff 55 | "Given n, returns a function that computes the distance of its argument from 56 | n." 57 | [n] 58 | (fn [x] (Math/abs (- x n)))) 59 | 60 | (defn sorter 61 | "Returns a combiner function that sorts according to cost-fn." 62 | [cost-fn] 63 | (fn [new old] 64 | (sort-by cost-fn (concat new old)))) 65 | 66 | (defn best-first-search 67 | "Search lowest cost states first until goal is reached." 68 | [start goal?-fn successors cost-fn] 69 | (tree-search (list start) goal?-fn successors (sorter cost-fn))) 70 | 71 | ;(with-verbose 72 | ;(best-first-search 1 #(= % 12) binary-tree (diff 12))) 73 | 74 | (defn beam-search 75 | "Search highest scoring states first until goal is reached, but never consider 76 | more than beam-width states at a time." 77 | [start goal?-fn successors cost-fn beam-width] 78 | (tree-search (list start) goal?-fn successors 79 | (fn [old new] 80 | (let [sorted ((sorter cost-fn) old new)] 81 | (take beam-width sorted))))) 82 | 83 | ;; With beam-width of 2 won't be found... 84 | ;(with-verbose 85 | ;(beam-search 1 #(= % 12) binary-tree (diff 12) 3)) 86 | -------------------------------------------------------------------------------- /src/paip/2_grammar/grammar_rule_based.clj: -------------------------------------------------------------------------------- 1 | ;;; Chapter 2: "A simple Lisp Program" - generative grammar - rule-based 2 | ;;; solution. 3 | ;;; 4 | ;;; Notes: 5 | ;;; - Using maps instead of a-lists for more idiomatic (and efficient) Clojure. 6 | ;;; Hence we also don't need the special -> notation. 7 | ;;; - simple-grammar, not *simple-grammar*. In Clojure everything is assumed to 8 | ;;; be constant unless stated otherwise, so earmuffs for constants are not 9 | ;;; necessary. 10 | 11 | (ns paip.2-grammar.grammar_rule_based) 12 | 13 | ;;; Maps category to a list of rewrites. When a rewrite is a list in itself, 14 | ;;; it's treated recursively. 15 | (def simple-grammar 16 | {'sentence '((noun-phrase verb-phrase)), 17 | 'noun-phrase '((Article Noun)), 18 | 'verb-phrase '((Verb noun-phrase)), 19 | 'Article '(the a), 20 | 'Noun '(man ball woman table), 21 | 'Verb '(hit took saw liked)}) 22 | 23 | (def grammar simple-grammar) 24 | 25 | (defn rewrites 26 | "Return a list of the possible rewrites for this category." 27 | [category] 28 | (get grammar category)) 29 | 30 | (defn generate 31 | "Generate a random sentence or phrase." 32 | [phrase] 33 | (cond (list? phrase) (mapcat generate phrase) 34 | (rewrites phrase) (generate (rand-nth (rewrites phrase))) 35 | :else (list phrase))) 36 | 37 | ;;; Solution to exercise 2.1 38 | (defn generate-2-1 39 | [phrase] 40 | ;; Uses if-let since a cond solution would require mean (rewrites phrase) 41 | ;; even when not necessary. In the book, setf is used on a let binding but 42 | ;; this goes against the Clojure way. We could define a cond-let macro 43 | ;; for Clojure too. 44 | (if-let [prewrites (rewrites phrase)] 45 | (generate (rand-nth prewrites)) 46 | (if (list? phrase) 47 | (mapcat generate phrase) 48 | (list phrase)))) 49 | 50 | ;;;---- To enable tracing, uncomment the following two lines 51 | ;(use 'clojure.tools.trace) 52 | ;(trace-vars generate rewrites) 53 | ;;;---- 54 | 55 | ;(dotimes [_ 10] 56 | ;(println (generate 'sentence))) 57 | 58 | (defn generate-tree 59 | "Generate a random sentence or phrase, with a complete parse tree." 60 | [phrase] 61 | (cond (list? phrase) (map generate-tree phrase) 62 | (rewrites phrase) 63 | (cons phrase (generate-tree (rand-nth (rewrites phrase)))) 64 | :else (list phrase))) 65 | 66 | ;(generate-tree 'sentence) 67 | 68 | (defn combine-all 69 | "Return a list of lists formed by appeding a y to an x. 70 | E.g. (combine-all '((a) (b)) '((1) (2))) 71 | -> ((a 1) (b 1) (a 2) (b 2))" 72 | [xlist ylist] 73 | (mapcat (fn [y] 74 | (map #(concat % y) xlist)) 75 | ylist)) 76 | 77 | (defn generate-all 78 | "Generate a list of all possible expansions of this phrase." 79 | [phrase] 80 | (cond (nil? phrase) (list nil) 81 | (list? phrase) (combine-all (generate-all (first phrase)) 82 | (generate-all (seq (rest phrase)))) 83 | (rewrites phrase) (mapcat generate-all (rewrites phrase)) 84 | :else (list (list phrase)))) 85 | 86 | (count (generate-all 'sentence)) 87 | -------------------------------------------------------------------------------- /src/paip/4_gps/gps_basic.clj: -------------------------------------------------------------------------------- 1 | ;;; Chapter 4: "GPS: The general problem solver" - the basic/naive solver. 2 | ;;; 3 | ;;; Notes: 4 | ;;; - This solution tries to be as faithful as possible to the original CL code, 5 | ;;; including a mutable state. Not using mutable state here would result in a 6 | ;;; completely different design, which is presented in the rest of the chapter 7 | ;;; anyway. 8 | ;;; - One difference is using add-set and del-set instead of add-list and 9 | ;;; del-list, because in Clojure set-like ops are efficiently defined on sets, 10 | ;;; not lists. 11 | 12 | (ns paip.4-gps.gps-basic) 13 | 14 | (defrecord Op [action preconds add-set del-set]) 15 | 16 | ;;; *ops* and *state* are dynamic variables that will be set by GPS when 17 | ;;; executing a solution to some particular problem. The funuctions defined here 18 | ;;; refer to these variables directly. 19 | (def ^:dynamic *ops* nil) 20 | (def ^:dynamic *state* nil) 21 | 22 | ;;; Pre-declare symbols used in the functions below. 23 | (declare achieve) 24 | 25 | (defn appropriate? 26 | "Is it appropriate to perform an operation to achieve a goal?" 27 | [goal op] 28 | (contains? (:add-set op) goal)) 29 | 30 | (defn apply-op 31 | "Print a message and update *state* if op is applicable and return true." 32 | [op] 33 | (when (every? achieve (:preconds op)) 34 | (println "Executing " (:action op)) 35 | ;; Do the update in a single swap! 36 | (swap! *state* #(clojure.set/union 37 | (clojure.set/difference % (:del-set op)) 38 | (:add-set op))) 39 | true)) 40 | 41 | (defn achieve 42 | "Try to achieve a goal and return true if it's achieved, false otherwise." 43 | [goal] 44 | (or (contains? @*state* goal) 45 | (some apply-op (filter #(appropriate? goal %) *ops*)))) 46 | 47 | (defn GPS 48 | "GPS: achieve all goals using ops, from the starting state 'state'." 49 | [state goals ops] 50 | ;; Set a dynamic binding for *ops* and *state* while the solution is 51 | ;; executing. 52 | (binding [*ops* ops 53 | *state* state] 54 | (when (every? achieve goals) 55 | 'solved))) 56 | 57 | ;;; Data for the 'drive child to school' problem. State entities and actions are 58 | ;;; symbols. 59 | (def school-ops 60 | "A list of available operators" 61 | (list (map->Op {:action 'drive-son-to-school 62 | :preconds '(son-at-home car-works) 63 | :add-set #{'son-at-school} 64 | :del-set #{'son-at-home}}) 65 | (map->Op {:action 'shop-installs-battery 66 | :preconds '(car-needs-battery shop-knows-problem shop-has-money) 67 | :add-set #{'car-works}}) 68 | (map->Op {:action 'tell-shop-problem 69 | :preconds '(in-communication-with-shop) 70 | :add-set #{'shop-knows-problem}}) 71 | (map->Op {:action 'telephone-shop 72 | :preconds '(know-phone-number) 73 | :add-set #{'in-communication-with-shop}}) 74 | (map->Op {:action 'look-up-number 75 | :preconds '(have-phone-book) 76 | :add-set #{'know-phone-number}}) 77 | (map->Op {:action 'give-shop-money 78 | :preconds '(have-money) 79 | :add-set #{'shop-has-money} 80 | :del-set #{'have-money}}))) 81 | 82 | (GPS 83 | (atom #{'son-at-home 'car-needs-battery 'have-money 'have-phone-book}) 84 | '(son-at-school) school-ops) 85 | 86 | (GPS 87 | (atom #{'son-at-home 'car-needs-battery 'have-money}) 88 | '(son-at-school) school-ops) 89 | 90 | (GPS 91 | (atom #{'son-at-home 'car-works}) 92 | '(son-at-school) school-ops) 93 | 94 | ;(clojure.pprint/pprint school-ops) 95 | -------------------------------------------------------------------------------- /src/paip/6_tools/pat_match.clj: -------------------------------------------------------------------------------- 1 | ;;; Chapter 6, section 6.2: a pattern matching tool. 2 | 3 | (ns paip.6-tools.pat-match 4 | (:use paip.utils)) 5 | 6 | (def fail 7 | "Denotes a failure in matching" 8 | nil) 9 | 10 | (def no-bindings 11 | "Denotes successful match with no variable bindings" 12 | {}) 13 | 14 | (defn variable? 15 | [x] 16 | (and (symbol? x) (= \? (get (str x) 0)))) 17 | 18 | (defn get-binding 19 | "Find a variable->value binding in the given binding." 20 | [v bindings] 21 | (get bindings v)) 22 | 23 | (defn extend-bindings 24 | "Add a v -> value mappping to bindings." 25 | [v value bindings] 26 | (assoc bindings v value)) 27 | 28 | (defn match-variable 29 | "Does v match input? Uses (or updates) and returns bindings." 30 | [v input bindings] 31 | (let [b (get-binding v bindings)] 32 | (cond (nil? b) (extend-bindings v input bindings) 33 | (= input b) bindings 34 | :else fail))) 35 | 36 | (declare pat-match) 37 | 38 | (defn match-is 39 | "Suceed and bind var if the input satisfied pred. 40 | var-and-pred is the list (var pred)." 41 | [var-and-pred input bindings] 42 | (let [[v pred] var-and-pred 43 | new-bindings (pat-match v input bindings)] 44 | (if (or (= new-bindings fail) 45 | (not ((resolve pred) input))) 46 | fail 47 | new-bindings))) 48 | 49 | (defn match-and 50 | "Succeed if all the patterns match the input." 51 | [patterns input bindings] 52 | (cond (= bindings fail) fail 53 | (empty? patterns) bindings 54 | :else (match-and 55 | (rest patterns) 56 | input 57 | (pat-match (first patterns) input bindings)))) 58 | 59 | (defn match-or 60 | "Succeed if any of the patterns match the input." 61 | [patterns input bindings] 62 | (if (empty? patterns) 63 | fail 64 | (let [new-bindings (pat-match (first patterns) input bindings)] 65 | (if (= new-bindings fail) 66 | (match-or (rest patterns) input bindings) 67 | new-bindings)))) 68 | 69 | (defn match-not 70 | "Succeed if none of the patterns match the input. 71 | This will never bind variables." 72 | [patterns input bindings] 73 | (if (match-or patterns input bindings) 74 | fail 75 | bindings)) 76 | 77 | (def single-matcher-table 78 | "Table mapping single matcher names to matching functions." 79 | {'?is match-is 80 | '?or match-or 81 | '?and match-and 82 | '?not match-not}) 83 | 84 | (defn first-match-pos 85 | "Find the first position that pat1 could possibly match input, starting 86 | at position start. If pat1 is non-constant, then just return start, 87 | conservatively assuming it could match." 88 | [pat1 input start] 89 | (cond (and (not (list? pat1)) 90 | (not (variable? pat1))) (let [idx (index-in-seq input pat1 start)] 91 | (if (< idx 0) 92 | nil 93 | idx)) 94 | (< start (count input)) start 95 | :else nil)) 96 | 97 | (defn segment-match-* 98 | "Match the segment pattern ((?* ?var) . pat) against input. The optional start 99 | parameter specifices where to start matching (index in input) the pattern 100 | after the current ?* match." 101 | ([pattern input bindings] (segment-match-* pattern input bindings 0)) 102 | ([pattern input bindings start] 103 | (let [v (second (first pattern)) 104 | pat (rest pattern)] 105 | (if (nil? pat) 106 | ;; If there's no more pat to match, this is a simple variable match of 107 | ;; ?var on the whole input. 108 | (match-variable v input bindings) 109 | ;; Otherwise, find the first position in the input where pat could match. 110 | ;; Try to match our segment until there pat from there. If this fails, 111 | ;; rerun with start+1 to try matching at the next position. 112 | (let [pos (first-match-pos (first pat) input start)] 113 | (if (nil? pos) 114 | fail 115 | (let [b2 (pat-match pat 116 | (nthrest input pos) 117 | (match-variable v 118 | (take pos input) 119 | bindings))] 120 | ;; If this match failed, try another longer one 121 | (if (= b2 fail) 122 | (segment-match-* pattern input bindings (+ pos 1)) 123 | b2)))))))) 124 | 125 | (defn segment-match-+ 126 | "Match ?+ -- one or more elements of input." 127 | [pattern input bindings] 128 | (segment-match-* pattern input bindings 1)) 129 | 130 | (defn segment-match-? 131 | "Match ?? -- zero or one elements of input." 132 | [pattern input bindings] 133 | (let [v (second (first pattern)) 134 | pat (rest pattern)] 135 | (or (pat-match (conj pat v) input bindings) 136 | (pat-match pat input bindings)))) 137 | 138 | (def segment-matcher-table 139 | "Table mapping segment matcher names to matching functions." 140 | {'?* segment-match-* 141 | '?+ segment-match-+ 142 | '?? segment-match-?}) 143 | 144 | (defn single-pattern? 145 | "Is this a single-matching pattern?" 146 | [pattern] 147 | (and (list? pattern) (get single-matcher-table (first pattern)))) 148 | 149 | (defn single-matcher 150 | "Call the right single-pattern matching function." 151 | [pattern input bindings] 152 | ((get single-matcher-table (first pattern)) (rest pattern) input bindings)) 153 | 154 | (defn segment-pattern? 155 | "Is this a segment-matching pattern?" 156 | [pattern] 157 | (and (list? pattern) 158 | (list? (first pattern)) 159 | (symbol? (first (first pattern))) 160 | (get segment-matcher-table (first (first pattern))))) 161 | 162 | (defn segment-matcher 163 | "Call the right function for this kind of segment pattern." 164 | [pattern input bindings] 165 | ((get segment-matcher-table (first (first pattern))) pattern input bindings)) 166 | 167 | (defn pat-match 168 | ([pattern input] (pat-match pattern input no-bindings)) 169 | ([pattern input bindings] 170 | (cond (= bindings fail) fail 171 | (variable? pattern) (match-variable pattern input bindings) 172 | (= pattern input) bindings 173 | (single-pattern? pattern) (single-matcher pattern input bindings) 174 | (segment-pattern? pattern) (segment-matcher pattern input bindings) 175 | (and (list? pattern) (list? input)) (pat-match 176 | (rest pattern) 177 | (rest input) 178 | (pat-match 179 | (first pattern) 180 | (first input) 181 | bindings)) 182 | :else fail))) 183 | --------------------------------------------------------------------------------