aima.lisp 0100644 0002635 0000472 00000020313 07454634632 012642 0 ustar russell russell ;;; -*- Mode: Lisp; Syntax: Common-Lisp -*- File: aima.lisp
;;;; Vendor-Specific Customizations
#+Lucid (setq *warn-if-no-in-package* nil)
;;;; A minimal facility for defining systems of files
(defparameter *aima-root* (truename "~/public_html/code/") ; <<<<<<<< Edit this <<<<<<
"The root directory where the code is stored.")
(defparameter *aima-binary-type*
(first (list ; <<<<<<<<<<<<<<<<<<<< Edit this <<<<<<<<<
#+Lispworks system::*binary-file-type*
#+Lucid (first lucid::*load-binary-pathname-types*)
#+Allegro excl:*fasl-default-type*
#+(or AKCL KCL) "o"
#+CMU "sparcf"
#+CLISP "fas"))
"If calling aima-load loads your source files and not your compiled
binary files, insert the file type for your binaries before the <<<<
and load systems with (aima-load-binary NAME).")
(defconstant *aima-version*
"0.99 AIMA Code, Appomattox Version, 09-Apr-2002")
(defparameter *aima-system-names* nil
"A list of names of the systems that have been defined.")
(defstruct aima-system
name (requires nil) (doc "") (parts nil) (examples nil) (loaded? nil))
;;;; The Top-Level Functions:
(defmacro def-aima-system (name requires doc &body parts)
"Define a system as a list of parts. A part can be a string, which denotes
a file name; or a symbol, which denotes a (sub)system name; or a list of the
form (subdirectory / part...), which means the parts are in a subdirectory.
The REQUIRES argument is a list of systems that must be loaded before this
one. Note that a documentation string is mandatory."
`(add-aima-system :name ',name
:requires ',requires :doc ',doc :parts ',parts))
(defun aima-load (&optional (name 'all))
"Load file(s), trying the system-dependent method first."
(operate-on-aima-system name 'load-something))
(defun aima-load-binary (&optional (name 'all))
"Load file(s), prefering binaries to source."
(operate-on-aima-system name 'load-binary))
(defun aima-compile (&optional (name 'everything))
"Compile (and load) the file or files that make up an AIMA system."
(operate-on-aima-system name 'compile-load))
(defun aima-load-if-unloaded (name)
(let ((system (get-aima-system name)))
(unless (and system (aima-system-loaded? system))
(aima-load system))
system))
;;;; Support Functions
(defun add-aima-system (&key name requires doc parts examples)
(pushnew name *aima-system-names*)
(setf (get 'aima-system name)
(make-aima-system :name name :examples examples
:requires requires :doc doc :parts parts)))
(defun get-aima-system (name)
"Return the system with this name. (If argument is a system, return it.)"
(cond ((aima-system-p name) name)
((symbolp name) (get 'aima-system name))
(t nil)))
(defun operate-on-aima-system (part operation &key (path nil) (load t)
(directory-operation #'identity))
"Perform the operation on the part (or system) and its subparts (if any).
Reasonable operations are load, load-binary, compile-load, and echo.
If LOAD is true, then load any required systems that are unloaded."
(let (system)
(cond
((stringp part) (funcall operation (aima-file part :path path)))
((and (consp part) (eq (second part) '/))
(let* ((subdirectory (mklist (first part)))
(new-path (append path subdirectory)))
(funcall directory-operation new-path)
(dolist (subpart (nthcdr 2 part))
(operate-on-aima-system subpart operation :load load
:path new-path
:directory-operation directory-operation))))
((consp part)
(dolist (subpart part)
(operate-on-aima-system subpart operation :load load :path path
:directory-operation directory-operation)))
((setf system (get-aima-system part))
;; Load the required systems, then operate on the parts
(when load (mapc #'aima-load-if-unloaded (aima-system-requires system)))
(operate-on-aima-system (aima-system-parts system) operation
:load load :path path
:directory-operation directory-operation)
(setf (aima-system-loaded? system) t))
(t (warn "Unrecognized part: ~S in path ~A" part path)))))
(defun aima-file (name &key (type nil) (path nil))
"Given a file name and maybe a file type and a relative path from the
AIMA directory, return the right complete pathname."
(make-pathname :name name :type type :defaults *aima-root*
:directory (append (pathname-directory *aima-root*)
(mklist path))))
#-MCL ;; Macintosh Common Lisp already defines this function
(defun compile-load (file)
"Compile file and then load it."
;; This could be made more sophisticated, to compile only when out of date.
(compile-file (file-with-type file "lisp"))
(load-binary file))
(defun load-binary (file)
"Load file, trying the binary first, but loading the source if necessary."
(load-something file '(binary nil "lisp")))
(defun load-something (file &optional (types '(nil binary "lisp")))
"Try each of the types in turn until we get a file that loads.
Complain if we can't find anything. By default, try the system-dependent
method first, then the binary, and finally the source (lisp) file."
(dolist (type types (warn "Can't find file: ~A" file))
(when (load (file-with-type file type) :if-does-not-exist nil)
(return t))))
(defun file-with-type (file type)
"Return a pathname with the given type."
(if (null type)
file
(merge-pathnames
(make-pathname :type (if (eq type 'binary) *aima-binary-type* type))
file)))
(defun mklist (x)
"If x is a list, return it; otherwise return a singleton list, (x)."
(if (listp x) x (list x)))
;;; ----------------------------------------------------------------------
;;;; Definitions of Systems
;;; ----------------------------------------------------------------------
(def-aima-system utilities ()
"Basic functions that are loaded every time, and used by many other systems."
("utilities" / "utilities" "binary-tree" "queue" "cltl2" "test-utilities"))
(def-aima-system agents (utilities)
"Code from Part I: Agents and Environments"
("agents" / "test-agents"
("environments" / "basic-env" "grid-env" "vacuum" "wumpus")
("agents" / "agent" "vacuum" "wumpus")
("algorithms" / "grid")))
(def-aima-system search (agents)
"Code from Part II: Problem Solving and Search"
("search" / "test-search"
("algorithms" / "problems" "simple" "repeated"
"csp" "ida" "iterative" "sma" "minimax")
("environments" / "games" "prob-solve")
("domains" / "cannibals" "ttt" "cognac" "nqueens" "path-planning"
"puzzle8" "route-finding" "tsp" "vacuum")
("agents" / "ps-agents" "ttt-agent")))
(def-aima-system logic (agents)
"Code from Part III: Logic, Inference, and Knowledge Representation"
("logic" / "test-logic"
("algorithms" / "tell-ask" "unify" "normal" "prop" "horn" "fol" "infix")
("environments" / "shopping")))
(def-aima-system planning ()
"Code from Part IV: Planning and Acting"
("planning" / ))
(def-aima-system uncertainty (agents)
"Code from Part V: Uncertain Knowledge and Reasoning"
("uncertainty" / "test-uncertainty"
("agents" / "mdp-agent")
("domains" / "mdp" "4x3-mdp")
("environments" / "mdp")
("algorithms" / "dp" "stats")))
(def-aima-system learning (uncertainty)
"Code from Part VI: Learning"
("learning" / "test-learning"
("algorithms" / "inductive-learning" "learning-curves" "dtl" "dll"
"nn" "perceptron" "multilayer" "q-iteration")
("domains" / "restaurant-multivalued" "restaurant-real"
"restaurant-boolean" "majority-boolean" "ex-19-4-boolean"
"and-boolean" "xor-boolean" "4x3-passive-mdp")
("agents" / "passive-lms-learner" "passive-adp-learner"
"passive-td-learner" "active-adp-learner" "active-qi-learner"
"exploring-adp-learner" "exploring-tdq-learner")))
(def-aima-system language (logic)
"Code from Part VII, Chapters 22-23: Natural Language and Communication"
("language" / "test-language"
("algorithms" / "chart-parse")
("domains" / "grammars" )))
(def-aima-system all ()
"All systems except the utilities system, which is always already loaded"
agents search logic planning uncertainty learning language)
(def-aima-system everything ()
"All the code, including the utilities"
utilities all)
(setf *aima-system-names* (nreverse *aima-system-names*))
;;;; Always load the utilities
(aima-load 'utilities)
language/ 0040755 0002635 0000472 00000000000 06326754526 012633 5 ustar russell russell language/domains/ 0040755 0002635 0000472 00000000000 06326754714 014264 5 ustar russell russell language/domains/grammars.lisp 0100644 0002635 0000472 00000012502 06222320270 016740 0 ustar russell russell ;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- File: language/grammars.lisp
;;;; Definition of Lexicons and Grammars: E0, E1, E2
(defparameter *E0*
(grammar
:lexicon
'((Noun -> stench breeze glitter nothing wumpus pit pits
gold north south east west)
(Verb -> is see smell shoot shot feel stinks go grab
carry kill turn)
(Adjective -> right left east south back smelly)
(Adverb -> here there nearby ahead right left
north south east west back)
(Pronoun -> me you I it)
(Name -> John Mary Boston Aristotle)
(Article -> the a an)
(Preposition -> to in on near)
(Conjunction -> and or but)
(Digit -> 0 1 2 3 4 5 6 7 8 9)
(that -> that))
:rules
'((S -> NP VP)
(S -> S Conjunction S)
(NP -> Pronoun)
(NP -> Noun)
(NP -> Article Noun)
(NP -> Digit Digit)
(NP -> NP PP)
(NP -> NP RelClause)
(VP -> Verb)
(VP -> VP NP)
(VP -> VP Adjective)
(VP -> VP PP)
(VP -> VP Adverb)
(PP -> Preposition NP)
(RelClause -> that VP)))
"Lexicon and grammar for E0 in Figures 22.5, 22.6, page 665.")
(defparameter *E1*
(grammar
:lexicon
'((Noun -> stench breeze glitter nothing wumpus pit pits
gold north south east west)
(Verb -> is see smell shoot shot feel stinks go grab
carry kill turn)
(Adjective -> right left east south back smelly)
(Adverb -> here there nearby ahead right left
north south east west back)
((Pronoun subjective) -> I you he she)
((Pronoun objective) -> me you him her)
((Pronoun $case) -> it)
(Name -> John Mary Boston Aristotle)
(Article -> the a an)
(Preposition -> to in on near)
(Conjunction -> and or but)
(Digit -> 0 1 2 3 4 5 6 7 8 9)
(that -> that))
:rules
'((S -> (NP subjective) VP)
(S -> S Conjunction S)
((NP $case) -> (Pronoun $case))
((NP $case) -> Noun)
((NP $case) -> Article Noun)
((NP $case) -> Digit Digit)
((NP $case) -> (NP $case) PP)
((NP $case) -> (NP $case) RelClause)
(VP -> Verb)
(VP -> Verb (NP objective))
(VP -> Verb Adjective)
(VP -> Verb PP)
(VP -> Verb Adverb)
(PP -> Preposition (NP objective))
(RelClause -> that VP)))
"Lexicon and grammar for E1 in Figure 22.10, page 670.")
(defparameter *E2*
(grammar
:lexicon
'(((Noun $w) -> stench breeze glitter nothing wumpus pit pits
gold north south east west)
((Verb $w) -> is see smell shoot shot feel stinks go grab
carry kill turn)
((Adjective $w) -> right left east south back smelly)
((Adverb $w) -> here there nearby ahead right left
north south east west back)
((Pronoun $w) -> me you I it)
((Name $w) -> John Mary Boston Aristotle)
((Article $w) -> the a an)
((Preposition $w) -> to in on near)
((Conjunction $w) -> and or but)
((Digit $w) -> 0 1 2 3 4 5 6 7 8 9)
(that -> that))
:rules
'(((S ($rel $obj)) -> (NP $obj) (VP $rel))
((S ($conj $sem1 $sem2)) -> (S $sem1) (Conjunction $conj) (S $sem2))
((NP $sem) -> (Pronoun $sem))
((NP $sem) -> (Name $sem))
;; ?? Need nouns with no article, e.g. "dogs" is an NP
((NP ($q $x ($sem $x))) -> (Article $q) (Noun $sem))
((NP ($q $x (and $obj ($rel $x)))) -> (NP ($q $x $obj)) (PP $rel))
((NP ($q $x (and $obj ($rel $x)))) -> (NP ($q $x $obj)) (RelClause $rel))
((NP (@ $sem1 $sem2) -> (Digit $sem1) (Digit $sem2)))
;; VP rules for subcategorization
((VP $sem) -> (Verb $sem))
((VP ($rel $obj)) -> (VP $rel) (NP $obj))
((VP ($sem1 $sem2)) -> (VP $sem1) (Adjective $sem2))
((VP ($sem1 $sem2)) -> (VP $sem1) (PP $sem2))
;; VP rules for adjuncts
((VP (lambda $x (and ($sem1 $x) ($sem2 (event-var $sem1))))) ->
(VP $sem1) (PP $sem2))
((VP (lambda $x (and ($sem1 $x) ($sem2 (event-var $sem1))))) ->
(VP $sem1) (Adverb $sem2))
((RelClause $sem) -> that (VP $sem))
((PP (lambda $x ($rel $x $obj))) -> (Preposition $rel) (NP $obj))))
"Lexicon and grammar for E2 in Figure 22.19, page 680.")
;;;; Other grammars: Arithmetic, Trivial
(defparameter *arithmetic-grammar*
(grammar
:start-symbol 'Exp
:rules
'(((Exp ($op $sem1 $sem2)) -> (Exp $sem1) (Operator $op) (Exp $sem2))
((Exp $sem) -> [ (Exp $sem) ])
((Exp $sem) -> (Number $sem))
((Number $sem) -> (Digit $sem))
((Number (+ (* 10 $sem1) $sem2)) -> (Number $sem1) (Digit $sem2)))
:lexicon
'(((Digit $w) -> 0 1 2 3 4 5 6 7 8 9)
((Operator $w) -> + - * /)
([ -> \( [)
(] -> \) ])))
"A grammar of arithmetic expressions, with semantics, from Figure 22.13,
page 673.")
(defparameter *figure23.4*
(grammar
:lexicon (grammar-lexicon *E0*)
:rules
'((S -> NP VP)
(NP -> Pronoun)
(VP -> Verb)
(VP -> VP NP)))
"A grammar that, with debugging on, produces output similar to that
on page 700, Figure 23.4. The differences are: (1) Scanner does two
steps in the book; here those steps are broken into Scanner and Completer.
(2) Some 'irrelevant' edges were ommitted from Figure 23.4") language/domains/wumpus-grammar.lisp 0100644 0002635 0000472 00000003570 06200252701 020117 0 ustar russell russell ;;; -*- Mode: Lisp; -*- Author: Peter Norvig
;;;; A grammar for the wumpus world
(defparameter *E1*
(grammar
:lexicon
'((Noun -> stench breeze glitter nothing wumpus pit pits
gold north south east west)
(Verb -> is am are see smell shoot feel stinks go grab release
carry kill turn)
(Adjective -> right left east south back smelly)
(Adverb -> here there nearby ahead right left
north south east west back)
((Pronoun subjective) -> I you he she it) ;; change here
((Pronoun objective) -> me you him her it) ;; change here
(Name -> John Mary Boston Aristotle)
(Article -> the a an)
(Preposition -> from to at in on near)
(Conjunction -> and or but)
(Digit -> 0 1 2 3 4 5 6 7 8 9)
(that -> that))
:rules
'((S -> (NP subjective) VP) ;; changes start here
(S -> S Conjunction S)
((NP $case) -> (Pronoun $case))
((NP $case) -> Noun)
((NP $case) -> Article Noun)
((NP $case) -> Digit Digit)
((NP $case) -> (NP $case) PP)
((NP $case) -> (NP $case) RelClause)
(VP -> Verb)
(VP -> Verb (NP objective))
(VP -> Verb Adjective)
(VP -> Verb PP)
(VP -> Verb Adverb)
(PP -> Preposition (NP objective)) ;; changes end here
(RelClause -> that VP)))
"Lexicon and grammar for E1 in Figure 22.10, page 670.")
will, did
a, the
--
yes, no, maybe, ok, huh
S -> Question | Command | Report | Acknowledgement | S -- S
Question -> Aux NP VP | Be NP VP-args
Command -> "you" VP
Report -> "I" VP
NP -> Pronoun | {Article} Noun
VP -> {Aux} Verb VP-args
VP-args -> {NP} {PP} {Adverb}
PP -> Prep NP
;;; Terminals
Acknowledgement -> "yes" | "no" | "ok" | "huh"
Verb -> Aux | "shoot" | ...
Aux -> Be | "will" | "did"
Be -> "is" | "am" | "are"
Adverb -> "here" | ...
language/test-language.lisp 0100644 0002635 0000472 00000006771 06222336663 016265 0 ustar russell russell
(deftest language
"Test the chart parser on some grammars."
"First the simple E0 grammar from page 665."
((chart-parses '(I smell a stench) *E0*)
'((S (NP (PRONOUN I))
(VP (VP (VERB SMELL)) (NP (ARTICLE A) (NOUN STENCH))))))
((chart-parses '(the gold is in 2 2) *E0*)
'((S (NP (ARTICLE THE) (NOUN GOLD))
(VP (VP (VERB IS)) (PP (PREPOSITION IN) (NP (DIGIT 2) (DIGIT 2)))))))
"Now the E1 grammar to show how pronoun case is handled."
"It is grammatical to use 'I' as a subject, but not 'me'."
((chart-parses '(I shot the wumpus) *E1*)
(renaming? * '((S ((NP SUBJECTIVE) ((PRONOUN SUBJECTIVE) I))
(VP (VERB SHOT)
((NP $CASE.10) (ARTICLE THE) (NOUN WUMPUS)))))))
((chart-parses '(Me shot the wumpus) *E1*)
'NIL)
"The E0 grammar allows anything (including 'me') as a subject:"
((chart-parses '(Me shot the wumpus) *E0*)
'((S (NP (PRONOUN ME))
(VP (VP (VERB SHOT)) (NP (ARTICLE THE) (NOUN WUMPUS))))))
"Now for a longer sentence"
((chart-parses '(I see the wumpus in 2 3 and it is smelly ) *e1*)
(renaming?
*
'((S (S ((NP SUBJECTIVE) ((PRONOUN SUBJECTIVE) I))
(VP (VERB SEE)
((NP $CASE.218) ((NP $CASE.220) (ARTICLE THE) (NOUN WUMPUS))
(PP (PREPOSITION IN) ((NP $CASE.225) (DIGIT 2) (DIGIT 3))))))
(CONJUNCTION AND)
(S ((NP $CASE.234) ((PRONOUN $CASE) IT))
(VP (VERB IS) (ADJECTIVE SMELLY)))))))
"An example from the simple arithmetic grammar."
((chart-parses '([ 1 + 2 ] * 3 0) *arithmetic-grammar*)
'(((EXP (* (+ 1 2) (+ (* 10 3) 0)))
((EXP (+ 1 2))
([ [)
((EXP (+ 1 2))
((EXP 1) ((NUMBER 1) ((DIGIT 1) 1)))
((OPERATOR +) +)
((EXP 2) ((NUMBER 2) ((DIGIT 2) 2))))
(] ]))
((OPERATOR *) *)
((EXP (+ (* 10 3) 0))
((NUMBER (+ (* 10 3) 0)) ((NUMBER 3) ((DIGIT 3) 3)) ((DIGIT 0) 0))))))
"The function MEANINGS picks out just the semantics"
((meanings '([ 1 + 2 ] * 3 0) *arithmetic-grammar*)
'((* (+ 1 2) (+ (* 10 3) 0))))
"Note that strings can be ambiguous, yielding two or more parses."
((meanings '(1 + 2 * 3) *arithmetic-grammar*)
'((* (+ 1 2) 3) (+ 1 (* 2 3))))
((chart-parses '(1 + 2 * 3) *arithmetic-grammar*)
'(((EXP (* (+ 1 2) 3))
((EXP (+ 1 2)) ((EXP 1) ((NUMBER 1) ((DIGIT 1) 1)))
((OPERATOR +) +) ((EXP 2) ((NUMBER 2) ((DIGIT 2) 2))))
((OPERATOR *) *) ((EXP 3) ((NUMBER 3) ((DIGIT 3) 3))))
((EXP (+ 1 (* 2 3)))
((EXP 1) ((NUMBER 1) ((DIGIT 1) 1)))
((OPERATOR +) +)
((EXP (* 2 3)) ((EXP 2) ((NUMBER 2) ((DIGIT 2) 2))) ((OPERATOR *) *)
((EXP 3) ((NUMBER 3) ((DIGIT 3) 3)))))))
((chart-parses '(i shot the wumpus that stinks) *e2*)
(renaming?
*
'(((S ((SHOT (THE $X.648 (AND (WUMPUS $X.648) (STINKS $X.648)))) I))
((NP I) ((PRONOUN I) I))
((VP (SHOT (THE $X.648 (AND (WUMPUS $X.648) (STINKS $X.648)))))
((VP SHOT) ((VERB SHOT) SHOT))
((NP (THE $X.648 (AND (WUMPUS $X.648) (STINKS $X.648))))
((NP (THE $X.655 (WUMPUS $X.655))) ((ARTICLE THE) THE)
((NOUN WUMPUS) WUMPUS))
((RELCLAUSE STINKS) (THAT THAT)
((VP STINKS) ((VERB STINKS) STINKS)))))))))
((meanings '(i shoot the wumpus that stinks and i grab the gold) *e2*)
(renaming?
*
'((AND ((SHOOT (THE $X.746 (AND (WUMPUS $X.746) (STINKS $X.746)))) I)
((GRAB (THE $X.851 (GOLD $X.851))) I)))))
) language/algorithms/ 0040755 0002635 0000472 00000000000 06326754714 015003 5 ustar russell russell language/algorithms/chart-parse.lisp 0100644 0002635 0000472 00000016101 06222572074 020071 0 ustar russell russell ;;;; Chart Parser with Unification Augmentation
(defstructure grammar
"A grammar for a chart parser has rules indexed by word and LHS."
(lexicon nil)
(rules nil)
(start-symbol 'S)
(categories-for (make-hash-table :test #'eq))
(rewrites-for (make-hash-table :test #'eq))
(unknown-word-cats '(noun verb adjective adverb)))
(defvar *grammar* nil
"The currently used grammar. Defining a new grammar changes this, or you
can set it yourself.")
(defun rule-lhs (rule) "The left hand side." (first rule))
(defun rule-rhs (rule) "The right-hand side." (nthcdr 2 rule))
(defstructure chart
"A chart has a vector that holds the edges that end at vertex i."
;; A more efficient implementation would store other things
(ends-at #()))
(defstructure (edge)
"An edge represents a dotted rule instance. In the edge [i, j, L -> F . R],
i is the start, j is the end, L is the lhs, (F) is found, and (R) remains."
;; The FOUND slot is stored in reverse order, so you can just push on it.
start end lhs found remains bindings)
;;;; Chart Parsing Algorithm
(defun chart-parse (words &optional (*grammar* *grammar*))
"See if the string of words can be parsed by the grammar. (See page 702.)"
(let ((chart (make-chart :ends-at (make-array (+ 1 (length words))
:initial-element nil))))
(add-edge (edge 0 0 'S* nil (list (grammar-start-symbol *grammar*)))
chart 'initializer)
(for v = 0 to (- (length words) 1) do
(scanner v (elt words v) chart))
chart))
(defun scanner (j word chart)
"Add edges everywhere WORD is expected."
(for each cat in (categories-for word *grammar*) do
(dprint "scanner:" cat (elt (chart-ends-at chart) j))
(when (member cat (elt (chart-ends-at chart) j)
:test #'unify :key #'edge-expects)
(add-edge (edge j (+ j 1) cat (list word) nil) chart 'scanner))))
(defun predictor (edge chart)
"Add edges saying what we expect to see here."
(for each rule in (rewrites-for (op (edge-expects edge)) *grammar*) do
(add-edge (edge (edge-end edge) (edge-end edge)
(rule-lhs rule)
nil (rule-rhs rule))
chart 'predictor)))
(defun completer (edge chart)
"Use this edge to extend any edges in the chart."
(for each old-edge in (elt (chart-ends-at chart) (edge-start edge)) do
(let ((b (unify (edge-lhs edge) (edge-expects old-edge)
(edge-bindings old-edge))))
(when b
(add-edge (edge (edge-start old-edge) (edge-end edge)
(edge-lhs old-edge)
(cons edge (edge-found old-edge))
(rest (edge-remains old-edge))
b)
chart 'completer)))))
(defun add-edge (edge chart &optional reason)
"Put edge into chart, and complete or predict as appropriate."
(unless (member edge (elt (chart-ends-at chart) (edge-end edge))
:test #'edge-equal)
(when (handle-augmentation *grammar* edge)
(push edge (elt (chart-ends-at chart) (edge-end edge)))
(dprint reason edge);; debugging output (as in Figure 23.4, [p 700])
(if (complete? edge)
(completer edge chart)
(predictor edge chart)))))
;;;; Other Top-Level Functions
(defun chart-parses (words &optional (*grammar* *grammar*))
"See if the string of words can be parsed by the grammar. If it can, look
into the chart and pull out complete spanning strings."
(mapcar #'edge->tree (spanning-edges (chart-parse words *grammar*))))
(defun meanings (words &optional (*grammar* *grammar*))
"Parse words, then pick out the semantics of each parse.
Assumes the semantics will be the last element of the LHS."
(delete-duplicates
(mapcar #'(lambda (edge) (last1 (mklist (edge-lhs edge))))
(spanning-edges (chart-parse words *grammar*)))
:test #'equal))
;;;; Auxiliary Functions
(defun spanning-edges (chart)
"Find the edges that span the chart and form the start symbol."
(remove-if-not
#'(lambda (e)
(and (complete? e)
(eql (edge-start e) 0)
(eq (op (edge-lhs e)) (grammar-start-symbol *grammar*))))
(elt (chart-ends-at chart) (- (length (chart-ends-at chart)) 1))))
(defun edge->tree (edge)
"Convert an edge into a parse tree by including its FOUND parts."
(cond ((edge-p edge)
(cons (edge-lhs edge)
(mapcar #'edge->tree (reverse (edge-found edge)))))
(t edge)))
(defun edge (start end lhs found remains &optional (bindings +no-bindings+))
"Construct a new edge."
(make-edge :start start :end end :lhs lhs :found found :remains remains
:bindings bindings))
(defun grammar (&rest args)
"Take a list of rules, index them to form a grammar for chart-parse."
(setf *grammar* (apply #'make-grammar args))
(for each rule in (grammar-lexicon *grammar*) do
(for each word in (rule-rhs rule) do
;; Rule [A -> word] means index A under categories-for word
;; Replace (A $w) with (A word)
(let ((lhs (subst-bindings `(($w . ,word)) (rule-lhs rule))))
(push lhs (gethash word (grammar-categories-for *grammar*))))))
(for each rule in (grammar-rules *grammar*) do
;; Rule [A -> B C] indexed under rewrites for A
(push rule (gethash (op (rule-lhs rule))
(grammar-rewrites-for *grammar*))))
*grammar*)
(defun rewrites-for (lhs grammar)
"Find the rules in grammar with LHS as the left hand side."
(gethash (op lhs) (grammar-rewrites-for grammar)))
(defun categories-for (word grammar)
"Find what categories this word can be.
For unknown words, use the grammar's unknown-word-cats field"
(or (gethash word (grammar-categories-for grammar))
(subst word '$w (grammar-unknown-word-cats grammar))))
(defun edge-expects (edge)
"What does the edge expect next in order to be extended?"
(first (edge-remains edge)))
(defun lhs-op (edge)
"Left hand side of an edge's category"
(if (edge-p edge) (op (edge-lhs edge)) edge))
(defun complete? (edge)
"An edge is complete if it has no remaining constituents."
(null (edge-remains edge)))
(defun edge-equal (edge1 edge2)
"Are two edges the same, up to renaming of the parts with variables?"
(and (eql (edge-start edge1) (edge-start edge2))
(eql (edge-end edge1) (edge-end edge2))
(eql (op (edge-lhs edge1)) (op (edge-lhs edge2)))
(renaming? (edge-found edge1) (edge-found edge2))
(renaming? (edge-remains edge1) (edge-remains edge2))))
(defmethod handle-augmentation ((grammar grammar) edge)
"There are two things to do: (1) When we start a new edge, rename vars.
(2) When an edge is complete, substitute the bindings into the lhs."
(when (null (edge-found edge)) ;; (1) rename vars
(let ((new (rename-variables (cons (edge-lhs edge) (edge-remains edge)))))
(setf (edge-lhs edge) (first new)
(edge-remains edge) (rest new))))
(when (complete? edge) ;; (2) substitute bindings into lhs
(setf (edge-lhs edge)
(subst-bindings (edge-bindings edge) (edge-lhs edge))))
(edge-bindings edge))
(defmethod print-structure ((e edge) stream)
(format stream "[~D, ~D, ~A ->~{ ~A~} .~{ ~A~}]"
(edge-start e) (edge-end e) (lhs-op e)
(nreverse (mapcar #'lhs-op (edge-found e)))
(mapcar #'lhs-op (edge-remains e))))
language/README.html 0100644 0002635 0000472 00000002336 06235723735 014454 0 ustar russell russell
Language (Subsystem of AIMA Code)
Language (Subsystem of AIMA Code)
The language subsystem covers the natural language processing
code from Chapters 22 and 23 of the book. The main parsing function
is chart-parse, but it returns a chart, which is not very
useful in itself, so most of the test
examples call chart-parses, which returns a list of
parses for the complete input string, or meanings which pulls
out the semantic component of each parse.
Several sample grammars are shown.
For the most part, they follow the notation from the book. The
differences are:
- Obviously, the grammars are in Lisp notation.
- The symbol $w on the left-hand side of a lexical rule stands
for the word itself on the right-hand side. This allows you to put multiple
lexical entries on one line.
- The grammar can specify a list of :unknown-word-cats. That means
that when an unknown word is encountered in the input, it is assumed to be
one of these categories.
logic/ 0040755 0002635 0000472 00000000000 06326754524 012143 5 ustar russell russell logic/README.html 0100644 0002635 0000472 00000004355 06324547335 013770 0 ustar russell russell
Logic (Subsystem of AIMA Code)
Logic (Subsystem of AIMA Code)
The logic system covers part III of the book. We define
knowledge bases, and tell and ask operations on
those knowledge bases. The interface is defined in the file tell-ask.lisp.
We need a new language for logical expressions,
since we don't have all the nice characters (like upside-down A) that
we would like to use. We will allow an infix format for input, and
manipulate a Lisp-like prefix format internally. Here is a
description of the formats (compare to [p 167, 187]). The prefix
notation is a subset of the KIF
3.0 Knowledge Interchange Format.
Infix Prefix Meaning Alternate Infix Notation
========== ====== =========== ========================
~P (not P) negation not P
P ^ Q (and P Q) conjunction P and Q
P | Q (or P Q) disjunction P or Q
P => Q (=> P Q) implication
P <=> Q (<=> P Q) logical equivalence
P(x) (P x) predicate
Q(x,y) (Q x y) predicate with multiple arguments
f(x) (f x) function
f(x)=3 (= (f x) 3) equality
forall(x,P(x) (forall (x) (P x)) universal quantification
exists(x,P(x) (exists (x) (P x)) existential quantification
[a,b] (listof a b) list of elements
{a,b} (setof a b) mathematical set of elements
true true the true logical constant
false false the false logical constant
You can also use the usual operators for mathematical notation: +, -,
*, / for arithmetic, and &;lt;, >, <=, >= for comparison.
Many of the functions we define also accept strings as input,
interpreting them as infix expressions, so the following are
equivalent:
(tell kb "P=>Q")
(tell kb '(=> P Q))
logic/test-logic.lisp 0100644 0002635 0000472 00000007223 06223046704 015075 0 ustar russell russell ;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- File: logic/test.lisp
;;;; Testing Logical Inference
(deftest logic
"Some simple examples in Propositional Logic"
"First, just test the infix reader."
((logic "P=>Q <=> ~Q=>~P") '(<=> (=> P Q) (=> (not Q) (not P))))
"Print a truth table, as on [p 169]."
((truth-table "(P | H) ^ ~H => P"))
"Some simple examples"
((validity "P=>Q <=> ~Q=>~P") 'valid)
((validity "SillyQuestion") 'satisfiable)
((validity "~SillyQuestion") 'satisfiable)
((validity "ToBe or not ToBe") 'valid)
((validity "ToBe and not ToBe") 'unsatisfiable)
((validity "((S => W1|W2|W3|W4) ^ S ^ (~W1^~W2^~W3)) => W4") 'valid)
((validity "Ok ^ (Ok <=> ~W^~P) => ~W") 'valid)
((setf kb (make-prop-kb)))
((tell kb "S => W1|W2|W3|W4"))
((tell kb "S"))
((tell kb "~W1"))
((tell kb "~W2"))
((ask kb "W4") 'nil)
((tell kb "~W3"))
((ask kb "W4") 't)
((tell kb "Ok <=> ~W ^ ~P"))
((tell kb "Ok"))
((ask kb "W") 'nil)
((ask kb "~W") 't)
((tell kb "ToBe and ~ToBe"))
((ask kb "SillyQuestion") 't)
"A look at Normal forms (conjunctive, implicative, and Horn)."
((->cnf '(<=> P Q))
'(AND (OR P (NOT Q)) (OR (NOT P) Q)))
((->inf '(<=> P Q))
'(AND (=> Q P) (=> P Q)))
((->horn '(<=> P Q))
'(AND (=> Q P) (=> P Q)))
((->cnf '(=> (not P) R))
'(OR R P))
((->inf '(=> (not P) R))
'(=> TRUE (OR R P)))
"Use the KB to solve the `Wumpus at [1,3]' problem [p 174-176]."
"This builds a KB with 12 propositional symbols -- about the max."
"you can do without starting to slow down."
((setq kb1 (make-prop-kb)))
"The initial state of knowledge"
((tell kb1 "~S11 ^ ~S21 ^S12 ^ ~B11 ^ B21 ^ ~B12"))
"Rules R1 through R4"
((tell kb1 "~S11 => ~W11 ^ ~W12 ^ ~W21"))
((tell kb1 "~S21 => ~W11 ^ ~W21 ^ ~W22 ^ ~W31"))
((tell kb1 "~S12 => ~W11 ^ ~W12 ^ ~W22 ^ ~W13"))
((tell kb1 "S12 => W13 | W12 | W22 | W11"))
"Now the query -- this may take a while."
((ask kb1 "W13") *)
"Now a quick demo of the Horn Logic backward chainer."
((setf kb2 (make-horn-kb)))
"Now we define the Member predicate."
((tell kb2 "Member(x,Cons(x,y))"))
((tell kb2 "Member(x,rest) => Member(x,Cons(y,rest))"))
((ask-each kb2 "Member(x,Cons(1,Cons(2,Cons(3,Nil))))" #'print))
((ask-patterns kb2 "Member(x,Cons(1,Cons(2,Cons(3,Nil))))" "x") '(1 2 3))
((ask-pattern kb2 "Member(x,Cons(1,Cons(2,Cons(3,Nil)))) & x=2" "x") '2)
((ask-patterns kb2 "s = Cons(1,Cons(2,Nil))
& Member(x,s) & Member(y,s)" '($x $y))
'((1 1) (1 2) (2 1) (2 2)))
"A family relationships knowledge base and problem."
((tell kb2 '(Mother Gerda Peter)))
((tell kb2 '(Father Torsten Peter)))
((tell kb2 '(Father Peter Isabella)))
((tell kb2 '(Father Peter Juliet)))
((tell kb2 '(=> (mother $x $y) (parent $x $y))))
((tell kb2 '(=> (father $x $y) (parent $x $y))))
((tell kb2 '(=> (and (parent $g $p) (parent $p $c)) (grand-parent $g $c))))
((ask-patterns kb2 '(grand-parent $x $y))
'((Grand-parent Gerda Isabella) (Grand-parent Gerda Juliet)
(Grand-parent Torsten Isabella) (Grand-parent Torsten Juliet)))
"Now the 'Criminal' problem from [p 271-272]."
((setf kb3 (make-horn-kb)))
((tell kb3 "American(x) ^ Weapon(y) ^ Nation(z) ^ Hostile(z) ^ Sells(x,z,y)
=> Criminal(x)"))
((tell kb3 "Owns(Nono,M1)"))
((tell kb3 "Missle(M1)"))
((tell kb3 "Owns(Nono,x) ^ Missle(x) => Sells(West,Nono,x)"))
((tell kb3 "Missle(x) => Weapon(x)"))
((tell kb3 "Enemy(x,America) => Hostile(x)"))
((tell kb3 "American(West)"))
((tell kb3 "Nation(Nono)"))
((tell kb3 "Enemy(Nono,America)"))
((tell kb3 "Nation(America)"))
((ask kb3 "Criminal(West)") 't)
((ask-pattern kb3 "Criminal(x)" "x") 'West)
)
logic/domains/ 0040755 0002635 0000472 00000000000 06237320271 013562 5 ustar russell russell logic/algorithms/ 0040755 0002635 0000472 00000000000 06326754714 014315 5 ustar russell russell logic/algorithms/fol.lisp 0100644 0002635 0000472 00000011005 06316431646 015753 0 ustar russell russell ;;;; First Order Logic (FOL) Tell, Retract, and Ask-Each
(defstruct fol-kb
;;; A FOL (First-Order Logic) KB stores clauses.
;;; Access to the KB is via POSSIBLE-RESOLVERS, which takes a
;;; literal (e.g. (not D), or B), and returns all the clauses that
;;; contain the literal. We also keep a list of temporary clauses,
;;; added to the KB during a proof and removed at the end. Internally,
;;; clauses are in minimal-cnf format, which is CNF without the and/or.
;;; So (and (or P Q) (or R (not S))) becomes ((P Q) (R (not S)))
(positive-clauses (make-hash-table :test #'eq))
(negative-clauses (make-hash-table :test #'eq))
(temp-added nil))
(defmethod tell ((kb fol-kb) sentence)
"Add a sentence to a FOL knowledge base."
(for each clause in (->minimal-cnf sentence) do
(tell-minimal-cnf-clause kb clause)))
(defmethod retract ((kb fol-kb) sentence)
"Delete each conjunct of sentence from KB."
(retract-minimal-cnf-clauses kb (->minimal-cnf sentence)))
(defmethod ask-each ((kb fol-kb) query fn)
"Use resolution to decide if sentence is true."
(prove-by-refutation kb (->minimal-cnf `(not ,query)) fn))
;;;; FOL Knowledge Base Utility Functions
(defun possible-resolvers (kb literal)
"Find clauses that might resolve with a clause containing literal."
(if (eq (op literal) 'not)
(gethash (op (arg1 literal)) (fol-kb-negative-clauses kb))
(gethash (op literal) (fol-kb-positive-clauses kb))))
(defun tell-minimal-cnf-clause (kb clause)
;; We don't add tautologies like "P | ~P".
;; It would be good to eliminate subsumed clauses like
;; Eq(1,1) when Eq(x,x) is already in the kb.
;; Currently we don't check for that.
(unless (tautology? clause)
(for each literal in clause do
(if (eq (op literal) 'not)
(push clause (gethash (op (arg1 literal))
(fol-kb-negative-clauses kb)))
(push clause (gethash (op literal)
(fol-kb-positive-clauses kb)))))))
(defun retract-minimal-cnf-clauses (kb clauses)
"Remove the minimal-cnf clauses from the KB."
(for each clause in clauses do
(for each literal in clause do
(if (eq (op literal) 'not)
(deletef clause
(gethash (op (arg1 literal))
(fol-kb-negative-clauses kb)))
(deletef clause (gethash (op literal)
(fol-kb-positive-clauses kb)))))))
(defun ->minimal-cnf (sentence)
"Convert a logical sentence to minimal CNF (no and/or connectives)."
;; E.g., (and (or P (not Q) R) S) becomes ((P (not Q) R) (S))
;; Everything internal in the FOL module uses minimal-cnf
;; Only tell, retract, and ask-* use the regular logical form.
(mapcar #'disjuncts (conjuncts (->cnf sentence))))
(defun undo-temp-changes (kb)
"Undo the changes that were temporarilly made to KB."
(retract-minimal-cnf-clauses kb (fol-kb-temp-added kb))
(setf (fol-kb-temp-added kb) nil))
(defun tautology? (clause)
"Is clause a tautology (something that is always true)?"
(some #'(lambda (literal)
(and (eq (op literal) 'not)
(member (arg1 literal) clause :test #'equal)))
clause))
;;;; Functions for Resolution Refutation Theorem Proving
(defun prove-by-refutation (kb sos fn)
"Try to prove that ~SOS is true (given KB) by resolution refutation."
;; Call FN on every substitution that leads to a proof.
;; Similar to OTTER [p. 311], the KB plays the role of the usable
;; (background) axioms, and SOS (set of support) is formed by the
;; negation of the query. Uses set of support heuristic and uses
;; shorter clauses first (which is a generalization of the unit
;; preference strategy). Filters out tautologies.
(setf sos (sort sos #'< :key #'length))
(undo-temp-changes kb)
(let (clause)
(loop
(when (null sos) (RETURN nil))
;; Move clause from SOS to the usable KB
(setf clause (pop sos))
(tell-minimal-cnf-clause kb clause)
(push clause (fol-kb-temp-added kb))
;; Process everything that resolves with CLAUSE
(for each literal in clause do
(for each r in (possible-resolvers kb literal) do
(let ((b (unify ??? literal)))
(when b
(setf sos (insert clause sos #'< :key #'length))
(case (length clause)
(0 (funcall fn b)) ;; refutation found!!
; should look for unit refutation if length is 1
))))))))
(defun resolve (literal clause)
"Resolve a single literal against a clause"
)
(defun insert (item list pred &key (key #'identity))
(merge 'list (list item) list pred :key key))
logic/algorithms/horn.lisp 0100644 0002635 0000472 00000004612 06325073047 016144 0 ustar russell russell ;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- File: logic/horn.lisp
;;;; Logical Reasoning in Horn Clause Knowledge Bases
(defstructure horn-kb
;; Index all Horn sentences by the predicate on the right-hand side.
;; That is, both (=> P (Q x)) and (Q 3) would be indexed under Q.
(table (make-hash-table :test #'eq)))
(defmethod tell ((kb horn-kb) sentence)
"Add a sentence to a Horn knowledge base. Warn if its not a Horn sentence."
(for each clause in (conjuncts (->horn sentence)) do
;; Each clause should be of form (=> P (Q x)); add to hash for Q
(setf (gethash (op (arg2 clause)) (horn-kb-table kb))
(nconc (gethash (op (arg2 clause)) (horn-kb-table kb))
(list clause)))))
(defmethod retract ((kb horn-kb) sentence)
"Delete each conjunct of sentence from KB."
(for each clause in (conjuncts (->horn sentence)) do
;; Each clause should be of form (=> P (Q x)); delete from hash for Q
(deletef clause (gethash (op (arg2 clause)) (horn-kb-table kb))
:test #'renaming?)))
(defmethod ask-each ((kb horn-kb) query fn)
"Use backward chaining to decide if sentence is true."
(back-chain-each kb (conjuncts (->cnf query)) +no-bindings+ fn))
(defun back-chain-each (kb goals bindings fn)
"Solve the conjunction of goals by backward chaining.
See [p 275], but notice that this implementation is different.
It applies fn to each answer found, and handles composition differently."
(cond ((eq bindings +fail+) +fail+)
((null goals) (funcall fn bindings))
(t (let ((goal (first goals)))
(case (op goal)
(FALSE +fail+)
(TRUE (back-chain-each kb (rest goals) bindings fn))
(= (back-chain-each kb (rest goals)
(unify (arg1 goal) (arg2 goal) bindings)
fn))
(AND (back-chain-each kb (append (conjuncts goal) goals)
bindings fn))
(OR (for each disjunct in (disjuncts goal) do
(back-chain-each kb (cons disjunct goals)
bindings fn)))
(NOT +fail+) ; Horn clause provers can't handle NOT
(t ;; Look at all the clauses that could conclude the goal.
(for each clause in (gethash (op goal) (horn-kb-table kb)) do
(let ((new-clause (rename-variables clause)))
(back-chain-each
kb
(append (conjuncts (arg1 new-clause)) (rest goals))
(unify goal (arg2 new-clause) bindings)
fn)))))))))
logic/algorithms/infix.lisp 0100644 0002635 0000472 00000012075 06325071546 016317 0 ustar russell russell ;;;-*- Mode: Lisp; -*-
;;;; Prefix to Infix Conversion
(defparameter *infix-ops*
'((([ list match ]) ({ elts match }) (|(| nil match |)|))
((*) (/))
((+) (-))
((<) (>) (<=) (>=) (=) (/=))
((not not unary) (~ not unary))
((and) (& and) (^ and))
((or) (\| or))
((=>))
((<=>))
((|,|)))
"A list of lists of operators, highest precedence first.")
(defun ->prefix (infix)
"Convert an infix expression to prefix."
(when (stringp infix) (setf infix (string->infix infix)))
;; INFIX is a list of elements; each one is in prefix notation.
;; Keep reducing (most tightly bound first) until there is only one
;; element left in the list. Example: In two reductions we go:
;; (a + b * c) => (a + (* b c)) => ((+ a (* b c)))
(loop
(when (not (length>1 infix)) (RETURN (first infix)))
(setf infix (reduce-infix infix))))
(defun reduce-infix (infix)
"Find the highest-precedence operator in INFIX and reduce accordingly."
(dolist (ops *infix-ops* (error "Bad syntax for infix expression: ~S" infix))
(let* ((pos (position-if #'(lambda (i) (assoc i ops)) infix
:from-end (eq (op-type (first ops)) 'MATCH)))
(op (when pos (assoc (elt infix pos) ops))))
(when pos
(RETURN
(case (op-type op)
(MATCH (reduce-matching-op op pos infix))
(UNARY (replace-subseq infix pos 2
(list (op-name op)
(elt infix (+ pos 1)))))
(BINARY (replace-subseq infix (- pos 1) 3
(list (op-name op)
(elt infix (- pos 1))
(elt infix (+ pos 1)))))))))))
(defun op-token (op) (first op))
(defun op-name (op) (or (second op) (first op)))
(defun op-type (op) (or (third op) 'BINARY))
(defun op-match (op) (fourth op))
(defun replace-subseq (sequence start length new)
(nconc (subseq sequence 0 start) (list new)
(subseq sequence (+ start length))))
(defun reduce-matching-op (op pos infix)
"Find the matching op (paren or bracket) and reduce."
;; Note we don't worry about nested parens because we search :from-end
(let* ((end (position (op-match op) infix :start pos))
(len (+ 1 (- end pos)))
(inside-parens (remove-commas (->prefix (subseq infix (+ pos 1) end)))))
(cond ((not (eq (op-name op) '|(|)) ;; handle {a,b} or [a,b]
(replace-subseq infix pos len
(cons (op-name op) inside-parens))) ; {set}
((and (> pos 0) ;; handle f(a,b)
(function-symbol? (elt infix (- pos 1))))
(handle-quantifiers
(replace-subseq infix (- pos 1) (+ len 1)
(cons (elt infix (- pos 1)) inside-parens))))
(t ;; handle (a + b)
(assert (length=1 inside-parens))
(replace-subseq infix pos len (first inside-parens))))))
(defun remove-commas (exp)
"Convert (|,| a b) to (a b)."
(cond ((eq (op exp) '|,|) (nconc (remove-commas (arg1 exp) )
(remove-commas (arg2 exp))))
(t (list exp))))
(defun handle-quantifiers (exp)
"Change (FORALL x y P) to (FORALL (x y) P)."
(if (member (op exp) '(FORALL EXISTS))
`(,(op exp) ,(butlast (rest exp)) ,(last1 exp))
exp))
;;;; Tokenization: convert a string to a sequence of tokens
(defun string->infix (string &optional (start 0))
"Convert a string to a list of tokens."
(multiple-value-bind (token i) (parse-infix-token string start)
(cond ((null token) nil)
((null i) (list token))
(t (cons token (string->infix string i))))))
(defun parse-infix-token (string start)
"Return the first token in string and the position after it, or nil."
(let* ((i (position-if-not #'whitespace? string :start start))
(ch (if i (char string i))))
(cond ((null i) (values nil nil))
((find ch "+-~()[]{},") (values (intern (string ch)) (+ i 1)))
((find ch "0123456789") (parse-integer string :start i :junk-allowed t))
((symbol-char? ch) (parse-span string #'symbol-char? i))
((operator-char? ch) (parse-span string #'operator-char? i))
(t (error "unexpected character: ~C" ch)))))
(defun parse-span (string pred i)
(let ((j (position-if-not pred string :start i)))
(values (make-logic-symbol (subseq string i j)) j)))
(defun make-logic-symbol (string)
"Convert string to symbol, preserving case, except for AND/OR/NOT/FORALL/EXISTS."
(cond ((find string '(and or not forall exists) :test #'string-equal))
((lower-case-p (char string 0))
(concat-symbol "$" (string-upcase string)))
((equal string "Nil") '|Nil|)
(t (intern (string-upcase string)))))
(defun operator-char? (x) (find x "<=>&^|*/,"))
(defun symbol-char? (x) (or (alphanumericp x) (find x "$!?%")))
(defun function-symbol? (x)
(and (symbolp x) (not (member x '(and or not ||)))
(alphanumericp (char (string x) 0))))
(defun whitespace? (ch)
(find ch "
")) logic/algorithms/normal.lisp 0100644 0002635 0000472 00000014122 06316432652 016464 0 ustar russell russell ;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- File: logic/normal.lisp
;;;; Convert Expressions to Normal Form (Conjunctive, Implicative or Horn)
;;; This could be done much more efficiently by using a special
;;; representation for CNF, which eliminates the explicit ANDs
;;; and ORs. This code is meant to be informative, not efficient.
;;;; Top-Level Functions
(defun ->cnf (p &optional vars)
"Convert a sentence p to conjunctive normal form [p 279-280]."
;; That is, return (and (or ...) ...) where
;; each of the conjuncts has all literal disjuncts.
;; VARS is a list of universally quantified variables that P is in scope of.
(setf p (eliminate-implications (logic p)))
(case (op p)
(NOT (let ((p2 (move-not-inwards (arg1 p))))
(if (literal-clause? p2) p2 (->cnf p2 vars))))
(AND (conjunction (mappend #'(lambda (q) (conjuncts (->cnf q vars)))
(args p))))
(OR (merge-disjuncts (mapcar #'(lambda (q) (->cnf q vars))
(args p))))
(FORALL (let ((new-vars (mapcar #'new-variable (mklist (arg1 p)))))
(->cnf (sublis (mapcar #'cons (mklist (arg1 p)) new-vars)
(arg2 p))
(append new-vars vars))))
(EXISTS (->cnf (skolemize (arg2 p) (arg1 p) vars) vars))
(t p) ; p is atomic
))
(defun ->inf (p)
"Convert a sentence p to implicative normal form [p 282]."
(conjunction (mapcar #'cnf1->inf1 (conjuncts (->cnf p)))))
(defun ->horn (p)
"Try to convert sentence to a Horn clause, or a conjunction of Horn clauses.
Signal an error if this cannot be done."
(let ((q (->inf p)))
(when (not (every #'horn-clause? (conjuncts q)))
(warn "~A, converted to ~A, is not a Horn clause." p q))
q))
(defun logic (sentence)
"Canonicalize a sentence into proper logical form."
(cond ((stringp sentence) (->prefix sentence))
(t sentence)))
;;;; Auxiliary Functions
(defun cnf1->inf1 (p)
;; P is of the form (or (not a) (not b) ... c d ...)
;; Convert to: (=> (and a b ...) (or c d ...))
;; where a,b,c,d ... are positive atomic clauses
(let ((lhs (mapcar #'arg1 (remove-if-not #'negative-clause? (disjuncts p))))
(rhs (remove-if #'negative-clause? (disjuncts p))))
`(=> ,(conjunction lhs) ,(disjunction rhs))))
(defun eliminate-implications (p)
(if (literal-clause? p)
p
(case (op p)
(=> `(or ,(arg2 p) (not ,(arg1 p))))
(<=> `(and (or ,(arg1 p) (not ,(arg2 p)))
(or (not ,(arg1 p)) ,(arg2 p))))
(t (cons (op p) (mapcar #'eliminate-implications (args p)))))))
(defun move-not-inwards (p)
"Given P, return ~P, but with the negation moved as far in as possible."
(case (op p)
(TRUE 'false)
(FALSE 'true)
(NOT (arg1 p))
(AND (disjunction (mapcar #'move-not-inwards (args p))))
(OR (conjunction (mapcar #'move-not-inwards (args p))))
(FORALL (make-exp 'EXISTS (arg1 p) (move-not-inwards (arg2 p))))
(EXISTS (make-exp 'FORALL (arg1 p) (move-not-inwards (arg2 p))))
(t (make-exp 'not p))))
(defun merge-disjuncts (disjuncts)
"Return a CNF expression for the disjunction."
;; The argument is a list of disjuncts, each in CNF.
;; The second argument is a list of conjuncts built so far.
(case (length disjuncts)
(0 'false)
(1 (first disjuncts))
(t (conjunction
(let ((result nil))
(for each y in (conjuncts (merge-disjuncts (rest disjuncts))) do
(for each x in (conjuncts (first disjuncts)) do
(push (disjunction (append (disjuncts x) (disjuncts y)))
result)))
(nreverse result))))))
(defun skolemize (p vars outside-vars)
"Within the proposition P, replace each of VARS with a skolem constant,
or if OUTSIDE-VARS is non-null, a skolem function of them."
(sublis (mapcar #'(lambda (var)
(cons var (if (null outside-vars)
(skolem-constant var)
(cons (skolem-constant var) outside-vars))))
(mklist vars))
p))
(defun skolem-constant (name)
"Return a unique skolem constant, a symbol starting with '$'."
(intern (format nil "$~A_~D" name (incf *new-variable-counter*))))
(defun renaming? (p q &optional (bindings +no-bindings+))
"Are p and q renamings of each other? (That is, expressions that differ
only in variable names?)"
(cond ((eq bindings +fail+) +fail+)
((equal p q) bindings)
((and (consp p) (consp q))
(renaming? (rest p) (rest q)
(renaming? (first p) (first q) bindings)))
((not (and (variable? p) (variable? q)))
+fail+)
;; P and Q are both variables from here on
((and (not (get-binding p bindings)) (not (get-binding q bindings)))
(extend-bindings p q bindings))
((or (eq (lookup p bindings) q) (eq p (lookup q bindings)))
bindings)
(t +fail+)))
;;;; Utility Predicates and Accessors
(defconstant +logical-connectives+ '(and or not => <=>))
(defconstant +logical-quantifiers+ '(forall exists))
(defun atomic-clause? (sentence)
"An atomic clause has no connectives or quantifiers."
(not (or (member (op sentence) +logical-connectives+)
(member (op sentence) +logical-quantifiers+))))
(defun literal-clause? (sentence)
"A literal is an atomic clause or a negated atomic clause."
(or (atomic-clause? sentence)
(and (negative-clause? sentence) (atomic-clause? (arg1 sentence)))))
(defun negative-clause? (sentence)
"A negative clause has NOT as the operator."
(eq (op sentence) 'not))
(defun horn-clause? (sentence)
"A Horn clause (in INF) is an implication with atoms on the left and one
atom on the right."
(and (eq (op sentence) '=>)
(every #'atomic-clause? (conjuncts (arg1 sentence)))
(atomic-clause? (arg2 sentence))))
(defun conjuncts (sentence)
"Return a list of the conjuncts in this sentence."
(cond ((eq (op sentence) 'and) (args sentence))
((eq sentence 'true) nil)
(t (list sentence))))
(defun disjuncts (sentence)
"Return a list of the disjuncts in this sentence."
(cond ((eq (op sentence) 'or) (args sentence))
((eq sentence 'false) nil)
(t (list sentence))))
(defun conjunction (args)
"Form a conjunction with these args."
(case (length args)
(0 'true)
(1 (first args))
(t (cons 'and args))))
(defun disjunction (args)
"Form a disjunction with these args."
(case (length args)
(0 'false)
(1 (first args))
(t (cons 'or args)))) logic/algorithms/prop.lisp 0100644 0002635 0000472 00000012733 06316434247 016164 0 ustar russell russell ;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- File logic/prop.lisp
;;;; Propositional Logic
(defstructure prop-kb
"A simple KB implementation that builds a big conjoined sentence."
;; The sentence slot will be, e.g., (and P (not Q) R (or S T) ...)
(sentence (make-exp 'and)))
(defstructure truth-table
symbols ; The propositional symbols
sentences ; Sentences that head the columns
rows ; Lists of t or nil truth values
)
;;;; Tell, Ask, and Retract
(defmethod tell ((kb prop-kb) sentence)
"Add a sentence to a propositional knowledge base."
(push (logic sentence) (args (prop-kb-sentence kb)))
t)
(defmethod ask-each ((kb prop-kb) query fn)
"Ask a propositional knowledge base if the query is entailed by the kb."
(when (eq (validity (make-exp '=> (prop-kb-sentence kb) (logic query)))
'valid)
(funcall fn +no-bindings+)))
(defmethod retract ((kb prop-kb) sentence)
"Remove a sentence from a knowledge base."
;; This only retracts sentences that were explicitly told to the kb.
(deletef sentence (args (prop-kb-sentence kb)) :test #'equal)
t)
;;;; Other Useful Top-Level Functions
(defun validity (sentence)
"Return either VALID, SATISFIABLE or UNSATISFIABLE."
(let* ((table (build-truth-table (logic sentence) :short t))
(rows (truth-table-rows table)))
(cond ((every #'last1 rows) 'valid)
((some #'last1 rows) 'satisfiable)
(t 'unsatisfiable))))
(defun truth-table (sentence)
"Build and print a truth table for this sentence, with columns for all the
propositions and all the non-trivial component sentences. Iff the sentence
is valid, the last column will have all T's.
Example: (truth-table '(<=> P (not (not P))))."
(print-truth-table (build-truth-table (logic sentence))))
;;;; Auxiliary Functions
(defun eval-truth (sentence &optional interpretation)
"Evaluate the truth of the sentence under an interpretation.
The interpretation is a list of (proposition . truth-value) pairs,
where a truth-value is t or nil, e.g., ((P . t) (Q . nil)).
It is an error if there are any propositional symbols in the sentence
that are not given a value in the interpretation."
(cond (interpretation (eval-truth (sublis interpretation sentence) nil))
((eq sentence 'true) t)
((eq sentence 'false) nil)
((atom sentence) (error "No interpretation for ~A." sentence))
(t (case (op sentence)
(or (some #'eval-truth (args sentence)))
(and (every #'eval-truth (args sentence)))
(not (not (eval-truth (arg1 sentence))))
(=> (or (eval-truth (arg2 sentence))
(not (eval-truth (arg1 sentence)))))
(<=> (eq (eval-truth (arg1 sentence))
(eval-truth (arg2 sentence))))
(otherwise (error "Unknown connective ~A in ~A"
(op sentence) sentence))))))
;; Note: a more efficient implementation of interpretations would be
;; a sequence of n propositional symbols and a number from 0 to (2^n)-1.
;; Symbol i is true iff bit i in the number is 1.
;;;; Truth Tables
(defun build-truth-table (sentence &key short)
"Build a truth table whose last column is the sentence. If SHORT is true,
then that is the only column. If SHORT is false, all the sub-sentences
are also included as columns (except constants)."
(let* ((symbols (prop-symbols-in sentence))
(sentences (if short
(list sentence)
(append symbols (complex-sentences-in sentence)))))
(make-truth-table :symbols symbols
:sentences sentences
:rows (compute-truth-entries symbols sentences))))
(defun print-truth-table (table &optional (stream t))
"Print a truth table."
(let* ((headers (mapcar #'sentence-output-form
(truth-table-sentences table)))
(width (+ (* 2 (length headers))
(sum headers #'length))))
;; Each sentence is printed as a column header, surrounded by 2 spaces
(print-dashes width stream t)
(format stream "~{ ~A ~}~%" headers)
(print-dashes width stream t)
(dolist (row (truth-table-rows table))
(mapcar #'(lambda (entry header)
(print-centered (if entry "T" "F")
(+ 2 (length header))
stream))
row
headers)
(format stream "~%"))
(print-dashes width stream t)))
(defun compute-truth-entries (symbols sentences)
"Compute the truth of each sentence under all interpretations of symbols."
(mapcar #'(lambda (interpretation)
(mapcar #'(lambda (sentence)
(eval-truth sentence interpretation))
sentences))
(all-truth-interpretations symbols)))
(defun all-truth-interpretations (symbols)
"Return all 2^n interpretations for a list of n symbols."
(if (null symbols)
(list nil)
(let ((symbol1 (first symbols)))
(mapcan #'(lambda (sub-rest)
`(((,symbol1 . false) . ,sub-rest)
((,symbol1 . true) . ,sub-rest)))
(all-truth-interpretations (rest symbols))))))
(defun prop-symbols-in (sentence)
"Return a list of all the propositional symbols in sentence."
(cond ((member sentence '(true false)) nil)
((atom sentence) (list sentence))
(t (delete-duplicates (mapcan #'prop-symbols-in (args sentence))
:from-end t))))
(defun complex-sentences-in (sentence)
"Return a list of all non-atom sub-sentences of sentence."
(cond ((atom sentence) nil)
(t (delete-duplicates
(nconc (mapcan #'complex-sentences-in (args sentence))
(list sentence))))))
(defun sentence-output-form (sentence)
"Convert a prefix sentence back into an infix notation with brief operators."
(format nil "~{~A~^ ~}"
(mklist (sublis '((and . "^") (not . "~") (or . "|"))
(prefix->infix sentence))))) logic/algorithms/unify.lisp 0100644 0002635 0000472 00000011123 06324546622 016326 0 ustar russell russell ;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- File: logic/unify.lisp
;;;; Unification and Substitutions (aka Binding Lists)
;;; This code is borrowed from "Paradigms of AI Programming: Case Studies
;;; in Common Lisp", by Peter Norvig, published by Morgan Kaufmann, 1992.
;;; The complete code from that book is available for ftp at mkp.com in
;;; the directory "pub/Norvig". Note that it uses the term "bindings"
;;; rather than "substitution" or "theta". The meaning is the same.
;;;; Constants
(defconstant +fail+ nil "Indicates unification failure")
(defconstant +no-bindings+ '((nil))
"Indicates unification success, with no variables.")
;;;; Top Level Functions
(defun unify (x y &optional (bindings +no-bindings+))
"See if x and y match with given bindings. If they do,
return a binding list that would make them equal [p 303]."
(cond ((eq bindings +fail+) +fail+)
((eql x y) bindings)
((variable? x) (unify-var x y bindings))
((variable? y) (unify-var y x bindings))
((and (consp x) (consp y))
(unify (rest x) (rest y)
(unify (first x) (first y) bindings)))
(t +fail+)))
(defun rename-variables (x)
"Replace all variables in x with new ones."
(sublis (mapcar #'(lambda (var) (make-binding var (new-variable var)))
(variables-in x))
x))
;;;; Auxiliary Functions
(defun unify-var (var x bindings)
"Unify var with x, using (and maybe extending) bindings [p 303]."
(cond ((get-binding var bindings)
(unify (lookup var bindings) x bindings))
((and (variable? x) (get-binding x bindings))
(unify var (lookup x bindings) bindings))
((occurs-in? var x bindings)
+fail+)
(t (extend-bindings var x bindings))))
(defun variable? (x)
"Is x a variable (a symbol starting with $)?"
(and (symbolp x) (eql (char (symbol-name x) 0) #\$)))
(defun get-binding (var bindings)
"Find a (variable . value) pair in a binding list."
(assoc var bindings))
(defun binding-var (binding)
"Get the variable part of a single binding."
(car binding))
(defun binding-val (binding)
"Get the value part of a single binding."
(cdr binding))
(defun make-binding (var val) (cons var val))
(defun lookup (var bindings)
"Get the value part (for var) from a binding list."
(binding-val (get-binding var bindings)))
(defun extend-bindings (var val bindings)
"Add a (var . value) pair to a binding list."
(cons (make-binding var val)
;; Once we add a "real" binding,
;; we can get rid of the dummy +no-bindings+
(if (eq bindings +no-bindings+)
nil
bindings)))
(defun occurs-in? (var x bindings)
"Does var occur anywhere inside x?"
(cond ((eq var x) t)
((and (variable? x) (get-binding x bindings))
(occurs-in? var (lookup x bindings) bindings))
((consp x) (or (occurs-in? var (first x) bindings)
(occurs-in? var (rest x) bindings)))
(t nil)))
(defun subst-bindings (bindings x)
"Substitute the value of variables in bindings into x,
taking recursively bound variables into account."
(cond ((eq bindings +fail+) +fail+)
((eq bindings +no-bindings+) x)
((and (variable? x) (get-binding x bindings))
(subst-bindings bindings (lookup x bindings)))
((atom x) x)
(t (reuse-cons (subst-bindings bindings (car x))
(subst-bindings bindings (cdr x))
x))))
(defun unifier (x y)
"Return something that unifies with both x and y (or fail)."
(subst-bindings (unify x y) x))
(defun variables-in (exp)
"Return a list of all the variables in EXP."
(unique-find-anywhere-if #'variable? exp))
(defun unique-find-anywhere-if (predicate tree &optional found-so-far)
"Return a list of leaves of tree satisfying predicate,
with duplicates removed."
(if (atom tree)
(if (funcall predicate tree)
(pushnew tree found-so-far)
found-so-far)
(unique-find-anywhere-if
predicate
(first tree)
(unique-find-anywhere-if predicate (rest tree)
found-so-far))))
(defun find-anywhere-if (predicate tree)
"Does predicate apply to any atom in the tree?"
(if (atom tree)
(funcall predicate tree)
(or (find-anywhere-if predicate (first tree))
(find-anywhere-if predicate (rest tree)))))
(defvar *new-variable-counter* 0)
(defun new-variable (var)
"Create a new variable. Assumes user never types variables of form $X.9"
(concat-symbol (if (variable? var) "" "$")
var "." (incf *new-variable-counter*)))
logic/algorithms/tell-ask.lisp 0100644 0002635 0000472 00000004336 06210702552 016706 0 ustar russell russell ;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- File: tell-ask.lisp
;;;; Main Functions on KBs: Tell, Retract, Ask-Each, Ask, Ask-Pattern[s]
;;; First we define a very simple kind of knowledge base, literal-kb,
;;; that just stores a list of literal sentences.
(defstructure literal-kb
"A knowledge base that just stores a set of literal sentences."
(sentences '()))
;;; There are three generic functions that operate on knowledge bases, and
;;; that must be defined as methods for each type of knowledge base: TELL,
;;; RETRACT, and ASK-EACH. Here we show the implementation for literal-kb;
;;; elsewhere you'll see implementations for propositional, Horn, and FOL KBs.
(defmethod tell ((kb literal-kb) sentence)
"Add the sentence to the knowledge base."
(pushnew sentence (literal-kb-sentences kb) :test #'equal))
(defmethod retract ((kb literal-kb) sentence)
"Remove the sentence from the knowledge base."
(deletef sentence (literal-kb-sentences kb) :test #'equal))
(defmethod ask-each ((kb literal-kb) query fn)
"For each proof of query, call fn on the substitution that
the proof ends up with."
(declare (special +no-bindings+))
(for each s in (literal-kb-sentences kb) do
(when (equal s query) (funcall fn +no-bindings+))))
;;; There are three other ASK functions, defined below, that are
;;; defined in terms of ASK-EACH. These are defined once and for all
;;; here (not for each kind of KB)."
(defun ask (kb query)
"Ask if query sentence is true; return t or nil."
(ask-each kb (logic query)
#'(lambda (s) (declare (ignore s)) (RETURN-FROM ASK t))))
(defun ask-pattern (kb query &optional (pattern query))
"Ask if query sentence is true; if it is, substitute bindings into pattern."
(ask-each kb (logic query)
#'(lambda (s) (RETURN-FROM ASK-PATTERN
(subst-bindings s (logic pattern))))))
(defun ask-patterns (kb query &optional (pattern query))
"Find all proofs for query sentence, substitute bindings into pattern
once for each proof. Return a list of all substituted patterns."
(let ((pat (logic pattern))
(results nil))
(ask-each kb (logic query)
#'(lambda (s) (push (subst-bindings s pat) results)))
(nreverse results)))
logic/agents/ 0040755 0002635 0000472 00000000000 06237320272 013412 5 ustar russell russell logic/agents/kb-agent.lisp 0100644 0002635 0000472 00000001155 06211107470 015765 0 ustar russell russell ;;; -*- Mode: Lisp; -*- Author: Peter Norvig
;;;; Knowledge-Based Agent
(defstructure (action-value-agent (:include agent)
(program (make-action-value-agent-program))))
(defun make-action-value-agent-program (&key (kb (make-fol-kb)))
"Define an action-value knowledge-based agent. [p 210]"
(let ((t 0))
#'(lambda (percept)
(tell kb `(Percept ,percept ,t))
(let ((action (or (ask-pattern kb `(Great $a t) '$a)
(ask-pattern kb `(Good $a t) '$a)
(ask-pattern kb `(Medium $a t) '$a)
(ask-pattern kb `(Risky $a t) '$a))))
(tell kb `(Did Self ,action ,t))
(incf t)
action))))
; p 177 logic/agents/shopping-agent.lisp 0100644 0002635 0000472 00000000604 06224573124 017225 0 ustar russell russell ;;; -*- Mode: Lisp; -*- Author: Peter Norvig
;;;; Agents for the Shopping World
(defstructure (shopping-agent
(:include agent
(program 'ask-human-shopping-program))))
(defun ask-human-shopping-program (percept)
(format t "~&Agent ~%~@[Feels: ~A~%~]~{~^Hears: ~A~%~}~{~^Sees: ~A~%~}"
(second percept) (third percept) (first percept))
(format t "ACTION: ")
(read))
logic/environments/ 0040755 0002635 0000472 00000000000 06326754714 014673 5 ustar russell russell logic/environments/shopping.lisp 0100644 0002635 0000472 00000011076 06324547226 017411 0 ustar russell russell ;;; File: shopping.lisp -*- Mode: Lisp; Syntax: Common-Lisp; -*-
;;;; The Shopping World:
;;; Warning! This code has not yet been tested or debugged!
(defparameter *page250-supermarket*
'((at edge wall)
(at (1 1) (sign :words (exit)))
(at (and (2 2) (6 2)) shopper)
(at (and (3 2) (7 2)) cashier-stand)
(at (and (4 2) (8 2) (4 7)) cashier)
(at (2 4) (sign :words (Aisle 1 Vegetables)))
(at (2 5) (-15 tomato) (sign :words (Tomatoes $ .79 lb)))
(at (2 6) (-6 lettuce) (sign :words (Lettuce $ .89)))
(at (2 7) (-8 onion) (sign :words (Onion $ .49 lb)))
(at (3 4) (sign :words (Aisle 2 Fruit)))
(at (3 5) (-12 apple) (sign :words (Apples $ .69 lb)))
(at (3 6) (-9 orange) (sign :words (Oranges $ .75 lb)))
(at (3 7) (-3 grapefruit :size 0.06 :color yellow)
(-3 grapefruit :size 0.07 :color pink)
(sign :words (Grapefruit $ .49 each)))
;; The rest of the store is temporarily out of stock ...
(at (5 4) (sign :words (Aisle 3 Soup Sauces)))
(at (6 4) (sign :words (Aisle 4 Meat)))
(at (8 4) (sign :words (Aisle 5 Sundries)))
))
(defstructure (shopping-world (:include grid-environment
(aspec '(shopping-agent))
(bspec *page250-supermarket*))))
;;;; New Structures
(defstructure (credit-card (:include object (name "$"))))
(defstructure (food (:include object (shape :round) (size .1) (name 'f))))
(defstructure (tomato (:include food (color 'red) (size .08) (name 't))))
(defstructure (lettuce (:include food (color 'green) (size .09) (name 'l))))
(defstructure (onion (:include food (color 'yellow) (size .07) (name 'o))))
(defstructure (orange (:include food (color 'orange) (size .07) (name 'o))))
(defstructure (apple (:include food (color 'red) (size .07) (name 'a))))
(defstructure (grapefruit (:include food (color 'yellow) (size .1) (name 'g))))
(defstructure (sign (:include object (name 'S) (size .09)
(color '(white (with black)))))
(words '()))
(defstructure (cashier-stand (:include object (color '(black (with chrome)))
(shape 'flat) (size .9) (name 'C))))
(defstructure (cashier (:include agent-body (name "c"))))
(defstructure (seeing-agent-body (:include agent-body (name ":")))
(zoomed-at nil) ; Some have a camera to zoom in and out at a location
(can-zoom-at '((0 0) (0 +1) (+1 +1) (-1 +1)))
(visible-offsets '((0 +1) (+1 +1) (-1 +1))))
(defstructure (shopper (:include seeing-agent-body (name "@")
(contents (list (make-credit-card))))))
;;;; Percepts
(defmethod get-percept ((env shopping-world) agent)
"The percept is a sequence of sights, touch (i.e. bump), and sounds."
(list (see agent env) (feel agent env) (hear agent env)))
(defun see (agent env)
"Return a list of visual percepts for an agent. Note the agent's camera may
either be zoomed out, so that it sees several squares, or zoomed in on one."
(let* ((body (agent-body agent))
(zoomed-at (seeing-agent-body-zoomed-at body)))
(mappend #'(lambda (offset)
(see-loc (absolute-loc body offset) env zoomed-at))
(seeing-agent-body-visible-offsets body))))
(defun feel (agent env)
(declare (ignore env))
(if (object-bump (agent-body agent)) 'bump))
(defun hear (agent env)
;; We can hear anything within 2 squares
(let* ((body (agent-body agent))
(loc (object-loc body))
(objects nil))
(for each obj in (grid-environment-objects env) do
(when (and (object-sound obj) (near? (object-loc obj) loc 2))
(push (object-sound obj) objects)))
objects))
(defun see-loc (loc env zoomed-at)
(let ((objects (grid-contents env loc)))
(if zoomed-at
(mappend #'appearance objects)
(appearance objects))))
(defun appearance (object)
"Return a list of visual attributes: (loc size color shape words)"
(list (object-loc object) (fuzz (object-size object)) (object-color object)
(object-shape object) (object-words object)))
(defun object-words (object)
(if (sign-p object)
(sign-words object)
nil))
(defun zoom (agent-body env offset)
"Zoom the camera at an offset if it is feasible; otherwise zoom out."
(declare (ignore env))
(cond ((member offset (seeing-agent-body-can-zoom-at agent-body))
(setf (seeing-agent-body-zoomed-at agent-body) offset)
(setf (seeing-agent-body-visible-offsets agent-body) (list offset)))
(t ;; Zoom out
(setf (seeing-agent-body-zoomed-at agent-body) nil)
(setf (seeing-agent-body-visible-offsets agent-body)
(remove '(0 0) (seeing-agent-body-can-zoom-at agent-body)
:test #'equal)))))
search/ 0040755 0002635 0000472 00000000000 06326754520 012307 5 ustar russell russell search/domains/ 0040755 0002635 0000472 00000000000 06326754712 013744 5 ustar russell russell search/domains/nqueens.lisp 0100644 0002635 0000472 00000002470 06210415365 016301 0 ustar russell russell ;;;; The N-Queens Puzzle as a Constraint Satisfaction Problem
(defstructure (nqueens-problem (:include CSP-problem)
(:constructor create-nqueens-problem))
(n 8)
(explicit? nil))
(defun make-nqueens-problem (&rest args &key (n 8) (explicit? nil))
(apply #'create-nqueens-problem
:initial-state (nqueens-initial-state n explicit?)
args))
(defun nqueens-initial-state (n &optional (explicit? nil) (complete? nil))
(let ((s (make-CSP-state
:unassigned (mapcar #'(lambda (var)
(make-CSP-var :name var
:domain (iota n)))
(iota n))
:assigned nil
:constraint-fn (if explicit?
(let ((constraints (nqueens-constraints n)))
#'(lambda (var1 val1 var2 val2)
(CSP-explicit-check
var1 val1 var2 val2 constraints)))
#'nqueens-constraint-fn))))
(if complete? (CSP-random-completion s) s)))
(defun nqueens-constraints (n)
(let ((constraints (make-array (list n n))))
(dotimes (i n constraints)
(dotimes (j n)
(unless (= i j)
(dotimes (vi n)
(dotimes (vj n)
(unless (or (= vi vj)
(= (abs (- j i)) (abs (- vj vi))))
(push (cons vi vj)
(aref constraints i j))))))))))
(defun nqueens-constraint-fn (var1 val1 var2 val2)
(not (or (= val1 val2)
(= (abs (- var1 var2)) (abs (- val1 val2))))))
search/domains/path-planning.lisp 0100644 0002635 0000472 00000012622 06316424357 017373 0 ustar russell russell ;;;; Path Planning in 2 Dimensions with Convex Polygonal Obstacles
(defstructure (path-planning-problem (:include problem)
(:constructor create-path-planning-problem))
"A problem involving moving among polygonal obstacles in 2D space.
A state is the current vertex."
scene)
(defun make-path-planning-problem (&key scene)
"Define a constructor to build a problem, using the scene properly."
(create-path-planning-problem
:scene scene
:initial-state (scene-start scene)
:goal (scene-goal scene)))
(defmethod successors ((problem path-planning-problem) v1)
"Return a list of (action . state) pairs, where the state is another
vertex that is visible from the current vertex v1, and the action is a
delta (dx dy) from v1 to the new one."
(let ((p1 (vertex-xy v1)))
(mapcar #'(lambda (v2) (let ((p2 (vertex-xy v2)))
(cons (@ (- (xy-x p2) (xy-x p1))
(- (xy-y p2) (xy-y p1)))
v2)))
(vertices-visible-from v1 (path-planning-problem-scene problem)))))
(defmethod edge-cost ((problem path-planning-problem) node action vertex)
"The cost of an action is its distance."
(declare-ignore node vertex)
(xy-distance '(0 0) action))
(defmethod h-cost ((problem path-planning-problem) vertex)
"The heuristic cost is the straight-line distance to the goal."
(xy-distance (vertex-xy vertex) (vertex-xy (problem-goal problem))))
;;;; Defining the Vertex, Line, Polygon and Scene Types
(defstructure vertex
xy ;; the xy point for the vertex
c-neighbor ;; neighbour in clockwise direction
a-neighbor ;; neighbour in anti-clockwise direction
visible ;; list of vertices visible from here
)
(defmethod print-structure ((v vertex) stream)
(format stream "#" (xy-x (vertex-xy v)) (xy-y (vertex-xy v))))
(defstructure line
xy1 xy2)
(defstructure polygon
vertices n)
(defstructure scene
polygons ; polygons comprising scene
start ; vertex for start
goal ; vertex for goal
)
;;; Functions for testing whether one vertex is visible from another
(defun vertices-visible-from (v1 scene)
"Find all the vertices that can be seen from this vertex."
;; When you find them, cache them under the vertex-visible slot.
(or (vertex-visible v1)
(setf (vertex-visible v1) (vertices-in-view v1 scene))))
(defun vertices-in-view (v scene)
"Find all the other vertices that can be seen from v."
(delete v
(let ((result nil))
(for each poly in (scene-polygons scene) do
(cond ((member v (polygon-vertices poly))
(push (vertex-c-neighbor v) result)
(push (vertex-a-neighbor v) result))
(t (for each v2 in (polygon-vertices poly) do
(when (visible-p (vertex-xy v) (vertex-xy v2) scene)
(push v2 result))))))
result)))
(defun visible-p (xy1 xy2 scene)
"Predicate; return t iff xy1 is visible from xy2."
(let ( (line (make-line :xy1 xy1 :xy2 xy2)) )
(dolist (poly (scene-polygons scene) t)
(if (line-intersects-poly? line poly) (return nil)))))
(defun line-intersects-poly? (line poly)
"Predicate; return t iff line intersects poly."
(dolist (v1 (polygon-vertices poly) nil)
(let ((v2 (vertex-c-neighbor v1)))
(if (intersects line
(make-line :xy1 (vertex-xy v1) :xy2 (vertex-xy v2)))
(return t)))))
(defun intersects (l1 l2)
;;; l1 is line ab; l2 is line cd
;;; assume the lines cross at alpha a + (1-alpha) b,
;;; also known as beta c + (1-beta) d
;;; line segments intersect if 0