20 |
21 |
22 |
23 |
--------------------------------------------------------------------------------
/planning/README.html:
--------------------------------------------------------------------------------
1 |
2 |
3 | Planning (Subsystem of AIMA Code)
4 |
5 |
6 |
7 |
8 | Planning (Subsystem of AIMA Code)
9 |
10 | The planning subsystem will cover the code in Part IV of the
11 | book. So far we have not developed any code. However, there is a
12 | very good system called UCPOP
14 | available from the University of Washington. Much of the presentation
15 | in the book follows UCPOP and its predecessors and successors, so it
16 | should be easy to understand.
17 |
18 | Eventually, we plan to provide our own simplified versions of
19 | several planners here, and show how to hook them up to the wumpus and
20 | shopping environments.
21 |
22 |
23 |
24 |
25 |
26 |
27 |
--------------------------------------------------------------------------------
/uncertainty/agents/mdp-agent.lisp:
--------------------------------------------------------------------------------
1 | ;;;; A simple policy agent for Markov decision processes (MDPs).
2 |
3 | (defun make-mdp-agent (&key body name mdp program
4 | (algorithm 'value-iteration-policy))
5 | "An MDP agent constructs a policy from the MDP once, and then uses that
6 | policy repeatedly to take action. The ALGORITHM keyword specifies the
7 | algorithm that is used to create the policy; don't confuse it with the
8 | PROGRAM keyword, which decides what actions to take."
9 | (new-mdp-agent
10 | :body body :name name
11 | :program (or program
12 | (let ((policy nil))
13 | #'(lambda (percept)
14 | (when (null policy)
15 | (setf policy (funcall algorithm mdp)))
16 | (policy-choice (mdp-percept-state percept) policy))))))
17 |
18 | (defstructure (mdp-agent (:include agent) (:constructor new-mdp-agent))
19 | (total-reward 0))
20 |
21 |
--------------------------------------------------------------------------------
/agents/agents/vacuum.lisp:
--------------------------------------------------------------------------------
1 | ;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- Author: Peter Norvig
2 |
3 | ;;;; Some simple agents for the vacuum world
4 |
5 | (defstructure (random-vacuum-agent
6 | (:include agent
7 | (program
8 | #'(lambda (percept)
9 | (declare (ignore percept))
10 | (random-element
11 | '(suck forward (turn right) (turn left) shut-off))))))
12 | "A very stupid agent: ignore percept and choose a random action.")
13 |
14 | (defstructure (reactive-vacuum-agent
15 | (:include agent
16 | (program
17 | #'(lambda (percept)
18 | (destructuring-bind (bump dirt home) percept
19 | (cond (dirt 'suck)
20 | (home (random-element '(shut-off forward (turn right))))
21 | (bump (random-element '((turn right) (turn left))))
22 | (t (random-element '(forward forward forward
23 | (turn right) (turn left))))))))))
24 | "When you bump, turn randomly; otherwise mostly go forward, but
25 | occasionally turn. Always suck when there is dirt.")
26 |
27 |
28 |
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | The MIT License (MIT)
2 |
3 | Copyright (c) 2016 aimacode
4 |
5 | Permission is hereby granted, free of charge, to any person obtaining a copy
6 | of this software and associated documentation files (the "Software"), to deal
7 | in the Software without restriction, including without limitation the rights
8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9 | copies of the Software, and to permit persons to whom the Software is
10 | furnished to do so, subject to the following conditions:
11 |
12 | The above copyright notice and this permission notice shall be included in all
13 | copies or substantial portions of the Software.
14 |
15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21 | SOFTWARE.
22 |
--------------------------------------------------------------------------------
/learning/agents/passive-lms-learner.lisp:
--------------------------------------------------------------------------------
1 | ;;; learning/agents/passive-lms-learner.lisp
2 | ;;; Passive LMS learning agent.
3 | ;;; When a given training sequence terminates,
4 | ;;; update the utility of each state visited in the sequence
5 | ;;; to reflect the rewards received from then on.
6 |
7 | (defun make-passive-lms-learner ()
8 | (let ((percepts nil)
9 | (U (make-hash-table :test #'equal))
10 | (N (make-hash-table :test #'equal)))
11 | #'(lambda (e)
12 | (push e percepts)
13 | (let ((s (mdp-percept-state e)))
14 | (unless (gethash s N) ;;; make entries for new state
15 | (setf (gethash s N) 0
16 | (gethash s U) 0))
17 | (incf (gethash s N))
18 | (lms-update U e percepts N)
19 | (when (mdp-percept-terminalp e)
20 | (setq percepts nil)))
21 | 'no-op)))
22 |
23 | (defun lms-update (U e percepts N &aux (reward-to-go 0))
24 | (when (mdp-percept-terminalp e)
25 | (dolist (ei percepts) ;;; percepts is in reverse chronological order
26 | (let ((i (mdp-percept-state ei))
27 | (r (mdp-percept-reward ei)))
28 | (incf reward-to-go r)
29 | (setf (gethash i U)
30 | (running-average (gethash i U) r (gethash i N)))))))
31 |
--------------------------------------------------------------------------------
/search/agents/ttt-agent.lisp:
--------------------------------------------------------------------------------
1 |
2 | ;;;; An Agent for Playing Tic-Tac-Toe
3 |
4 | (defstructure (alpha-beta-ttt-agent
5 | (:include game-agent
6 | (algorithm #'(lambda (state game)
7 | (alpha-beta-decision state game #'ttt-eval)))))
8 | "A game-playing agent that uses ttt-eval to do alpha-beta search.")
9 |
10 | (defun ttt-eval (state)
11 | "Evaluate a TTT board on a scale from -1 to +1."
12 | ;; This is a rather poor evaluation function.
13 | ;; Note that it doesn't even pay attention to K.
14 | ;; We just count the number of blank squares next to each player.
15 | ;; The more of these, the better.
16 | (let* ((board (game-state-board state))
17 | (players (game-state-players state))
18 | (values (make-list (length players) :initial-element 0))
19 | (n (array-dimension board 0)))
20 | (dotimes (x n)
21 | (dotimes (y n)
22 | (when (eq (aref board x y) '-)
23 | (for each delta in '((1 0) (0 1) (-1 0) (0 -1)) do
24 | (let* ((neighbor (xy-add delta (@ x y)))
25 | (piece (when (inside neighbor n n)
26 | (aref board (xy-x neighbor) (xy-y neighbor)))))
27 | (unless (member piece '(- nil))
28 | ;; You get points for having your piece neighboring an empty
29 | (incf (elt values (position piece players)) 0.001)))))))
30 | values))
31 |
--------------------------------------------------------------------------------
/doc/overview-PLANNING.html:
--------------------------------------------------------------------------------
1 |
2 |
3 | Planning (Subsystem of AIMA Code)
4 |
5 |
6 |
7 |
8 | Planning (Subsystem of AIMA Code)
9 |
10 | The planning subsystem will cover the code in Part IV of the
11 | book. So far we have not developed any code. However, there is a
12 | very good system called UCPOP
14 | available from the University of Washington. Much of the presentation
15 | in the book follows UCPOP and its predecessors and successors, so it
16 | should be easy to understand.
17 |
18 | Eventually, we plan to provide our own simplified versions of
19 | several planners here, and show how to hook them up to the wumpus and
20 | shopping environments.
21 |
22 |
23 |
planning/:
24 |
25 |
26 |
27 |
34 |
35 |
36 |
--------------------------------------------------------------------------------
/language/README.html:
--------------------------------------------------------------------------------
1 |
2 |
3 | Language (Subsystem of AIMA Code)
4 |
5 |
6 |
7 |
8 | Language (Subsystem of AIMA Code)
9 |
10 | The language subsystem covers the natural language processing
11 | code from Chapters 22 and 23 of the book. The main parsing function
12 | is chart-parse, but it returns a chart, which is not very
13 | useful in itself, so most of the test
14 | examples call chart-parses, which returns a list of
15 | parses for the complete input string, or meanings which pulls
16 | out the semantic component of each parse.
17 |
18 | Several sample grammars are shown.
19 | For the most part, they follow the notation from the book. The
20 | differences are:
21 |
22 | - Obviously, the grammars are in Lisp notation.
23 |
- The symbol $w on the left-hand side of a lexical rule stands
24 | for the word itself on the right-hand side. This allows you to put multiple
25 | lexical entries on one line.
26 |
- The grammar can specify a list of :unknown-word-cats. That means
27 | that when an unknown word is encountered in the input, it is assumed to be
28 | one of these categories.
29 |
30 |
31 |
32 |
33 |
34 |
35 |
--------------------------------------------------------------------------------
/agents/test-agents.lisp:
--------------------------------------------------------------------------------
1 | ;;; File: agents/test.lisp -*- Mode: Lisp; -*-
2 |
3 | (deftest agents
4 | "Test agents in the vacuum and wumpus worlds."
5 | "Here is how to run an environment, in this case the vacuum world."
6 | "We specify the maximum number of steps, but that is optional:"
7 | ((run-environment (make-vacuum-world :max-steps 10)))
8 | "You can turn off the display (with :stream nil), and just see the results:"
9 | ((run-environment (make-vacuum-world :stream nil)))
10 | "You can customize several things, such as the agent(s) in the world."
11 | "By default, a vacuum-world has a random-agent; we can change that to"
12 | "a slightly smarter agent with the :ASPEC (Agent SPECification) keyword:"
13 | ((run-environment (make-vacuum-world :stream nil
14 | :aspec '(reactive-vacuum-agent))))
15 | "We can change the probability of dirt in each cell using the :CSPEC"
16 | "keyword (Custom SPECification). It allows a complex language for"
17 | "specifying objects and where they go."
18 | ((run-environment (make-vacuum-world :cspec '((at all (P 0.9 dirt)))
19 | :max-steps 10)))
20 | "Finally, we can compare 2 or more agents over a number of trials:"
21 | ((agent-trials 'make-vacuum-world
22 | '(reactive-vacuum-agent random-vacuum-agent) :n 10))
23 | "Now for the wumpus world"
24 | ((run-environment (make-wumpus-world :max-steps 10)))
25 | )
26 |
--------------------------------------------------------------------------------
/uncertainty/algorithms/stats.lisp:
--------------------------------------------------------------------------------
1 | ;;;; Code for performance assessment of DP and RL algorithms.
2 |
3 | ;;; Makes extensive use of global variables to minimize interference with the
4 | ;;; algorithms themselves.
5 |
6 | (defvar *policy-fn*) ;;; the policy used by the agent in acting
7 | (defvar *correct-U*)
8 | (defvar *correct-M*)
9 | (defvar *correct-R*)
10 |
11 | ;;;; U2 is the correct utility table
12 | ;;;; assume U1, U2 have the same states
13 | (defun u-rms-error (U1 U2 &aux (n 0) (e 0))
14 | (maphash #'(lambda (s u)
15 | (incf n)
16 | (incf e (square (- u (gethash s U2)))))
17 | U1)
18 | (sqrt (/ e n)))
19 |
20 | ;;; The policy loss of a utility function U for an mdp is defined as the
21 | ;;; difference in utility between the corresponding policy and the optimal
22 | ;;; policy, for the agent's current state. Calculate using
23 | ;;; value determination wrt the current policy
24 |
25 | (defun loss (mdp U &aux (U2 (copy-hash-table U #'identity))
26 | (M (mdp-model mdp))
27 | (R (mdp-rewards mdp)))
28 | (maphash #'(lambda (s md) (declare (ignore md))
29 | (unless (gethash s U2) (setf (gethash s U2) 0)))
30 | *correct-R*) ;;; fill in missing entries if any
31 | (setq U2 (value-determination (funcall *policy-fn* U M R)
32 | U2 *correct-M* *correct-R*))
33 | (- (gethash (mdp-initial-state mdp) *correct-U*)
34 | (gethash (mdp-initial-state mdp) U2)))
35 |
36 |
--------------------------------------------------------------------------------
/search/agents/ps-agents.lisp:
--------------------------------------------------------------------------------
1 | ;; -*- Mode: Lisp; -*-
2 |
3 | ;;;; Problem-Solving Agents
4 |
5 | (defstructure (problem-solving-agent (:include agent))
6 | "An agent that applies a search algorithm to a problem to find a solution,
7 | and then follows the steps of the solution, one at a time, and then stops."
8 | (algorithm 'A*-search))
9 |
10 | ;;;; Game-Playing Agents
11 |
12 | (defstructure (game-agent (:include agent))
13 | "An agent that plays n-player games. The ALGORITHM slot is filled by
14 | a function that takes state and game arguments, and returns a move."
15 | (algorithm 'minimax-decision))
16 |
17 | (defstructure (random-game-agent
18 | (:include game-agent (algorithm 'pick-random-move)))
19 | "A game-playing agent that picks randomly from the legal moves.")
20 |
21 | (defstructure (human-game-agent
22 | (:include game-agent (algorithm 'ask-game-user)))
23 | "A game-playing agent that asks the human user what to do.")
24 |
25 | (defun pick-random-move (state game)
26 | (random-element (or (legal-moves game state) '(nothing))))
27 |
28 | (defun ask-game-user (state game)
29 | (let ((legal-moves (legal-moves game state)))
30 | (loop (format t "~&~A's move? " (current-player state))
31 | (let ((move (read)))
32 | (when (member move legal-moves :test #'equal)
33 | (RETURN move))
34 | (format t "~&~A is illegal for ~A. Choose one of:~% ~A.~%"
35 | move (current-player state) legal-moves)))))
36 |
--------------------------------------------------------------------------------
/learning/agents/passive-td-learner.lisp:
--------------------------------------------------------------------------------
1 | ;;; learning/agents/passive-td-learner.lisp
2 | ;;; Passive temporal-difference learning agent.
3 | ;;; After each transition, update the utility of the
4 | ;;; source state i to make it agree more closely with that
5 | ;;; of the destination state j.
6 |
7 | (defvar *alpha* 1.0) ;;; initial learning rate parameter
8 |
9 | (defun make-passive-td-learner ()
10 | (let ((percepts nil)
11 | (U (make-hash-table :test #'equal))
12 | (N (make-hash-table :test #'equal)))
13 | #'(lambda (e)
14 | (push e percepts)
15 | (let ((s (mdp-percept-state e)))
16 | (unless (gethash s N) ;;; make entries for new state
17 | (setf (gethash s N) 0
18 | (gethash s U) 0))
19 | (incf (gethash s N))
20 | (td-update U e percepts N)
21 | (when (mdp-percept-terminalp e)
22 | (setq percepts nil)))
23 | 'no-op)))
24 |
25 | (defun td-update (U e percepts N &aux (terminalp (mdp-percept-terminalp e))
26 | (j (mdp-percept-state e))
27 | (r (mdp-percept-reward e)))
28 | (cond (terminalp
29 | (setf (gethash j U)
30 | (running-average (gethash j U) r (gethash j N))))
31 | ((length>1 percepts)
32 | (let* ((e2 (second percepts))
33 | (i (mdp-percept-state e2)))
34 | (incf (gethash i U)
35 | (* (current-alpha (gethash j N))
36 | (+ r (- (gethash j U) (gethash i U)))))))))
37 |
38 |
39 |
40 | (defun current-alpha (n)
41 | (/ (* 60 *alpha*)
42 | (+ 59 n)))
43 |
--------------------------------------------------------------------------------
/agents/agents/wumpus.lisp:
--------------------------------------------------------------------------------
1 | ;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- Author: Peter Norvig
2 |
3 | ;;;; Agents for the wumpus world
4 |
5 | (defstructure (wumpus-agent (:include agent (body (make-wumpus-agent-body))))
6 | "The default wumpus agent gets an arrow.")
7 |
8 | (defstructure (random-wumpus-agent
9 | (:include wumpus-agent
10 | (program
11 | #'(lambda (percept)
12 | (declare (ignore percept))
13 | (random-element '(forward (turn right) (turn left) shoot grab
14 | release climb)))))))
15 |
16 | (defstruct (aimless-wumpus-agent
17 | (:include wumpus-agent
18 | (program
19 | (let ((plan nil)
20 | (wumpus-alive? t))
21 | #'(lambda (percept)
22 | (destructuring-bind (stench breeze glitter bump sound) percept
23 | (when sound
24 | (setf wumpus-alive? nil))
25 | (cond (glitter 'grab)
26 | (bump (setf plan '((turn right) (turn right) forward))
27 | (pop plan))
28 | (plan (pop plan))
29 | ((or breeze (and wumpus-alive? stench))
30 | (setf plan (list (random-element '((turn left) (turn right)))
31 | 'forward))
32 | (pop plan))
33 | (t (random-element '(forward forward (turn right)
34 | (turn left)))))))))))
35 | "This agent does the obvious reactive things: grab when there's a glitter,
36 | and turn and move when there's a bump. If the wumpus is alive and
37 | there's a stench, it turns and moves. Otherwise it wanders aimlessly.")
38 |
--------------------------------------------------------------------------------
/search/domains/nqueens.lisp:
--------------------------------------------------------------------------------
1 | ;;;; The N-Queens Puzzle as a Constraint Satisfaction Problem
2 |
3 | (defstructure (nqueens-problem (:include CSP-problem)
4 | (:constructor create-nqueens-problem))
5 | (n 8)
6 | (explicit? nil))
7 |
8 | (defun make-nqueens-problem (&rest args &key (n 8) (explicit? nil))
9 | (apply #'create-nqueens-problem
10 | :initial-state (nqueens-initial-state n explicit?)
11 | args))
12 |
13 | (defun nqueens-initial-state (n &optional (explicit? nil) (complete? nil))
14 | (let ((s (make-CSP-state
15 | :unassigned (mapcar #'(lambda (var)
16 | (make-CSP-var :name var
17 | :domain (iota n)))
18 | (iota n))
19 | :assigned nil
20 | :constraint-fn (if explicit?
21 | (let ((constraints (nqueens-constraints n)))
22 | #'(lambda (var1 val1 var2 val2)
23 | (CSP-explicit-check
24 | var1 val1 var2 val2 constraints)))
25 | #'nqueens-constraint-fn))))
26 | (if complete? (CSP-random-completion s) s)))
27 |
28 | (defun nqueens-constraints (n)
29 | (let ((constraints (make-array (list n n))))
30 | (dotimes (i n constraints)
31 | (dotimes (j n)
32 | (unless (= i j)
33 | (dotimes (vi n)
34 | (dotimes (vj n)
35 | (unless (or (= vi vj)
36 | (= (abs (- j i)) (abs (- vj vi))))
37 | (push (cons vi vj)
38 | (aref constraints i j))))))))))
39 |
40 | (defun nqueens-constraint-fn (var1 val1 var2 val2)
41 | (not (or (= val1 val2)
42 | (= (abs (- var1 var2)) (abs (- val1 val2))))))
43 |
44 |
--------------------------------------------------------------------------------
/search/algorithms/ida.lisp:
--------------------------------------------------------------------------------
1 | ;;; ida.lisp
2 |
3 | ;;;; Iterative Deepening A* (IDA*) Search
4 |
5 | (defun tree-ida*-search (problem)
6 | "Iterative Deepening Tree-A* Search [p 107]."
7 | ;; The main loop does a series of f-cost-bounded depth-first
8 | ;; searches until a solution is found. After each search, the f-cost
9 | ;; bound is increased to the smallest f-cost value found that
10 | ;; exceeds the previous bound. Note that the variables here are
11 | ;; local, not static as on [p 107].
12 | (setf (problem-iterative? problem) t)
13 | (let* ((root (create-start-node problem))
14 | (f-limit (node-f-cost root))
15 | (solution nil))
16 | (loop (multiple-value-setq (solution f-limit)
17 | (DFS-contour root problem f-limit))
18 | (dprint "DFS-contour returned" solution "at" f-limit)
19 | (if (not (null solution)) (RETURN solution))
20 | (if (= f-limit infinity) (RETURN nil)))))
21 |
22 | (defun DFS-contour (node problem f-limit)
23 | "Return a solution and a new f-cost limit."
24 | (let ((next-f infinity))
25 | (cond ((> (node-f-cost node) f-limit)
26 | (values nil (node-f-cost node)))
27 | ((goal-test problem (node-state node))
28 | (values node f-limit))
29 | (t (for each s in (expand node problem) do
30 | (multiple-value-bind (solution new-f)
31 | (DFS-contour s problem f-limit)
32 | (if (not (null solution))
33 | (RETURN-FROM DFS-contour (values solution f-limit)))
34 | (setq next-f (min next-f new-f))))
35 | (values nil next-f)))))
36 |
37 |
38 |
--------------------------------------------------------------------------------
/learning/domains/4x3-passive-mdp.lisp:
--------------------------------------------------------------------------------
1 | ;;; Passive, stochastic 4x3 environment for chapter 20.
2 | ;;; Just one possible action (no-op), uniformly arrives at neighbour square.
3 |
4 | (defvar *4x3-passive-M-data*)
5 | (defvar *4x3-passive-R-data*)
6 | (defvar *4x3-passive-mdp*)
7 |
8 | (setq *4x3-passive-mdp*
9 | (make-mdp
10 | :model (make-hash-table :test #'equal)
11 | :rewards (make-hash-table :test #'equal)
12 | :initial-state '(1 1)
13 | :terminal-states '((4 2) (4 3))
14 | :name "4x3-passive-mdp"))
15 |
16 | (setq *4x3-passive-M-data* '(
17 | ((1 1) (no-op (((2 1) 0.5) ((1 2) 0.5))))
18 | ((1 2) (no-op (((1 1) 0.5) ((1 3) 0.5))))
19 | ((1 3) (no-op (((2 3) 0.5) ((1 2) 0.5))))
20 | ((2 1) (no-op (((1 1) 0.5) ((3 1) 0.5))))
21 | ((2 3) (no-op (((1 3) 0.5) ((3 3) 0.5))))
22 | ((3 1) (no-op (((3 2) 0.333333) ((2 1) 0.333333) ((4 1) 0.333333))))
23 | ((3 2) (no-op (((3 3) 0.333333) ((4 2) 0.333333) ((3 1) 0.333333))))
24 | ((3 3) (no-op (((3 2) 0.333333) ((2 3) 0.333333) ((4 3) 0.333333))))
25 | ((4 1) (no-op (((4 2) 0.5) ((3 1) 0.5))))
26 | ((4 2) (no-op ()))
27 | ((4 3) (no-op ()))
28 | ))
29 |
30 | (setq *4x3-passive-R-data* '(((1 1) 0) ((1 2) 0) ((1 3) 0)
31 | ((2 1) 0) ((2 3) 0)
32 | ((3 1) 0) ((3 2) 0) ((3 3) 0)
33 | ((4 1) 0) ((4 2) -1) ((4 3) 1)))
34 |
35 |
36 | (dolist (sd *4x3-passive-M-data*)
37 | (setf (gethash (car sd) (mdp-model *4x3-passive-mdp*)) (cdr sd)))
38 | (dolist (sr *4x3-passive-R-data*)
39 | (setf (gethash (car sr) (mdp-rewards *4x3-passive-mdp*)) (cadr sr)))
40 |
--------------------------------------------------------------------------------
/search/domains/cognac.lisp:
--------------------------------------------------------------------------------
1 | ;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- File: search/domains/cognac.lisp
2 |
3 | ;;;; The Game of Cognac
4 |
5 | ;;; Definitions for a game of uncertain origin reputed to be played by
6 | ;;; bored cognac-tenders in the cellars. Similar to Tic-Tac-Toe but
7 | ;;; instead of playing anywhere, one can only play directly above an
8 | ;;; existing mark or on the bottom row.
9 |
10 | (defstructure (cognac-game (:include ttt-game)
11 | (:constructor create-cognac-game))
12 | "Define an NxN tic-tac-toe-like game. The object is to get K in a row.")
13 |
14 | (defun make-cognac-game (&key (n 3) (k n) (players '(X O)))
15 | "Define an NxN Cognac game in which the object is to get K in a row."
16 | (create-cognac-game
17 | :n n :k k
18 | :initial-state (make-game-state
19 | :board (make-array (list n n) :initial-element '-)
20 | :players players)))
21 |
22 |
23 | (defmethod legal-moves ((game cognac-game) state)
24 | "List all possible legal moves. Like tic-tac-toe, except in each column
25 | you can only move to the lowest unoccupied square."
26 | (let ((board (game-state-board state)))
27 | ;; For each column (x position), the one (at most) possible move
28 | ;; is the lowest empty y position.
29 | (let ((moves nil))
30 | (dotimes (x (array-dimension board 0))
31 | (dotimes (y (array-dimension board 1))
32 | (when (eq (aref board x y) '-)
33 | (push (@ x y) moves)
34 | (return) ; out of y loop
35 | )))
36 | moves)))
37 |
38 | ;;; Everything else is inherited from ttt-game.
39 |
40 |
--------------------------------------------------------------------------------
/learning/agents/active-qi-learner.lisp:
--------------------------------------------------------------------------------
1 | ;;; learning/agents/active-adp-learner.lisp
2 | ;;; Reinforcement learning agent that uses dynamic
3 | ;;; programming to solve the Markov decision process
4 | ;;; that it learns from its experience. Thus, the
5 | ;;; main job is to update the model over time.
6 |
7 | (defun make-random-qi-learner (actions)
8 | (make-active-qi-learner actions #'q-random-choice))
9 | (defun make-maximizing-qi-learner (actions)
10 | (make-active-qi-learner actions #'q-max-choice))
11 |
12 | (defun make-active-qi-learner (actions choice-function)
13 | (let* ((percepts nil)
14 | (last-action nil)
15 | (Q (make-hash-table :test #'equal))
16 | (N (make-hash-table :test #'equal))
17 | (M (make-hash-table :test #'equal))
18 | (R (make-hash-table :test #'equal))
19 | (mdp (make-mdp :model M :rewards R)))
20 | #'(lambda (e)
21 | (push e percepts)
22 | (let ((s (mdp-percept-state e)))
23 | (unless (gethash s N) ;;; make entries for new state
24 | (setf (gethash s N) 0
25 | (gethash s Q) (mapcar #'(lambda (a)
26 | (cons a (mdp-percept-reward e)))
27 | actions)
28 | (gethash s M) (mapcar #'(lambda (a)
29 | (cons a (make-mdp-action-model)))
30 | actions)
31 | (gethash s R) (mdp-percept-reward e)))
32 | (incf (gethash s N))
33 | (update-active-model mdp percepts last-action)
34 | (when (mdp-terminal-states mdp) ;;; make sure DP alg. terminates
35 | (setq Q (q-iteration mdp Q)))
36 | (when (mdp-percept-terminalp e)
37 | (setq percepts nil))
38 | (setq last-action (funcall choice-function s Q))))))
39 |
40 |
--------------------------------------------------------------------------------
/learning/agents/exploring-tdq-learner.lisp:
--------------------------------------------------------------------------------
1 | ;;; learning/agents/exploring-tdq-learner.lisp
2 | ;;; Exploratory reinforcement learning agent using temporal differences.
3 | ;;; Works without a model by using the stochastic sampling to
4 | ;;; mirror the effect of averaging using the model.
5 |
6 | (defun make-exploring-tdq-learner (actions)
7 | (let ((i nil) ;;; the previous state visited
8 | (a nil) ;;; the last action taken
9 | (Q (make-hash-table :test #'equal))
10 | (N (make-hash-table :test #'equal))
11 | (Ri nil)) ;;; reward received in state i
12 | #'(lambda (e)
13 | (let ((terminalp (mdp-percept-terminalp e))
14 | (j (mdp-percept-state e))
15 | (reward (mdp-percept-reward e)))
16 | (unless (gethash j Q)
17 | (setf (gethash j Q)
18 | (mapcar #'(lambda (a) (cons a reward)) actions))
19 | (setf (gethash j N)
20 | (mapcar #'(lambda (a) (cons a 0)) actions)))
21 | (when i
22 | (incf (cdr (assoc a (gethash i N) :test #'eq)))
23 | (update-exploratory-Q Q a i j N Ri))
24 | (cond (terminalp
25 | (setq i nil)
26 | (setf (gethash j Q)
27 | (mapcar #'(lambda (a) (cons a reward)) actions)))
28 | (t (setq i j Ri reward)))
29 | (setq a (exploration-q-choice j Q N))))))
30 |
31 |
32 | (defun update-exploratory-Q (Q a i j N Ri)
33 | (incf (cdr (assoc a (gethash i Q) :test #'eq))
34 | (* (current-alpha (cdr (assoc a (gethash i N) :test #'eq)))
35 | (+ Ri
36 | (- (apply #'max (all-q-entries j Q))
37 | (q-entry Q a i))))))
38 |
39 | (defun exploration-q-choice (s Q N)
40 | (the-biggest-random-tie
41 | #'(lambda (a)
42 | (exploration-function
43 | (q-entry Q a s)
44 | (cdr (assoc a (gethash s N) :test #'equal))))
45 | (q-actions s Q)))
46 |
47 |
--------------------------------------------------------------------------------
/learning/domains/ex-19-4-boolean.lisp:
--------------------------------------------------------------------------------
1 | ;;; learning/domains/ex-19-4-boolean.lisp
2 | ;;; Inductive learning example from exercise 19.4
3 |
4 |
5 | (defvar *ex-19-4-boolean-problem*)
6 |
7 | (setq *ex-19-4-boolean-problem*
8 | (make-learning-problem
9 | :attributes '((i1 1 0)
10 | (i2 1 0)
11 | (i3 1 0)
12 | (i4 1 0)
13 | (i5 1 0)
14 | (i6 1 0))
15 | :goals '((g 0 1))
16 | :examples '(((g . 1) (i1 . 1) (i2 . 0) (i3 . 1) (i4 . 0) (i5 . 0) (i6 . 0))
17 | ((g . 1) (i1 . 1) (i2 . 0) (i3 . 1) (i4 . 1) (i5 . 0) (i6 . 0))
18 | ((g . 1) (i1 . 1) (i2 . 0) (i3 . 1) (i4 . 0) (i5 . 1) (i6 . 0))
19 | ((g . 1) (i1 . 1) (i2 . 1) (i3 . 0) (i4 . 0) (i5 . 1) (i6 . 1))
20 | ((g . 1) (i1 . 1) (i2 . 1) (i3 . 1) (i4 . 1) (i5 . 0) (i6 . 0))
21 | ((g . 1) (i1 . 1) (i2 . 0) (i3 . 0) (i4 . 0) (i5 . 1) (i6 . 1))
22 | ((g . 0) (i1 . 1) (i2 . 0) (i3 . 0) (i4 . 0) (i5 . 1) (i6 . 0))
23 | ((g . 1) (i1 . 0) (i2 . 1) (i3 . 1) (i4 . 1) (i5 . 0) (i6 . 1))
24 | ((g . 0) (i1 . 0) (i2 . 1) (i3 . 1) (i4 . 0) (i5 . 1) (i6 . 1))
25 | ((g . 0) (i1 . 0) (i2 . 0) (i3 . 0) (i4 . 1) (i5 . 1) (i6 . 0))
26 | ((g . 0) (i1 . 0) (i2 . 1) (i3 . 0) (i4 . 1) (i5 . 0) (i6 . 1))
27 | ((g . 0) (i1 . 0) (i2 . 0) (i3 . 0) (i4 . 1) (i5 . 0) (i6 . 1))
28 | ((g . 0) (i1 . 0) (i2 . 1) (i3 . 1) (i4 . 0) (i5 . 1) (i6 . 1))
29 | ((g . 0) (i1 . 0) (i2 . 1) (i3 . 1) (i4 . 1) (i5 . 0) (i6 . 0))
30 | )))
31 |
32 |
33 |
--------------------------------------------------------------------------------
/uncertainty/domains/mdp.lisp:
--------------------------------------------------------------------------------
1 | ;;; Definitions for Markov decision processes (MDPs).
2 |
3 | ;;; An MDP is defined by initial state, transition model, rewards, and
4 | ;;; distinguished terminal states. Model and rewards are hash tables
5 | ;;; index by state (after application of hash-key function).
6 | ;;; The entries in the model are alists keyed by action; each action is
7 | ;;; associated with an action model: basically a list of transitions.
8 | ;;; Markov chains (i.e., stochastic processes with no distinct agent)
9 | ;;; can be defined by allowing only a no-op action in the MDP.
10 |
11 | (defstruct mdp
12 | initial-state ;; The initial state for the problem
13 | (model (make-hash-table :test #'equal)) ;; Describes transition probabilities
14 | (rewards (make-hash-table :test #'equal)) ;; Rewards for each state
15 | (terminal-states nil) ;; List of terminal states
16 | (hash-key #'identity) ;; To convert states into hash keys
17 | name) ;; String, identifies the problem
18 |
19 | (defstruct (mdp-action-model (:type list))
20 | (transitions nil)
21 | (times-executed 0))
22 |
23 | (defstruct (transition (:type list))
24 | destination
25 | probability
26 | (times-achieved 0))
27 |
28 | (defun action-model (a s M)
29 | (cdr (assoc a (gethash s M) :test #'eq)))
30 |
31 | (defun transitions (a s M)
32 | "Returns the transitions resulting from executing
33 | action a in state s according to model M."
34 | (mdp-action-model-transitions (action-model a s M)))
35 |
36 | (defun actions (s M)
37 | "Returns the list of actions feasible in state s according to model M."
38 | (mapcar #'car (gethash s M)))
39 |
40 |
41 |
42 |
43 |
44 |
45 |
46 |
47 |
48 |
49 |
50 |
51 |
52 |
53 |
54 |
--------------------------------------------------------------------------------
/agents/environments/vacuum.lisp:
--------------------------------------------------------------------------------
1 | ;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*-
2 |
3 | ;;;; The Vacuum World: cleaning up dirt in a grid
4 |
5 | (defstructure (dirt (:include object (name "*") (size 0.01))))
6 |
7 | (defstructure (vacuum-world (:include grid-environment
8 | (size (@ 8 8))
9 | (aspec '(random-vacuum-agent))
10 | (cspec '((at all (P 0.25 dirt))))))
11 | "A grid with some dirt in it, and by default a reactive vacuum agent.")
12 |
13 | ;;;; Defining the generic functions
14 |
15 | (defmethod performance-measure ((env vacuum-world) agent)
16 | "100 points for each piece of dirt vacuumed up, -1 point for each
17 | step taken, and -1000 points if the agent does not return home."
18 | (- (* 100 (count-if #'dirt-p (object-contents (agent-body agent))))
19 | (environment-step env)
20 | (if (equal (object-loc (agent-body agent))
21 | (grid-environment-start env))
22 | 0
23 | 1000)))
24 |
25 | (defmethod get-percept ((env vacuum-world) agent)
26 | "Percept is a three-element sequence: bump, dirt and home."
27 | (let ((loc (object-loc (agent-body agent))))
28 | (list (if (object-bump (agent-body agent)) 'bump)
29 | (if (find-object-if #'dirt-p loc env) 'dirt)
30 | (if (equal loc (grid-environment-start env)) 'home))))
31 |
32 | (defmethod legal-actions ((env vacuum-world))
33 | '(suck forward turn shut-off))
34 |
35 | ;;;; Actions (other than the basic grid actions of forward and turn)
36 |
37 | (defmethod suck ((env vacuum-world) agent-body)
38 | (let ((dirt (find-object-if #'dirt-p (object-loc agent-body) env)))
39 | (when dirt
40 | (place-in-container dirt agent-body env))))
41 |
42 | (defmethod shut-off ((env environment) agent-body)
43 | (declare-ignore env)
44 | (setf (object-alive? agent-body) nil))
45 |
46 |
--------------------------------------------------------------------------------
/learning/algorithms/perceptron.lisp:
--------------------------------------------------------------------------------
1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 |
3 | ;;; perceptron learning - single-layer neural networks
4 |
5 | ;;; make-perceptron returns a one-layer network with m units, n inputs each
6 |
7 | (defun make-perceptron (n m &optional (g #'(lambda (i) (step-function 0 i)))
8 | &aux (l nil))
9 | (dotimes (i m (list l))
10 | (push (make-unit :parents (iota (1+ n))
11 | :children nil
12 | :weights (random-weights (1+ n) -0.5 +0.5)
13 | :g g)
14 | l)))
15 |
16 | (defun majority-perceptron (n &optional (g #'(lambda (i) (step-function 0 i))))
17 | (list (list (make-unit :parents (iota (1+ n))
18 | :children nil
19 | :weights (cons (/ n 4)
20 | (make-list n :initial-element 0.5))
21 | :g g))))
22 |
23 |
24 | ;;; perceptron-learning is the standard "induction algorithm"
25 | ;;; and interfaces to the learning-curve functions
26 |
27 | (defun perceptron-learning (problem)
28 | (nn-learning problem
29 | (make-perceptron
30 | (length (learning-problem-attributes problem))
31 | (length (learning-problem-goals problem)))
32 | #'perceptron-update))
33 |
34 | ;;; Perceptron updating - simple version without lower bound on delta
35 | ;;; Hertz, Krogh, and Palmer, eq. 5.19 (p.97)
36 |
37 | (defun perceptron-update (perceptron actual-inputs predicted target
38 | &optional (learning-rate 0.1)
39 | &aux (all-inputs (cons -1 actual-inputs)))
40 | (mapc #'(lambda (unit predicted-i target-i)
41 | (mapl #'(lambda (weights inputs)
42 | (incf (car weights)
43 | (* learning-rate
44 | (- target-i predicted-i)
45 | (car inputs))))
46 | (unit-weights unit) all-inputs))
47 | (car perceptron) predicted target)
48 | perceptron)
49 |
50 |
51 |
52 |
--------------------------------------------------------------------------------
/language/domains/wumpus-grammar.lisp:
--------------------------------------------------------------------------------
1 | ;;; -*- Mode: Lisp; -*- Author: Peter Norvig
2 |
3 | ;;;; A grammar for the wumpus world
4 |
5 | (defparameter *E1*
6 | (grammar
7 | :lexicon
8 | '((Noun -> stench breeze glitter nothing wumpus pit pits
9 | gold north south east west)
10 | (Verb -> is am are see smell shoot feel stinks go grab release
11 | carry kill turn)
12 | (Adjective -> right left east south back smelly)
13 | (Adverb -> here there nearby ahead right left
14 | north south east west back)
15 | ((Pronoun subjective) -> I you he she it) ;; change here
16 | ((Pronoun objective) -> me you him her it) ;; change here
17 | (Name -> John Mary Boston Aristotle)
18 | (Article -> the a an)
19 | (Preposition -> from to at in on near)
20 | (Conjunction -> and or but)
21 | (Digit -> 0 1 2 3 4 5 6 7 8 9)
22 | (that -> that))
23 |
24 | :rules
25 | '((S -> (NP subjective) VP) ;; changes start here
26 | (S -> S Conjunction S)
27 | ((NP $case) -> (Pronoun $case))
28 | ((NP $case) -> Noun)
29 | ((NP $case) -> Article Noun)
30 | ((NP $case) -> Digit Digit)
31 | ((NP $case) -> (NP $case) PP)
32 | ((NP $case) -> (NP $case) RelClause)
33 | (VP -> Verb)
34 | (VP -> Verb (NP objective))
35 | (VP -> Verb Adjective)
36 | (VP -> Verb PP)
37 | (VP -> Verb Adverb)
38 | (PP -> Preposition (NP objective)) ;; changes end here
39 | (RelClause -> that VP)))
40 | "Lexicon and grammar for E1 in Figure 22.10, page 670.")
41 |
42 | will, did
43 | a, the
44 | --
45 | yes, no, maybe, ok, huh
46 |
47 | S -> Question | Command | Report | Acknowledgement | S -- S
48 |
49 | Question -> Aux NP VP | Be NP VP-args
50 |
51 | Command -> "you" VP
52 |
53 | Report -> "I" VP
54 |
55 | NP -> Pronoun | {Article} Noun
56 |
57 | VP -> {Aux} Verb VP-args
58 |
59 | VP-args -> {NP} {PP} {Adverb}
60 |
61 | PP -> Prep NP
62 |
63 | ;;; Terminals
64 |
65 | Acknowledgement -> "yes" | "no" | "ok" | "huh"
66 |
67 | Verb -> Aux | "shoot" | ...
68 |
69 | Aux -> Be | "will" | "did"
70 |
71 | Be -> "is" | "am" | "are"
72 |
73 | Adverb -> "here" | ...
74 |
--------------------------------------------------------------------------------
/learning/algorithms/inductive-learning.lisp:
--------------------------------------------------------------------------------
1 | ;;; learning:inductive-learning.lisp
2 | ;;; Definition for learning problems and
3 | ;;; utilities for generating and manipulating example data.
4 | ;;; Examples are list of (attribute . value) pairs.
5 | ;;; Some of these may be goal values -- no explicit separation in data
6 |
7 |
8 | (defstruct (learning-problem (:print-function print-learning-problem))
9 | examples
10 | attributes
11 | goals)
12 |
13 | (defun attribute-name (attribute) (first attribute))
14 | (defun attribute-values (attribute) (rest attribute))
15 |
16 | (defun attribute-value (attribute example)
17 | (cdr (assoc (attribute-name attribute) example :test #'eq)))
18 |
19 | (defun random-examples (n attributes &aux (l nil))
20 | (dotimes (i n l)
21 | (push (mapcar #'(lambda (a)
22 | (cons (attribute-name a)
23 | (random-element (attribute-values a))))
24 | attributes)
25 | l)))
26 |
27 | (defun classify (unclassified-examples goals h performance-element)
28 | (mapcar #'(lambda (e)
29 | (append (mapcar #'(lambda (goal value)
30 | (cons (attribute-name goal)
31 | value))
32 | goals
33 | (funcall performance-element h e))
34 | e))
35 | unclassified-examples))
36 |
37 | (defun consistent (examples goals h performance-element)
38 | (every #'(lambda (e)
39 | (every #'(lambda (goal value)
40 | (eq (attribute-value goal e)
41 | value))
42 | goals
43 | (funcall performance-element h e)))
44 | examples))
45 |
46 | ;;; Coded examples have goal values (in a single list)
47 | ;;; followed by attribute values, both in fixed order
48 |
49 | (defun code-examples (examples attributes goals)
50 | (mapcar #'(lambda (e) (code-example e attributes goals)) examples))
51 |
52 | (defun code-example (example attributes goals)
53 | (cons (mapcar #'(lambda (g) (attribute-value g example)) goals)
54 | (mapcar #'(lambda (a) (attribute-value a example)) attributes)))
55 |
56 | (defun code-unclassified-example (example attributes goals)
57 | (declare (ignore goals))
58 | (mapcar #'(lambda (a) (attribute-value a example)) attributes))
59 |
60 | (defun print-learning-problem (problem &optional stream depth)
61 | (declare (ignore depth))
62 | (format stream "#<~A with ~D examples and ~D attributes>"
63 | (type-of problem)
64 | (length (learning-problem-examples problem))
65 | (length (learning-problem-attributes problem))))
66 |
--------------------------------------------------------------------------------
/logic/algorithms/tell-ask.lisp:
--------------------------------------------------------------------------------
1 | ;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- File: tell-ask.lisp
2 |
3 | ;;;; Main Functions on KBs: Tell, Retract, Ask-Each, Ask, Ask-Pattern[s]
4 |
5 | ;;; First we define a very simple kind of knowledge base, literal-kb,
6 | ;;; that just stores a list of literal sentences.
7 |
8 | (defstructure literal-kb
9 | "A knowledge base that just stores a set of literal sentences."
10 | (sentences '()))
11 |
12 | ;;; There are three generic functions that operate on knowledge bases, and
13 | ;;; that must be defined as methods for each type of knowledge base: TELL,
14 | ;;; RETRACT, and ASK-EACH. Here we show the implementation for literal-kb;
15 | ;;; elsewhere you'll see implementations for propositional, Horn, and FOL KBs.
16 |
17 | (defmethod tell ((kb literal-kb) sentence)
18 | "Add the sentence to the knowledge base."
19 | (pushnew sentence (literal-kb-sentences kb) :test #'equal))
20 |
21 | (defmethod retract ((kb literal-kb) sentence)
22 | "Remove the sentence from the knowledge base."
23 | (deletef sentence (literal-kb-sentences kb) :test #'equal))
24 |
25 | (defmethod ask-each ((kb literal-kb) query fn)
26 | "For each proof of query, call fn on the substitution that
27 | the proof ends up with."
28 | (declare (special +no-bindings+))
29 | (for each s in (literal-kb-sentences kb) do
30 | (when (equal s query) (funcall fn +no-bindings+))))
31 |
32 | ;;; There are three other ASK functions, defined below, that are
33 | ;;; defined in terms of ASK-EACH. These are defined once and for all
34 | ;;; here (not for each kind of KB)."
35 |
36 | (defun ask (kb query)
37 | "Ask if query sentence is true; return t or nil."
38 | (ask-each kb (logic query)
39 | #'(lambda (s) (declare (ignore s)) (RETURN-FROM ASK t))))
40 |
41 | (defun ask-pattern (kb query &optional (pattern query))
42 | "Ask if query sentence is true; if it is, substitute bindings into pattern."
43 | (ask-each kb (logic query)
44 | #'(lambda (s) (RETURN-FROM ASK-PATTERN
45 | (subst-bindings s (logic pattern))))))
46 |
47 | (defun ask-patterns (kb query &optional (pattern query))
48 | "Find all proofs for query sentence, substitute bindings into pattern
49 | once for each proof. Return a list of all substituted patterns."
50 | (let ((pat (logic pattern))
51 | (results nil))
52 | (ask-each kb (logic query)
53 | #'(lambda (s) (push (subst-bindings s pat) results)))
54 | (nreverse results)))
55 |
--------------------------------------------------------------------------------
/logic/README.html:
--------------------------------------------------------------------------------
1 |
2 |
3 | Logic (Subsystem of AIMA Code)
4 |
5 |
6 |
7 |
8 | Logic (Subsystem of AIMA Code)
9 |
10 | The logic system covers part III of the book. We define
11 | knowledge bases, and tell and ask operations on
12 | those knowledge bases. The interface is defined in the file tell-ask.lisp.
14 |
15 |
16 | We need a new language for logical expressions,
17 | since we don't have all the nice characters (like upside-down A) that
18 | we would like to use. We will allow an infix format for input, and
19 | manipulate a Lisp-like prefix format internally. Here is a
20 | description of the formats (compare to [p 167, 187]). The prefix
21 | notation is a subset of the KIF
23 | 3.0 Knowledge Interchange Format.
24 |
25 |
26 | Infix Prefix Meaning Alternate Infix Notation
27 | ========== ====== =========== ========================
28 | ~P (not P) negation not P
29 | P ^ Q (and P Q) conjunction P and Q
30 | P | Q (or P Q) disjunction P or Q
31 | P => Q (=> P Q) implication
32 | P <=> Q (<=> P Q) logical equivalence
33 | P(x) (P x) predicate
34 | Q(x,y) (Q x y) predicate with multiple arguments
35 | f(x) (f x) function
36 | f(x)=3 (= (f x) 3) equality
37 | forall(x,P(x) (forall (x) (P x)) universal quantification
38 | exists(x,P(x) (exists (x) (P x)) existential quantification
39 | [a,b] (listof a b) list of elements
40 | {a,b} (setof a b) mathematical set of elements
41 | true true the true logical constant
42 | false false the false logical constant
43 |
44 |
45 | You can also use the usual operators for mathematical notation: +, -,
46 | *, / for arithmetic, and &;lt;, >, <=, >= for comparison.
47 | Many of the functions we define also accept strings as input,
48 | interpreting them as infix expressions, so the following are
49 | equivalent:
50 |
51 |
52 | (tell kb "P=>Q")
53 | (tell kb '(=> P Q))
54 |
55 |
56 |
57 |
58 |
59 |
60 |
--------------------------------------------------------------------------------
/agents/agents/agent.lisp:
--------------------------------------------------------------------------------
1 | ;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- Author: Peter Norvig
2 |
3 | ;;;; Definition of basic AGENT functions
4 |
5 | (defstructure (ask-user-agent (:include agent (program 'ask-user)))
6 | "An agent that asks the user to type in an action.")
7 |
8 | (defun ask-user (percept)
9 | "Ask the user what action to take."
10 | (format t "~&Percept is ~A; action? " percept)
11 | (read))
12 |
13 | (defmethod print-structure ((agent agent) stream)
14 | "Agents are printed by showing their name (or body) and score."
15 | (format stream "[~A = ~D]" (or (agent-name agent) (agent-body agent))
16 | (agent-score agent)))
17 |
18 | (defun initialize-agent-names (env)
19 | "Name the agents 1, 2, ... if they don't yet have a name."
20 | (for each agent in (environment-agents env) do
21 | (when (null (agent-name agent))
22 | (let ((i (+ 1 (position agent (environment-agents env))))
23 | (body (agent-body agent)))
24 | (setf (agent-name agent) i)
25 | (when (and body (null (object-name body)))
26 | (setf (object-name body) i))))))
27 |
28 | ;; Design Decision Notes
29 |
30 | ;; We have decided that the agent and its body are two separate objects.
31 | ;; We could have combined the agent and its body into one object. But then
32 | ;; each new type of agent would need to inherit from both AGENT and some
33 | ;; body type, such as OBJECT. This would require multiple inheritance,
34 | ;; which is part of CLOS, but is not in our simple implementation for those
35 | ;; who don't have CLOS. In any case, it would get messy. We think that
36 | ;; separating agents from agent-bodies is a good thing for this
37 | ;; implementation. (Just don't take it too far and assume that this says
38 | ;; anything about the mind-body problem.)
39 | ;;
40 | ;; We could have defined the agent program as a generic function on the
41 | ;; agent. But that would mean that everytime you want to try out a
42 | ;; slightly different agent program, you would need to define a new type. You
43 | ;; would also need to hold state information in slots rather than in local
44 | ;; variables, and we would need to have some kind of discipline to ensure
45 | ;; that the slots representing intermediate state could be accessed and
46 | ;; modified by the agent program, while the slot representing, say, the score
47 | ;; could not. All in all, a closure (a different one for every agent) is
48 | ;; exactly what we want in an agent program: a closure encapsulates local
49 | ;; state and behavior, and can access only its arguments and closed-over
50 | ;; variables.
51 |
52 |
--------------------------------------------------------------------------------
/learning/agents/passive-adp-learner.lisp:
--------------------------------------------------------------------------------
1 | ;;; learning/agents/passive-adp-learner.lisp
2 | ;;; Reinforcement learning agent that uses dynamic
3 | ;;; programming to solve the Markov process
4 | ;;; that it learns from its experience. Thus, the
5 | ;;; main job is to update the model over time.
6 | ;;; Being a passive agent, it simply does no-op
7 | ;;; at each step, watching the world go by.
8 |
9 | (defun make-passive-adp-learner ()
10 | (let ((percepts nil)
11 | (U (make-hash-table :test #'equal))
12 | (N (make-hash-table :test #'equal))
13 | (M (make-hash-table :test #'equal))
14 | (R (make-hash-table :test #'equal)))
15 | #'(lambda (e)
16 | (push e percepts)
17 | (let ((s (mdp-percept-state e)))
18 | (unless (gethash s N) ;;; make entries for new state
19 | (setf (gethash s N) 0
20 | (gethash s U) 0
21 | (gethash s M) (list
22 | (cons 'no-op (make-mdp-action-model)))
23 | (gethash s R) (mdp-percept-reward e)))
24 | (incf (gethash s N))
25 | (update-passive-model s percepts M)
26 | (setq U (value-determination (passive-policy M) U M R))
27 | (when (mdp-percept-terminalp e)
28 | (setq percepts nil)))
29 | 'no-op)))
30 |
31 | ;;; Updating the transition model according to oberved transition i->j.
32 | ;;; Fairly tedious because of initializing new transition records.
33 |
34 | (defun update-passive-model
35 | (j ;;; current state (destination of transition)
36 | percepts ;;; in reverse chronological order
37 | M ;;; transition model, indexed by state
38 | &aux transition)
39 | (when (length>1 percepts)
40 | (let* ((e2 (second percepts))
41 | (i (mdp-percept-state e2)) ;;; transition from i, so update i's model
42 | (action-model (action-model 'no-op i M))
43 | (transitions (mdp-action-model-transitions action-model)))
44 | (incf (mdp-action-model-times-executed action-model))
45 | (unless (setq transition
46 | (find j transitions :test #'equal
47 | :key #'transition-destination))
48 | (push (setq transition (make-transition :destination j))
49 | (mdp-action-model-transitions action-model)))
50 | (incf (transition-times-achieved transition))
51 | (dolist (trans (mdp-action-model-transitions action-model))
52 | (setf (transition-probability trans)
53 | (float (/ (transition-times-achieved trans)
54 | (mdp-action-model-times-executed action-model))))))))
55 |
56 | ;;; (passive-policy M) makes a policy of no-ops for use in value determination
57 |
58 | (defun passive-policy (M)
59 | (copy-hash-table M #'(lambda (x) (declare (ignore x))
60 | (list (list 'no-op 1.0)))))
--------------------------------------------------------------------------------
/doc/overview.html:
--------------------------------------------------------------------------------
1 |
2 | Overview of AIMA Code
3 |
4 |
5 |
6 | Overview of AIMA Code
7 |
8 | This serves as the starting point for exploring the online code for
9 | Artificial Intelligence: A Modern Approach. You can see:
10 |
11 |
42 |
43 |
50 |
--------------------------------------------------------------------------------
/logic/algorithms/horn.lisp:
--------------------------------------------------------------------------------
1 | ;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- File: logic/horn.lisp
2 |
3 | ;;;; Logical Reasoning in Horn Clause Knowledge Bases
4 |
5 | (defstructure horn-kb
6 | ;; Index all Horn sentences by the predicate on the right-hand side.
7 | ;; That is, both (=> P (Q x)) and (Q 3) would be indexed under Q.
8 | (table (make-hash-table :test #'eq)))
9 |
10 | (defmethod tell ((kb horn-kb) sentence)
11 | "Add a sentence to a Horn knowledge base. Warn if its not a Horn sentence."
12 | (for each clause in (conjuncts (->horn sentence)) do
13 | ;; Each clause should be of form (=> P (Q x)); add to hash for Q
14 | (setf (gethash (op (arg2 clause)) (horn-kb-table kb))
15 | (nconc (gethash (op (arg2 clause)) (horn-kb-table kb))
16 | (list clause)))))
17 |
18 | (defmethod retract ((kb horn-kb) sentence)
19 | "Delete each conjunct of sentence from KB."
20 | (for each clause in (conjuncts (->horn sentence)) do
21 | ;; Each clause should be of form (=> P (Q x)); delete from hash for Q
22 | (deletef clause (gethash (op (arg2 clause)) (horn-kb-table kb))
23 | :test #'renaming?)))
24 |
25 | (defmethod ask-each ((kb horn-kb) query fn)
26 | "Use backward chaining to decide if sentence is true."
27 | (back-chain-each kb (conjuncts (->cnf query)) +no-bindings+ fn))
28 |
29 | (defun back-chain-each (kb goals bindings fn)
30 | "Solve the conjunction of goals by backward chaining.
31 | See [p 275], but notice that this implementation is different.
32 | It applies fn to each answer found, and handles composition differently."
33 | (cond ((eq bindings +fail+) +fail+)
34 | ((null goals) (funcall fn bindings))
35 | (t (let ((goal (first goals)))
36 | (case (op goal)
37 | (FALSE +fail+)
38 | (TRUE (back-chain-each kb (rest goals) bindings fn))
39 | (= (back-chain-each kb (rest goals)
40 | (unify (arg1 goal) (arg2 goal) bindings)
41 | fn))
42 | (AND (back-chain-each kb (append (conjuncts goal) goals)
43 | bindings fn))
44 | (OR (for each disjunct in (disjuncts goal) do
45 | (back-chain-each kb (cons disjunct goals)
46 | bindings fn)))
47 | (NOT +fail+) ; Horn clause provers can't handle NOT
48 | (t ;; Look at all the clauses that could conclude the goal.
49 | (for each clause in (gethash (op goal) (horn-kb-table kb)) do
50 | (let ((new-clause (rename-variables clause)))
51 | (back-chain-each
52 | kb
53 | (append (conjuncts (arg1 new-clause)) (rest goals))
54 | (unify goal (arg2 new-clause) bindings)
55 | fn)))))))))
56 |
57 |
--------------------------------------------------------------------------------
/learning/algorithms/dtl.lisp:
--------------------------------------------------------------------------------
1 | ;;; decision tree learning algorithm - the standard "induction algorithm"
2 | ;;; returns a tree in the format
3 | ;;; (a1 (v11 . ) (v12 . )), bottoming out with goal values.
4 | ;;; currently handles only a single goal attribute
5 |
6 | (defun decision-tree-learning (problem)
7 | (dtl (learning-problem-examples problem)
8 | (learning-problem-attributes problem)
9 | (first (learning-problem-goals problem))))
10 |
11 | (defun dtl (examples attributes goal &optional prior &aux (trees nil))
12 | (cond ((null examples) prior)
13 | ((null attributes) (majority examples goal))
14 | ((every #'(lambda (e) (eq (attribute-value goal e)
15 | (attribute-value goal (first examples))))
16 | (rest examples))
17 | (majority examples goal))
18 | (t (let ((best (select-attribute examples attributes goal)))
19 | (dolist (v (rest best) (cons best trees))
20 | (push (cons v (dtl (remove-if-not
21 | #'(lambda (e) (eq v (attribute-value best e)))
22 | examples)
23 | (remove best attributes)
24 | goal
25 | (majority examples goal)))
26 | trees))))))
27 |
28 | (defun distribution (examples goal
29 | &aux (l (length (rest goal)))
30 | (d (make-list l :initial-element 0)))
31 | (dolist (e examples)
32 | (incf (nth (position (attribute-value goal e) (rest goal)) d)))
33 | (mapcar #'(lambda (n) (float (/ n (length examples)))) d))
34 |
35 | (defun majority (examples goal)
36 | (the-biggest #'(lambda (v)
37 | (count v (mapcar #'(lambda (e) (attribute-value goal e))
38 | examples)))
39 | (rest goal)))
40 |
41 | (defun select-attribute (examples attributes goal)
42 | (the-biggest #'(lambda (a) (information-value a examples goal))
43 | attributes))
44 |
45 | (defun information-value
46 | (a examples goal
47 | &aux (i (bits-required (distribution examples goal))))
48 | (dolist (v (rest a) i)
49 | (let ((s (remove-if-not #'(lambda (e) (eq (attribute-value a e) v)) examples)))
50 | (when s (decf i (* (bits-required (distribution s goal))
51 | (/ (length s) (length examples))))))))
52 |
53 | (defun bits-required (d &aux (b 0))
54 | (dolist (p d (- b))
55 | (unless (= 0 p)
56 | (incf b (* p (log p 2))))))
57 |
58 | ;;; dtpredict is the standard "performance element" that
59 | ;;; interfaces with the example-generation and learning-curve functions
60 |
61 | (defun dtpredict (dt example)
62 | (if (atom dt) (list dt)
63 | (dtpredict (cdr (assoc (attribute-value (car dt) example) (cdr dt)))
64 | example)))
65 |
--------------------------------------------------------------------------------
/search/domains/vacuum.lisp:
--------------------------------------------------------------------------------
1 | ;;; File: search/domains/vacuum.lisp
2 |
3 | ;;;; Definitions for Searching in the Vacuum-World Domain
4 |
5 | (defstruct (vacuum-state (:type list))
6 | orientation ; an xy unit vector
7 | dirt ; list of dirt locations
8 | m n ; world is m by n squares
9 | on ; true if agent is switched on
10 | location ; xy agent location
11 | )
12 |
13 | (defvar *vacuum-home* (@ 0 0))
14 |
15 | ;;;; Vacuum problem generator, and vacuum domain functions
16 |
17 | (defun vacuum-problem (m n &optional (dirt nil) (dirt-probability 0.2))
18 | "Create a Vacuum World problem."
19 | (make-problem
20 | :initial-state (vacuum-initial-state m n dirt dirt-probability)
21 | :successor-fn #'vacuum-successors
22 | :goal-test #'vacuum-goalp
23 | :h-cost-fn #'(lambda (state)
24 | (* 2 (length (vacuum-state-dirt state))))
25 | :domain "vacuum world"
26 | ))
27 |
28 | (defun vacuum-initial-state (m n dirt dirt-probability)
29 | (make-vacuum-state :orientation (@ 1 0)
30 | :m m :n n :on t :location *vacuum-home*
31 | :dirt (or dirt
32 | (dotimes (x n dirt)
33 | (dotimes (y m)
34 | (when (< (random 1.0) dirt-probability)
35 | (push (@ x y) dirt)))))))
36 |
37 | (defun vacuum-goalp (state)
38 | "Is this a goal state?"
39 | (and (null (vacuum-state-dirt state))
40 | (xy-equal (vacuum-state-location state) *vacuum-home*)
41 | (not (vacuum-state-on state))))
42 |
43 | (defun vacuum-successors (state)
44 | "Return a list of (action . state) pairs."
45 | (destructuring-bind (o d m n on l) state
46 | (if on
47 | (list
48 | (cons 'forward
49 | (if (inside (xy-add l o) n m)
50 | (make-vacuum-state :orientation o
51 | :dirt d
52 | :m m :n n :on on
53 | :location (xy-add l o))
54 | state))
55 | (cons '(turn left)
56 | (make-vacuum-state :orientation (rotate o 0 -1 1 0)
57 | :dirt d
58 | :m m :n n :on on
59 | :location l))
60 | (cons '(turn right)
61 | (make-vacuum-state :orientation (rotate o 0 1 -1 0)
62 | :dirt d
63 | :m m :n n :on on
64 | :location l))
65 | (cons 'suck
66 | (if (member l d :test #'xy-equal)
67 | (make-vacuum-state :orientation o
68 | :dirt (remove l d :test #'xy-equal)
69 | :m m :n n :on on
70 | :location l)
71 | state))
72 | (cons 'shut-off
73 | (make-vacuum-state :orientation o
74 | :dirt d
75 | :m m :n n :on nil
76 | :location l)))
77 | nil)))
78 |
--------------------------------------------------------------------------------
/utilities/test-utilities.lisp:
--------------------------------------------------------------------------------
1 | ;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- File: utilities/test.lisp
2 |
3 | ;;;; Test cases for the basic utilities
4 |
5 | (deftest utilities
6 | "Test all the utility functions."
7 |
8 | "Test the CLOS implementation"
9 | ((defstructure shape))
10 | ((defstructure (triangle (:include shape))
11 | base height))
12 | ((defstructure (rectangle (:include shape))
13 | height width))
14 | ((defmethod area ((x triangle))
15 | (* 1/2 (triangle-base x) (triangle-height x))))
16 | ((defmethod area ((x rectangle))
17 | (* (rectangle-height x) (rectangle-width x))))
18 | ((area (make-triangle :base 10 :height 10)) (equal * 50))
19 | ((area (make-rectangle :width 10 :height 10)) (equal * 100))
20 | ((defmethod features ((x shape))
21 | '(shapely)))
22 | ((defmethod features ((x triangle))
23 | (cons (if (eql 0 (triangle-base x)) 'line 'triangle)
24 | (call-next-method))))
25 | ((features (make-triangle :base 0 :height 10)) (equal * '(line shapely)))
26 | ((features (make-triangle :base 1 :height 10)) (equal * '(triangle shapely)))
27 |
28 | "Now, some operations on lists."
29 | ((length>1 '(a b c)) *)
30 | ((random-element '(a b c)) (member * '(a b c)))
31 | ((mappend #'reverse '((a b c) (1 2 3))) (equal * '(c b a 3 2 1)))
32 | ((starts-with '(hi there) 'hi) *)
33 | ((last1 '(a b c)) (eq * 'c))
34 | ((transpose '((a b c) (d e f))) (equal * '((a d) (b e) (c f))))
35 | ((setq l '(a b c)))
36 | ((deletef 'a l) (equal l '(b c)))
37 |
38 | "Now for 2-dimensional points."
39 | ((xy-add (@ 1 2) (@ 10 20)) (equal * (@ 11 22)))
40 | ((xy-distance (@ 0 0) (@ 3 4)) (= * 5))
41 |
42 | "Numeric utilities"
43 | ((average '(10 20 30)) (= * 20))
44 | ((sum '(10 20 30)) (= * 60))
45 | ((sum '(1 2 3) #'square) (= * 14))
46 | ((random-integer 8 10) (member * '(8 9 10)))
47 | ((fuzz 10) (<= 9 * 11))
48 | ((round-off 3.14159 .01) (< 3.139 * 3.141))
49 |
50 | "Other"
51 | ((stringify '(a b c)) (equalp * "(A B C)"))
52 | ((concat-symbol 'a 1) (eq * 'a1))
53 | ((funcall (compose #'- #'sqrt) 16) (= * -4))
54 | ((setq nums '(1 2 3 4 -5 -2 -1)))
55 | ((the-biggest #'identity nums) (eql * 4))
56 | ((the-biggest #'abs nums) (eql * -5))
57 | ((the-biggest-that #'identity #'oddp nums) (eql * 3))
58 | ((the-smallest-random-tie #'abs nums) (member * '(1 -1)))
59 |
60 | "Now test the priority queue code."
61 | ((heap-sort '(1 4 3 5 2 0)) (equal * '(0 1 2 3 4 5)))
62 | ((heap-sort '(1 4 3 5 2 6) :key #'-) (equal * '(6 5 4 3 2 1)))
63 |
64 | "Now destructuring-bind"
65 | ((destructuring-bind ((a . b) c &rest d &key e (f 5)) '((1 . 2) 3 :e 4)
66 | (list a b c d e f)) (equal * '(1 2 3 (:e 4) 4 5)))
67 | )
68 |
--------------------------------------------------------------------------------
/learning/algorithms/multilayer.lisp:
--------------------------------------------------------------------------------
1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 |
3 | ;;; back-propagation learning - multi-layer neural networks
4 |
5 | ;;; backprop-learning is the standard "induction algorithm"
6 | ;;; and interfaces to the learning-curve functions
7 |
8 | (defun backprop-learning (problem
9 | &optional
10 | (hidden (length
11 | (learning-problem-attributes problem))))
12 | (nn-learning problem
13 | (make-connected-nn
14 | (list (length (learning-problem-attributes problem))
15 | hidden
16 | (length (learning-problem-goals problem))))
17 | #'backprop-update))
18 |
19 | ;;; Backprop updating - Hertz, Krogh, and Palmer, p.117
20 |
21 | (defun backprop-update (network actual-inputs predicted target
22 | &optional (learning-rate 0.5)
23 | &aux (all-inputs (cons -1 actual-inputs)))
24 | (backpropagate (reverse network) ;;; start at the output layer
25 | all-inputs ;;; include the bias input
26 | (mapcar #'(lambda (iunit predicted-i target-i)
27 | (* (unit-gradient iunit)
28 | (- target-i predicted-i)))
29 | (car (last network)) predicted target)
30 | learning-rate)
31 | network)
32 |
33 | (defun backpropagate (rnetwork ;;; network in reverse order
34 | inputs ;;; the inputs to the network
35 | deltas ;;; the "errors" for current layer
36 | learning-rate)
37 | (cond ((null (cdr rnetwork)) ;;; have reached the earliest hidden layer
38 | (backprop-update-layer
39 | (car rnetwork) inputs deltas learning-rate))
40 | (t (backprop-update-layer
41 | (car rnetwork) (cons -1 (mapcar #'unit-a (cadr rnetwork)))
42 | deltas learning-rate)
43 | (backpropagate
44 | (cdr rnetwork)
45 | inputs
46 | (compute-deltas (cadr rnetwork) (car rnetwork) deltas)
47 | learning-rate))))
48 |
49 |
50 | (defun backprop-update-layer (layer all-inputs deltas learning-rate)
51 | (mapc #'(lambda (unit delta)
52 | (mapl #'(lambda (weights inputs)
53 | (incf (car weights)
54 | (* learning-rate
55 | delta
56 | (car inputs))))
57 | (unit-weights unit) all-inputs))
58 | layer deltas))
59 |
60 | ;;; compute-deltas propagates the deltas back from layer i to layer j
61 | ;;; pretty ugly, partly because weights Wji are stored only at layer i
62 |
63 | (defun compute-deltas (jlayer ilayer ideltas &aux (j 0))
64 | (mapcar #'(lambda (junit)
65 | (incf j)
66 | (* (unit-gradient junit)
67 | (dot-product ideltas
68 | (mapcar #'(lambda (iunit)
69 | (nth j (unit-weights iunit)))
70 | ilayer))))
71 | jlayer))
72 |
73 |
74 |
75 |
76 |
77 |
78 |
79 |
--------------------------------------------------------------------------------
/search/domains/cannibals.lisp:
--------------------------------------------------------------------------------
1 | ;; -*- Mode: Lisp; -*-
2 |
3 | ;;;; The Missionaries and Cannibals Domain
4 |
5 | (defstructure (cannibal-problem
6 | (:include problem (initial-state (make-cannibal-state))))
7 | "The problem is to move M missionaries and C cannibals from one side
8 | of a river to another, using B boats that holds at most two people each,
9 | in such a way that the cannibals never outnumber the missionaries in
10 | any one place. See [p 68].")
11 |
12 | (defmethod goal-test ((problem cannibal-problem) state)
13 | "The goal is to have no missionaries or cannibals left on the first side."
14 | (= 0 (m1 state) (c1 state)))
15 |
16 | (defmethod successors ((problem cannibal-problem) state)
17 | "Return a list of (action . state) pairs. An action is a triple of the
18 | form (delta-m delta-c delta-b), where a positive delta means to move from
19 | side 1 to side 2; negative is the opposite. For example, the action (1 0 1)
20 | means move one missionary and 1 boat from side 1 to side 2."
21 | (let ((pairs nil))
22 | (for each action in '((+1 0 +1) (0 +1 +1) (+2 0 +1) (0 +2 +1) (+1 +1 +1)
23 | (-1 0 -1) (0 -1 -1) (-2 0 -1) (0 -2 -1) (-1 -1 -1)) do
24 | (let ((new-state (take-the-boat state action)))
25 | (when (and new-state (not (cannibals-can-eat? new-state)))
26 | (push (cons action new-state) pairs))))
27 | pairs))
28 |
29 | (defstruct (cannibal-state (:conc-name nil) (:type list))
30 | "The state says how many missionaries, cannibals, and boats on each
31 | side. The components m1,c1,b1 stand for the number of missionaries,
32 | cannibals and boats, respectively, on the first side of the river.
33 | The components m2,c2,b2 are for the other side of the river."
34 | ;; We need to represent both sides (rather than just one as on [p 68])
35 | ;; because we have generalized from 3+3 people to M+C. Incidently, we
36 | ;; also generalized from 1 boat to B boats.
37 | (m1 3) (c1 3) (b1 1) (m2 0) (c2 0) (b2 0))
38 |
39 | (defun take-the-boat (state action)
40 | "Move a certain number of missionaries, cannibals, and boats (if possible)."
41 | (destructuring-bind (delta-m delta-c delta-b) action
42 | (if (or (and (= delta-b +1) (> (b1 state) 0))
43 | (and (= delta-b -1) (> (b2 state) 0)))
44 | (let ((new (copy-cannibal-state state)))
45 | (decf (m1 new) delta-m) (incf (m2 new) delta-m)
46 | (decf (c1 new) delta-c) (incf (c2 new) delta-c)
47 | (decf (b1 new) delta-b) (incf (b2 new) delta-b)
48 | (if (and (>= (m1 new) 0) (>= (m2 new) 0)
49 | (>= (c1 new) 0) (>= (c2 new) 0))
50 | new
51 | nil))
52 | nil)))
53 |
54 | (defun cannibals-can-eat? (state)
55 | "The cannibals feast if they outnumber the missionaries on either side."
56 | (or (> (c1 state) (m1 state) 0)
57 | (> (c2 state) (m2 state) 0)))
58 |
59 |
--------------------------------------------------------------------------------
/learning/test-learning.lisp:
--------------------------------------------------------------------------------
1 | (deftest learning
2 | ((setq p *restaurant-boolean-problem*))
3 | ((setq e (learning-problem-examples p)
4 | g (learning-problem-goals p)))
5 | ((setq h (decision-list-learning 4 p)))
6 | ((accuracy h #'dlpredict e g)
7 | (= * 1.0))
8 | ((setq p *restaurant-multivalued-problem*))
9 | ((setq e (learning-problem-examples p)
10 | g (learning-problem-goals p)))
11 | ((setq h (decision-tree-learning p)))
12 | ((accuracy h #'dtpredict e g)
13 | (= * 1.0))
14 | ((setq p *majority-boolean-problem*))
15 | ((setq e (learning-problem-examples p)
16 | a (learning-problem-attributes p)
17 | g (learning-problem-goals p)))
18 | ((setq h (nn-learning p (make-perceptron 11 1) #'perceptron-update)))
19 | ((accuracy h #'(lambda (e1 h1) (nn-output e1 h1 a g)) e g)
20 | (> * 0.8))
21 | ((setq p *restaurant-real12-problem*))
22 | ((setq e (learning-problem-examples p)
23 | a (learning-problem-attributes p)
24 | g (learning-problem-goals p)))
25 | ((setq h (nn-learning p (make-connected-nn '(10 4 1)) #'backprop-update)))
26 | ((accuracy h #'(lambda (e1 h1) (nn-output e1 h1 a g)) e g #'rms-error)
27 | (> * 0.8))
28 | ((setq a (make-mdp-agent
29 | :name 'LM :program (make-passive-lms-learner))))
30 | ((setq e (make-mdp-environment :mdp *4x3-passive-mdp* :agents (list a)
31 | :epochs-left 2)))
32 | ((run-environment e)) ;;; for now just make sure it runs
33 | ((setq a (make-mdp-agent
34 | :name 'TD :program (make-passive-td-learner))))
35 | ((setq e (make-mdp-environment :mdp *4x3-passive-mdp* :agents (list a)
36 | :epochs-left 2)))
37 | ((run-environment e)) ;;; for now just make sure it runs
38 | ((setq a (make-mdp-agent :name 'MA
39 | :program (make-maximizing-adp-learner '(left right up down)))))
40 | ((setq e (make-mdp-environment :mdp *4x3-mdp* :agents (list a)
41 | :epochs-left 2)))
42 | ((run-environment e)) ;;; for now just make sure it runs
43 | ((setq a (make-mdp-agent :name 'QI
44 | :program (make-maximizing-qi-learner '(left right up down)))))
45 | ((setq e (make-mdp-environment :mdp *4x3-mdp* :agents (list a)
46 | :epochs-left 2)))
47 | ((run-environment e)) ;;; for now just make sure it runs
48 | ((setq a (make-mdp-agent :name 'EA
49 | :program (make-exploring-adp-learner '(left right up down)))))
50 | ((setq e (make-mdp-environment :mdp *4x3-mdp* :agents (list a)
51 | :epochs-left 2)))
52 | ((run-environment e)) ;;; for now just make sure it runs
53 | ((setq a (make-mdp-agent :name 'TQ
54 | :program (make-exploring-tdq-learner '(left right up down)))))
55 | ((setq e (make-mdp-environment :mdp *4x3-mdp* :agents (list a)
56 | :epochs-left 2)))
57 | ((run-environment e)) ;;; for now just make sure it runs
58 |
59 | )
60 |
--------------------------------------------------------------------------------
/learning/agents/active-adp-learner.lisp:
--------------------------------------------------------------------------------
1 | ;;; learning/agents/active-adp-learner.lisp
2 | ;;; Reinforcement learning agent that uses dynamic
3 | ;;; programming to solve the Markov decision process
4 | ;;; that it learns from its experience. Thus, the
5 | ;;; main job is to update the model over time.
6 |
7 | (defun make-random-adp-learner (actions)
8 | (make-active-adp-learner actions #'random-choice))
9 | (defun make-maximizing-adp-learner (actions)
10 | (make-active-adp-learner actions #'max-choice))
11 |
12 | (defun make-active-adp-learner (actions choice-function)
13 | (let* ((percepts nil)
14 | (last-action nil)
15 | (U (make-hash-table :test #'equal))
16 | (N (make-hash-table :test #'equal))
17 | (M (make-hash-table :test #'equal))
18 | (R (make-hash-table :test #'equal))
19 | (mdp (make-mdp :model M :rewards R)))
20 | #'(lambda (e)
21 | (push e percepts)
22 | (let ((s (mdp-percept-state e)))
23 | (unless (gethash s N) ;;; make entries for new state
24 | (setf (gethash s N) 0
25 | (gethash s U) 0
26 | (gethash s M) (mapcar
27 | #'(lambda (a)
28 | (cons a (make-mdp-action-model)))
29 | actions)
30 | (gethash s R) (mdp-percept-reward e)))
31 | (incf (gethash s N))
32 | (update-active-model mdp percepts last-action)
33 | (when (mdp-terminal-states mdp) ;;; make sure DP alg. terminates
34 | (setq U (value-iteration mdp U)))
35 | (when (mdp-percept-terminalp e)
36 | (setq percepts nil))
37 | (setq last-action (funcall choice-function s U M R))))))
38 |
39 | ;;; Update current model to reflect the evidence from the most recent action
40 |
41 | (defun update-active-model (mdp ;;; current description of envt.
42 | percepts ;;; in reverse chronological order
43 | action ;;; last action taken
44 | &aux (M (mdp-model mdp)) transition)
45 | (when (length>1 percepts)
46 | (let* ((e (first percepts)) (j (mdp-percept-state (first percepts)))
47 | (e2 (second percepts)) (i (mdp-percept-state e2))
48 | (action-model (action-model action i M))
49 | (transitions (mdp-action-model-transitions action-model)))
50 | (when (mdp-percept-terminalp e)
51 | (unless (member j (mdp-terminal-states mdp) :test #'equal)
52 | (push j (mdp-terminal-states mdp))))
53 | (incf (mdp-action-model-times-executed action-model))
54 | (unless (setq transition
55 | (find j transitions :test #'equal
56 | :key #'transition-destination))
57 | (push (setq transition (make-transition :destination j))
58 | (mdp-action-model-transitions action-model)))
59 | (incf (transition-times-achieved transition))
60 | (dolist (trans (mdp-action-model-transitions action-model))
61 | (setf (transition-probability trans)
62 | (float (/ (transition-times-achieved trans)
63 | (mdp-action-model-times-executed action-model))))))))
64 |
--------------------------------------------------------------------------------
/learning/algorithms/q-iteration.lisp:
--------------------------------------------------------------------------------
1 | ;;; learning/algorithms/q-iteration.lisp
2 | ;;; Data structures and algorithms for calculating the Q-table for an
3 | ;;; MDP. Q(a,i) is the value of doing action a in state i.
4 |
5 | (defun q-entry (Q a i) (cdr (assoc a (gethash i Q) :test #'eq)))
6 |
7 | (defun all-q-entries (i Q) (mapcar #'cdr (gethash i Q)))
8 |
9 | (defun q-actions (s Q) (mapcar #'car (gethash s Q)))
10 |
11 | ;;; Given an MDP, determine the q-values of the states.
12 | ;;; Q-iteration iterates on the Q-values instead of the U-values.
13 | ;;; Basic equation is Q(a,i) <- R(i) + sum_j M(a,i,j) max_a' Q(a',j)
14 | ;;; where Q(a',j) MUST be the old value not the new.
15 | (defun q-iteration (mdp &optional (Qold nil)
16 | &key (epsilon 0.000001)
17 | &aux Qnew
18 | (max-delta infinity)
19 | (M (mdp-model mdp))
20 | (R (mdp-rewards mdp)))
21 | (unless Qold
22 | (setq Qold (make-hash-table :test #'equal))
23 | (maphash #'(lambda (s r)
24 | (setf (gethash s Qold)
25 | (mapcar #'(lambda (a) (cons a r)) (actions s M))))
26 | R))
27 | (setq Qnew (copy-hash-table Qold #'identity))
28 | (do ()
29 | ((< max-delta epsilon) Qnew)
30 | (setq max-delta 0)
31 | (maphash #'(lambda (s a-qs)
32 | (dolist (a-q a-qs) (setf (cdr a-q)
33 | (q-entry Qnew (car a-q) s))))
34 | Qold)
35 | (maphash
36 | #'(lambda (i a-qs)
37 | (let ((new-a-qs (gethash i Qnew)))
38 | (dolist (a-q a-qs)
39 | (let ((a (car a-q)) (q (cdr a-q)))
40 | (unless (sink? i M)
41 | (setf (cdr (assoc a new-a-qs :test #'eq))
42 | (+ (gethash i R)
43 | (average-successor-q a i Qold M))))
44 | (setq max-delta (max max-delta
45 | (abs (- (q-entry Qnew a i) q))))))))
46 | Qold)))
47 |
48 | (defun average-successor-q (a i Q M &aux (sum 0))
49 | (dolist (transition (transitions a i M) sum)
50 | (let* ((j (transition-destination transition))
51 | (p (transition-probability transition))
52 | (qjs (gethash j Q)))
53 | (incf sum
54 | (if qjs
55 | (* p (cdr (the-biggest #'cdr qjs)))
56 | 0)))))
57 |
58 |
59 |
60 |
61 | ;;; Compute optimal policy from Q table
62 | (defun q-optimal-policy (Q &aux (P (make-hash-table :test #'equal)))
63 | (maphash #'(lambda (s a-qs) (declare (ignore a-qs))
64 | (setf (gethash s P)
65 | (list (list (q-dmax-choice s Q) 1.0))))
66 | Q)
67 | P)
68 |
69 |
70 | ;;; Choice functions select an action under specific circumstances
71 |
72 | ;;; Pick a random action
73 | (defun q-random-choice (s Q)
74 | (random-element (q-actions s Q)))
75 |
76 | ;;; Pick the currently best action
77 | (defun q-dmax-choice (s Q)
78 | (car (the-biggest #'cdr (gethash s Q))))
79 |
80 | ;;; Pick the currently best action with tie-breaking
81 | (defun q-max-choice (s Q)
82 | (car (the-biggest-random-tie #'cdr (gethash s Q))))
83 |
84 |
85 |
--------------------------------------------------------------------------------
/search/algorithms/simple.lisp:
--------------------------------------------------------------------------------
1 | ;; -*- Mode: Lisp -*-
2 |
3 | ;;;; Simple Search Algorithms
4 |
5 | ;;; Here we define the GENERAL-SEARCH function, and then a set of
6 | ;;; search functions that follow specific search strategies. None of
7 | ;;; these algorithms worries about repeated states in the search.
8 |
9 | (defun general-search (problem queuing-fn)
10 | "Expand nodes according to the specification of PROBLEM until we find
11 | a solution or run out of nodes to expand. The QUEUING-FN decides which
12 | nodes to look at first. [p 73]"
13 | (let ((nodes (make-initial-queue problem queuing-fn))
14 | node)
15 | (loop (if (empty-queue? nodes) (RETURN nil))
16 | (setq node (remove-front nodes))
17 | (if (goal-test problem (node-state node)) (RETURN node))
18 | (funcall queuing-fn nodes (expand node problem)))))
19 |
20 | (defun breadth-first-search (problem)
21 | "Search the shallowest nodes in the search tree first. [p 74]"
22 | (general-search problem #'enqueue-at-end))
23 |
24 | (defun depth-first-search (problem)
25 | "Search the deepest nodes in the search tree first. [p 78]"
26 | (general-search problem #'enqueue-at-front))
27 |
28 | (defun iterative-deepening-search (problem)
29 | "Do a series of depth-limited searches, increasing depth each time. [p 79]"
30 | (for depth = 0 to infinity do
31 | (let ((solution (depth-limited-search problem depth)))
32 | (unless (eq solution :cut-off) (RETURN solution)))))
33 |
34 | (defun depth-limited-search (problem &optional (limit infinity)
35 | (node (create-start-node problem)))
36 | "Search depth-first, but only up to LIMIT branches deep in the tree."
37 | (cond ((goal-test problem node) node)
38 | ((>= (node-depth node) limit) :cut-off)
39 | (t (for each n in (expand node problem) do
40 | (let ((solution (depth-limited-search problem limit n)))
41 | (when solution (RETURN solution)))))))
42 |
43 | ;;;; Search Algorithms That Use Heuristic Information
44 |
45 | (defun best-first-search (problem eval-fn)
46 | "Search the nodes with the best evaluation first. [p 93]"
47 | (general-search problem #'(lambda (old-q nodes)
48 | (enqueue-by-priority old-q nodes eval-fn))))
49 |
50 | (defun greedy-search (problem)
51 | "Best-first search using H (heuristic distance to goal). [p 93]"
52 | (best-first-search problem #'node-h-cost))
53 |
54 | (defun tree-a*-search (problem)
55 | "Best-first search using estimated total cost, or (F = G + H). [p 97]"
56 | (best-first-search problem #'node-f-cost))
57 |
58 | (defun uniform-cost-search (problem)
59 | "Best-first search using the node's depth as its cost. Discussion on [p 75]"
60 | (best-first-search problem #'node-depth))
61 |
62 | ;;;; Utility Function
63 |
64 | (defun make-initial-queue (problem queuing-fn)
65 | (let ((q (make-empty-queue)))
66 | (funcall queuing-fn q (list (create-start-node problem)))
67 | q))
68 |
--------------------------------------------------------------------------------
/learning/algorithms/dll.lisp:
--------------------------------------------------------------------------------
1 | ;;; decision list learning algorithm (Rivest)
2 | ;;; returns a decision list, each element of which is
3 | ;;; a test of the form (x .term), where each term is
4 | ;;; of the form ((a1 . v1) (a2 . v2) ... (an . vn)).
5 | ;;; The last element is the test (0).
6 | ;;; only works for purely boolean attributes.
7 |
8 | (defun decision-list-learning (k problem)
9 | (dll k (learning-problem-examples problem)
10 | (learning-problem-attributes problem)
11 | (first (learning-problem-goals problem))))
12 |
13 | (defun dll (k examples attributes goal)
14 | (if (null examples)
15 | (list (list 0))
16 | (multiple-value-bind (test subset)
17 | (select-test k examples attributes goal)
18 | (if test
19 | (cons test
20 | (dll k (set-difference examples subset :test #'eq) attributes goal))
21 | (error "Cannot find a consistent decision list")))))
22 |
23 | ;;; select-test finds a test of size at most k that picks out a set of
24 | ;;; examples with uniform classification. Returns test and subset.
25 |
26 | (defun select-test (k examples attributes goal)
27 | (dotimes (i (1+ k) (values nil nil))
28 | (let ((test (select-k-test i examples attributes goal nil)))
29 | (when test
30 | (return (values test
31 | (remove-if-not #'(lambda (e) (passes e test))
32 | examples)))))))
33 |
34 | (defun select-k-test (k examples attributes goal test-attributes)
35 | (cond ((= 0 k)
36 | (dolist (term (generate-terms test-attributes) nil)
37 | (let ((subset (remove-if-not
38 | #'(lambda (e) (passes e (cons 0 term)))
39 | examples)))
40 | (when (and subset (uniform-classification subset goal))
41 | (return (cons (attribute-value goal (first subset)) term))))))
42 | (t
43 | (dolist (f attributes nil)
44 | (let ((test (select-k-test (- k 1)
45 | examples
46 | (remove f attributes :test #'eq)
47 | goal
48 | (cons f test-attributes))))
49 | (when test (return test)))))))
50 |
51 | (defun generate-terms (attributes) ;;; generate all labellings
52 | (if (null attributes)
53 | (list nil)
54 | (let ((rest (generate-terms (cdr attributes))))
55 | (nconc (mapcar #'(lambda (test)
56 | (cons (cons (car attributes) 0) test))
57 | rest)
58 | (mapcar #'(lambda (test)
59 | (cons (cons (car attributes) 1) test))
60 | rest)))))
61 |
62 | (defun uniform-classification (examples goal)
63 | (every #'(lambda (e) (eq (attribute-value goal e)
64 | (attribute-value goal (first examples))))
65 | (rest examples)))
66 |
67 | (defun passes (example test)
68 | (every #'(lambda (av)
69 | (eq (attribute-value (car av) example) (cdr av)))
70 | (cdr test)))
71 |
72 |
73 | ;;; dlpredict is the standard "performance element" that
74 | ;;; interfaces with the example-generation and learning-curve functions
75 |
76 | (defun dlpredict (dl example)
77 | (if (every #'(lambda (av) (eq (attribute-value (car av) example) (cdr av)))
78 | (cdar dl))
79 | (list (caar dl))
80 | (dlpredict (cdr dl) example)))
81 |
--------------------------------------------------------------------------------
/learning/algorithms/learning-curves.lisp:
--------------------------------------------------------------------------------
1 | ;;; Functions for testing induction algorithms
2 | ;;; Tries to be as generic as possible
3 | ;;; Mainly for NN purposes, allows multiple goal attributes
4 | ;;; A prediction is correct if it agrees on ALL goal attributes
5 |
6 | (defun learning-curve
7 | (induction-algorithm ;;; examples -> hypothesis
8 | performance-element ;;; hypothesis + example -> prediction
9 | examples attributes goals trials training-size-increment
10 | &optional (error-fn #'boolean-error)
11 | &aux training-set test-set (training-set-size 0)
12 | (points (- (floor (length examples) training-size-increment) 1))
13 | (results nil))
14 | (dotimes (i points (reverse results))
15 | (incf training-set-size training-size-increment)
16 | (push (cons training-set-size 0) results)
17 | (dotimes (trial trials)
18 | (setq training-set
19 | (sample-without-replacement training-set-size examples))
20 | (setq test-set (remove-if
21 | #'(lambda (e) (member e training-set :test #'eq))
22 | examples))
23 | (incf (cdar results)
24 | (accuracy
25 | (funcall induction-algorithm training-set attributes goals)
26 | performance-element test-set goals error-fn)))
27 | (setf (cdar results) (/ (cdar results) trials))))
28 |
29 |
30 | ;;; this version uses incremental data sets rather than a new batch each time
31 | (defun incremental-learning-curve
32 | (induction-algorithm ;;; examples -> hypothesis
33 | performance-element ;;; hypothesis + example -> prediction
34 | examples attributes goals trials training-size-increment
35 | &optional (error-fn #'boolean-error)
36 | &aux training-set test-set (training-set-size 0)
37 | (points (- (floor (length examples) training-size-increment) 1))
38 | (results nil))
39 | (dotimes (i points)
40 | (incf training-set-size training-size-increment)
41 | (push (cons training-set-size 0) results))
42 | (dotimes (trial trials)
43 | (setf training-set-size 0)
44 | (setq test-set examples)
45 | (setq training-set nil)
46 | (dotimes (i points)
47 | (incf training-set-size training-size-increment)
48 | (setq training-set
49 | (append (sample-without-replacement
50 | training-size-increment test-set)
51 | training-set))
52 | (setq test-set (remove-if
53 | #'(lambda (e) (member e training-set :test #'eq))
54 | test-set))
55 | (incf (cdr (assoc training-set-size results))
56 | (accuracy
57 | (funcall induction-algorithm training-set attributes goals)
58 | performance-element test-set goals error-fn))))
59 | (dolist (xy results)
60 | (setf (cdr xy) (/ (cdr xy) trials)))
61 | (reverse results))
62 |
63 |
64 | (defun accuracy (h performance-element test-set goals
65 | &optional (error-fn #'boolean-error))
66 | (float (/ (sum test-set
67 | #'(lambda (e)
68 | (- 1 (funcall error-fn
69 | (funcall performance-element h e)
70 | (mapcar #'(lambda (g)
71 | (attribute-value g e))
72 | goals)))))
73 | (length test-set))))
74 |
75 |
--------------------------------------------------------------------------------
/learning/agents/exploring-adp-learner.lisp:
--------------------------------------------------------------------------------
1 | ;;; learning/agents/exploring-adp-learner.lisp
2 | ;;; Reinforcement learning agent that uses dynamic
3 | ;;; programming to solve the Markov decision process
4 | ;;; that it learns from its experience. Thus, the
5 | ;;; main job is to update the model over time.
6 | ;;; Unlike the active-adp-learner, this agent uses
7 | ;;; an "intelligent" exploration policy to make sure it
8 | ;;; explores the state space reasonably quickly.
9 |
10 | (defvar *R+* 2)
11 | (defvar *Ne* 5)
12 |
13 | (defun exploration-function (u n)
14 | (if (< n *Ne*) *R+* u))
15 |
16 | (defun make-exploring-adp-learner (actions)
17 | (let* ((percepts nil)
18 | (last-action nil)
19 | (U (make-hash-table :test #'equal))
20 | (N (make-hash-table :test #'equal))
21 | (M (make-hash-table :test #'equal))
22 | (R (make-hash-table :test #'equal))
23 | (mdp (make-mdp :model M :rewards R)))
24 | #'(lambda (e)
25 | (push e percepts)
26 | (let ((s (mdp-percept-state e)))
27 | (unless (gethash s N) ;;; make entries for new state
28 | (setf (gethash s N) 0
29 | (gethash s U) 0
30 | (gethash s M) (mapcar
31 | #'(lambda (a)
32 | (cons a (make-mdp-action-model)))
33 | actions)
34 | (gethash s R) (mdp-percept-reward e)))
35 | (incf (gethash s N))
36 | (update-active-model mdp percepts last-action)
37 | (when (mdp-terminal-states mdp)
38 | (setq U (exploratory-value-iteration mdp U)))
39 | (when (mdp-percept-terminalp e)
40 | (setq percepts nil))
41 | (setq last-action (exploration-choice s U M R))))))
42 |
43 |
44 | ;;; Given an environment model M, determine the values of states U.
45 | ;;; Use value iteration, with initial values given by U itself.
46 | ;;; Basic equation is U(i) <- r(i) + max_a f(sum_j M(a,i,j)U(j), N(a,i))
47 | ;;; where f is the exploration function. Does not applyt to terminal states.
48 |
49 | (defun exploratory-value-iteration
50 | (mdp &optional (Uold (copy-hash-table (mdp-rewards mdp) #'identity))
51 | &key (epsilon 0.000001)
52 | &aux (Unew (copy-hash-table Uold #'identity))
53 | (max-delta infinity)
54 | (M (mdp-model mdp))
55 | (R (mdp-rewards mdp)))
56 | (do ()
57 | ((< max-delta epsilon) Unew)
58 | (setq max-delta 0)
59 | (rotatef Uold Unew) ;;; switch contents; then we will overwrite Unew
60 | (maphash
61 | #'(lambda (s u)
62 | (unless (sink? s M)
63 | (setf (gethash s Unew)
64 | (+ (gethash s R)
65 | (if (gethash s M)
66 | (apply #'max
67 | (mapcar
68 | #'(lambda (a)
69 | (if (member s (mdp-terminal-states mdp)
70 | :test #'equal)
71 | (gethash s R)
72 | (exploration-function
73 | (q-value a s Uold M R)
74 | (mdp-action-model-times-executed
75 | (action-model a s M)))))
76 | (actions s M)))
77 | 0))))
78 | (setq max-delta (max max-delta (abs (- (gethash s Unew) u)))))
79 | Uold)))
80 |
81 |
82 | (defun exploration-choice (s U M R)
83 | (the-biggest-random-tie
84 | #'(lambda (a)
85 | (exploration-function
86 | (q-value a s U M R)
87 | (mdp-action-model-times-executed (action-model a s M))))
88 | (actions s M)))
89 |
90 |
--------------------------------------------------------------------------------
/uncertainty/domains/4x3-mdp.lisp:
--------------------------------------------------------------------------------
1 | ;;;; Stochastic active 4x3 world for chapters 17, 20.
2 |
3 | ;;; Each action achieves the intended effect with probability 0.8, but the
4 | ;;; rest of the time, the action moves the agent at right angles to the
5 | ;;; intended direction. For example, from the start square (1,1), the
6 | ;;; action North moves the agent to (1,2) with probability 0.8, but with
7 | ;;; probability 0.1, it moves East to (2,1), and with probability 0.1,
8 | ;;; it moves West, bumps into the wall, and stays in (1,1).
9 |
10 | (defparameter *4x3-mdp*
11 | (make-mdp
12 | :initial-state '(1 1)
13 | :terminal-states '((4 2) (4 3))
14 | :name "4x3-mdp"))
15 |
16 | (defparameter *4x3-M-data* '(
17 | ((1 1) (left (((1 1) 0.9) ((1 2) 0.1)))
18 | (right (((2 1) 0.8) ((1 2) 0.1) ((1 1) 0.1)))
19 | (up (((1 2) 0.8) ((2 1) 0.1) ((1 1) 0.1)))
20 | (down (((1 1) 0.9) ((2 1) 0.1))))
21 | ((1 2) (left (((1 2) 0.8) ((1 1) 0.1) ((1 3) 0.1)))
22 | (right (((1 2) 0.8) ((1 1) 0.1) ((1 3) 0.1)))
23 | (up (((1 2) 0.2) ((1 3) 0.8)))
24 | (down (((1 2) 0.2) ((1 1) 0.8))))
25 | ((1 3) (left (((1 3) 0.9) ((1 2) 0.1)))
26 | (right (((1 3) 0.1) ((2 3) 0.8) ((1 2) 0.1)))
27 | (up (((1 3) 0.9) ((2 3) 0.1)))
28 | (down (((1 3) 0.1) ((2 3) 0.1) ((1 2) 0.8))))
29 | ((2 1) (left (((2 1) 0.2) ((1 1) 0.8)))
30 | (right (((2 1) 0.2) ((3 1) 0.8)))
31 | (up (((2 1) 0.8) ((1 1) 0.1) ((3 1) 0.1)))
32 | (down (((2 1) 0.8) ((1 1) 0.1) ((3 1) 0.1))))
33 | ((2 3) (left (((2 3) 0.2) ((1 3) 0.8)))
34 | (right (((2 3) 0.2) ((3 3) 0.8)))
35 | (up (((2 3) 0.8) ((1 3) 0.1) ((3 3) 0.1)))
36 | (down (((2 3) 0.8) ((1 3) 0.1) ((3 3) 0.1))))
37 | ((3 1) (left (((3 1) 0.1) ((3 2) 0.1) ((2 1) 0.8)))
38 | (right (((3 1) 0.1) ((3 2) 0.1) ((4 1) 0.8)))
39 | (up ( ((3 2) 0.8) ((2 1) 0.1) ((4 1) 0.1)))
40 | (down (((3 1) 0.8) ((2 1) 0.1) ((4 1) 0.1))))
41 | ((3 2) (left (((3 2) 0.8) ((3 1) 0.1) ((3 3) 0.1)))
42 | (right (((4 2) 0.8) ((3 1) 0.1) ((3 3) 0.1)))
43 | (up (((3 2) 0.1) ((4 2) 0.1) ((3 3) 0.8)))
44 | (down (((3 2) 0.1) ((4 2) 0.1) ((3 1) 0.8))))
45 | ((3 3) (left (((2 3) 0.8) ((3 3) 0.1) ((3 2) 0.1)))
46 | (right (((3 2) 0.1) ((4 3) 0.8) ((3 3) 0.1)))
47 | (up (((2 3) 0.1) ((4 3) 0.1) ((3 3) 0.8)))
48 | (down (((3 2) 0.8) ((2 3) 0.1) ((4 3) 0.1))))
49 | ((4 1) (left (((4 1) 0.1) ((3 1) 0.8) ((4 2) 0.1)))
50 | (right (((4 1) 0.9) ((4 2) 0.1)))
51 | (up (((4 2) 0.8) ((4 1) 0.1) ((3 2) 0.1)))
52 | (down (((4 1) 0.9) ((3 1) 0.1))))
53 | ((4 2) (left ())
54 | (right ())
55 | (up ())
56 | (down ()))
57 | ((4 3) (left ())
58 | (right ())
59 | (up ())
60 | (down ()))
61 | ))
62 |
63 | (defparameter *4x3-R-data*
64 | '(((1 1) -0.04) ((1 2) -0.04) ((1 3) -0.04)
65 | ((2 1) -0.04) ((2 3) -0.04)
66 | ((3 1) -0.04) ((3 2) -0.04) ((3 3) -0.04)
67 | ((4 1) -0.04) ((4 2) -1) ((4 3) 1)))
68 |
69 |
70 | (dolist (sd *4x3-M-data*)
71 | (setf (gethash (car sd) (mdp-model *4x3-mdp*)) (cdr sd)))
72 | (dolist (sr *4x3-R-data*)
73 | (setf (gethash (car sr) (mdp-rewards *4x3-mdp*)) (second sr)))
74 |
75 |
--------------------------------------------------------------------------------
/search/environments/prob-solve.lisp:
--------------------------------------------------------------------------------
1 | ;;; -*- Mode: Lisp; -*- Author: Peter Norvig
2 |
3 | ;;;; Problem-Solving Environments
4 |
5 | ;;; The basic problem-solving-environment type, and the main generic
6 | ;;; functions for it.
7 |
8 | (defstructure (problem-solving-environment (:include environment))
9 | "An environment in which to solve problems. The state of the environment
10 | is one of the states from the problem, starting with the initial state."
11 | (problem (required)))
12 |
13 | (defmethod get-percept ((env problem-solving-environment) agent)
14 | "All agents can access the complete state of the environment."
15 | (declare-ignore agent)
16 | (environment-state env))
17 |
18 | (defmethod update-fn ((env problem-solving-environment))
19 | "Set the state to the result of executing the agent's action."
20 | (setf (environment-state env)
21 | (cdr (assoc (agent-action (first (environment-agents env)))
22 | (successors (problem-solving-environment-problem env)
23 | (environment-state env))
24 | :test #'equal))))
25 |
26 | (defmethod performance-measure ((env problem-solving-environment) agent)
27 | "Score of 1 for solving problem; 0 otherwise."
28 | (declare (ignore agent))
29 | (if (termination? env) 1 0))
30 |
31 | (defmethod initialize ((env problem-solving-environment))
32 | "Get the initial state from the problem, and supply agents with programs."
33 | (let ((problem (problem-solving-environment-problem env)))
34 | (setf (environment-state env) (problem-initial-state problem))
35 | ;; A problem solving agent needs to know what problem to solve.
36 | ;; We take the problem from the environment and use it to create
37 | ;; a problem-solving agent program for each agent (we only expect one).
38 | (for each agent in (environment-agents env) do
39 | (setf (agent-program agent) (problem-solving-program
40 | (problem-solving-agent-algorithm agent)
41 | problem)))))
42 |
43 | (defun problem-solving-program (search-algorithm problem)
44 | "Given a search algorithm, return a program that at the start searches
45 | for a solution, then executes the steps of the solution, then stops."
46 | (let ((actions :start))
47 | #'(lambda (percept)
48 | (declare (ignore percept)) ;; These agents ignore percepts!
49 | (when (eq actions :start)
50 | (setf actions (solution-actions (funcall search-algorithm problem))))
51 | (if actions (pop actions) :stop))))
52 |
53 | (defmethod termination? ((env problem-solving-environment))
54 | "Stop when the problem is solved, or when an agent says stop."
55 | (or (goal-test (problem-solving-environment-problem env)
56 | (environment-state env))
57 | (find :stop (environment-agents env) :key #'agent-action)))
58 |
59 | ;;;; Converting a Problem to an Environment
60 |
61 | (defun problem->environment (problem &key (algorithm 'A*-search))
62 | "Convert a problem into an environment. Then we can pass the environment
63 | to RUN-ENVIRONMENT, and the agent will search for a solution and execute it."
64 | (make-problem-solving-environment
65 | :agents (list (make-problem-solving-agent :algorithm algorithm))
66 | :problem problem))
67 |
68 | (defmethod print-structure ((env problem-solving-environment) stream)
69 | (format stream "#<~A; State: ~A>" (type-of env) (environment-state env)))
--------------------------------------------------------------------------------
/learning/diff-proof.txt:
--------------------------------------------------------------------------------
1 | (prologx '$x '(differentiate (^ x 2) x $x))
2 | (prologx '$x '(differentiate (^ x 2) x $x))
3 |
4 | Call: (DIFFERENTIATE (^ X 2) X $X)
5 | | Call: (DIFF (^ X 2) X $446)
6 | | | Call: (NUMBERP 2)
7 | | | Exit: (NUMBERP 2)
8 | | | Call: (DIFF X X $447)
9 | | | Exit: (DIFF X X 1)
10 | | Exit: (DIFF (^ X 2) X (* 1 (* 2 (^ X (- 2 1)))))
11 | | Call: (SIMPLIFY (* 1 (* 2 (^ X (- 2 1)))) $X)
12 | | | Call: (REWRITE (* 1 (* 2 (^ X (- 2 1)))) $448)
13 | | | Exit: (REWRITE (* 1 (* 2 (^ X (- 2 1)))) (* 2 (^ X (- 2 1))))
14 | | | Call: (SIMPLIFY (* 2 (^ X (- 2 1))) $X)
15 | | | | Call: (SIMPLIFY 2 2)
16 | | | | | Call: (PRIMITIVE 2)
17 | | | | | | Call: (NUMBERP 2)
18 | | | | | | Exit: (NUMBERP 2)
19 | | | | | Exit: (PRIMITIVE 2)
20 | | | | Exit: (SIMPLIFY 2 2)
21 | | | | Call: (SIMPLIFY (^ X (- 2 1)) $464)
22 | | | | | Call: (SIMPLIFY X X)
23 | | | | | | Call: (PRIMITIVE X)
24 | | | | | | | Call: (VARIABLE X)
25 | | | | | | | Exit: (VARIABLE X)
26 | | | | | | Exit: (PRIMITIVE X)
27 | | | | | Exit: (SIMPLIFY X X)
28 | | | | | Call: (SIMPLIFY (- 2 1) $471)
29 | | | | | | Call: (REWRITE (- 2 1) $472)
30 | | | | | | | Call: (NUMBERP 2)
31 | | | | | | | Exit: (NUMBERP 2)
32 | | | | | | | Call: (NUMBERP 1)
33 | | | | | | | Exit: (NUMBERP 1)
34 | | | | | | | Call: (= $472 (- 2 1))
35 | | | | | | | | Eval: $472
36 | | | | | | | | Exit: $472
37 | | | | | | | | Eval: (- 2 1)
38 | | | | | | | | | Eval: 2
39 | | | | | | | | | Exit: 2
40 | | | | | | | | | Eval: 1
41 | | | | | | | | | Exit: 1
42 | | | | | | | | Exit: 1
43 | | | | | | | Exit: (= 1 (- 2 1))
44 | | | | | | Exit: (REWRITE (- 2 1) 1)
45 | | | | | | Call: (SIMPLIFY 1 $471)
46 | | | | | | | Call: (PRIMITIVE 1)
47 | | | | | | | | Call: (NUMBERP 1)
48 | | | | | | | | Exit: (NUMBERP 1)
49 | | | | | | | Exit: (PRIMITIVE 1)
50 | | | | | | Exit: (SIMPLIFY 1 1)
51 | | | | | Exit: (SIMPLIFY (- 2 1) 1)
52 | | | | | Call: (SIMPLIFY (^ X 1) $464)
53 | | | | | | Call: (REWRITE (^ X 1) $474)
54 | | | | | | Exit: (REWRITE (^ X 1) X)
55 | | | | | | Call: (SIMPLIFY X $464)
56 | | | | | | | Call: (PRIMITIVE X)
57 | | | | | | | | Call: (VARIABLE X)
58 | | | | | | | | Exit: (VARIABLE X)
59 | | | | | | | Exit: (PRIMITIVE X)
60 | | | | | | Exit: (SIMPLIFY X X)
61 | | | | | Exit: (SIMPLIFY (^ X 1) X)
62 | | | | Exit: (SIMPLIFY (^ X (- 2 1)) X)
63 | | | | Call: (SIMPLIFY (* 2 X) $X)
64 | | | | | Call: (SIMPLIFY 2 2)
65 | | | | | | Call: (PRIMITIVE 2)
66 | | | | | | | Call: (NUMBERP 2)
67 | | | | | | | Exit: (NUMBERP 2)
68 | | | | | | Exit: (PRIMITIVE 2)
69 | | | | | Exit: (SIMPLIFY 2 2)
70 | | | | | Call: (SIMPLIFY X X)
71 | | | | | | Call: (PRIMITIVE X)
72 | | | | | | | Call: (VARIABLE X)
73 | | | | | | | Exit: (VARIABLE X)
74 | | | | | | Exit: (PRIMITIVE X)
75 | | | | | Exit: (SIMPLIFY X X)
76 | | | | Exit: (SIMPLIFY (* 2 X) (* 2 X))
77 | | | Exit: (SIMPLIFY (* 2 (^ X (- 2 1))) (* 2 X))
78 | | Exit: (SIMPLIFY (* 1 (* 2 (^ X (- 2 1)))) (* 2 X))
79 | Exit: (DIFFERENTIATE (^ X 2) X (* 2 X))
80 | (* 2 X)
81 |
--------------------------------------------------------------------------------
/uncertainty/environments/mdp.lisp:
--------------------------------------------------------------------------------
1 | ;; -*- Mode: Lisp; Syntax: Common-Lisp; -*-
2 |
3 | ;;;; Definitions for Markov Decision Problems and Reinforcement Learning
4 |
5 | (defstructure (mdp-environment (:include environment))
6 | "An MDP-environment is driven by an MDP (Markov Decision Process),
7 | which (probabilistically) says what state to transition to for each action."
8 | ;;; To make an MDP into an environment, we basically just keep track of the
9 | ;;; current state, and then ask the MDP model to determine the new state.
10 | ;;; This makes sense for the case of a single agent in the environment.
11 | (mdp (make-mdp))
12 | (epochs-left 1))
13 |
14 | (defstruct (mdp-percept (:type list))
15 | "A percept gives the current state, the reward received, and whether it is
16 | a terminal state."
17 | state reward terminalp)
18 |
19 | ;;;; Generic Functions for MDP-Environments
20 |
21 | (defmethod initialize ((env mdp-environment))
22 | ;; Set the initial state, and make sure there is one agent.
23 | (setf (environment-state env) (mdp-initial-state (mdp-environment-mdp env)))
24 | (call-next-method)
25 | (assert (= 1 (length (environment-agents env)))))
26 |
27 | (defmethod get-percept ((env mdp-environment) agent)
28 | "The percept is the current state, the reward, and whether this is terminal."
29 | (declare (ignore agent))
30 | (let* ((mdp (mdp-environment-mdp env))
31 | (state (environment-state env))
32 | (state-key (funcall (mdp-hash-key mdp) state)))
33 | (make-mdp-percept
34 | :state state
35 | :reward (gethash state-key (mdp-rewards mdp))
36 | :terminalp (not (null
37 | (member state (mdp-terminal-states mdp)
38 | :test #'equal))))))
39 |
40 | (defmethod update-fn ((env mdp-environment))
41 | "We update by transitioning to a new state. When we hit a terminal state,
42 | we restart in the initial state (until there are no more epochs left)."
43 | (let ((mdp (mdp-environment-mdp env))
44 | (agent (first (environment-agents env))))
45 | (incf (mdp-agent-total-reward agent)
46 | (mdp-percept-reward (agent-percept agent)))
47 | (cond ((member (environment-state env) (mdp-terminal-states mdp)
48 | :test #'equal)
49 | ;; Start over when we reach a terminal state
50 | (decf (mdp-environment-epochs-left env))
51 | (setf (environment-state env) (mdp-initial-state mdp)))
52 | (t (setf (environment-state env)
53 | (mdp-next-state (agent-action agent)
54 | (environment-state env)
55 | mdp))))))
56 |
57 | (defmethod performance-measure ((env mdp-environment) agent)
58 | "Return a number saying how well this agent is doing."
59 | ;; The default is to subtract one point for each time step.
60 | (mdp-agent-total-reward agent))
61 |
62 | (defmethod termination? ((env mdp-environment))
63 | (= 0 (mdp-environment-epochs-left env)))
64 |
65 | ;;;; Utility Functions
66 |
67 | (defun mdp-next-state (action state mdp)
68 | (let ((state-key (funcall (mdp-hash-key mdp) state)))
69 | (random-transition
70 | (mdp-transitions action (gethash state-key (mdp-model mdp))))))
71 |
72 | (defun mdp-transitions (action state-model)
73 | (mdp-action-model-transitions
74 | (cdr (assoc action state-model :test #'equal))))
75 |
76 | (defun random-transition (transitions &aux (r (random 1.0)))
77 | (dolist (transition transitions)
78 | (decf r (transition-probability transition))
79 | (unless (plusp r) (return (transition-destination transition)))))
80 |
81 |
--------------------------------------------------------------------------------
/learning/domains/restaurant.lisp:
--------------------------------------------------------------------------------
1 | (setq *examples*
2 | '(((willwait . Yes) (alternate . Yes) (bar . No) (fri/sat . No)
3 | (hungry . Yes) (patrons . Some) (price . DDD) (raining . No)
4 | (reservation . Yes) (type . French) (waitestimate . 0) )
5 | ((willwait . No) (alternate . Yes) (bar . No) (fri/sat . No)
6 | (hungry . Yes) (patrons . Full) (price . D) (raining . No)
7 | (reservation . No) (type . Thai) (waitestimate . 30) )
8 | ((willwait . Yes) (alternate . No) (bar . Yes) (fri/sat . No)
9 | (hungry . No) (patrons . Some) (price . D) (raining . No)
10 | (reservation . No) (type . Burger) (waitestimate . 0) )
11 | ((willwait . Yes) (alternate . Yes) (bar . No) (fri/sat . Yes)
12 | (hungry . Yes) (patrons . Full) (price . D) (raining . No)
13 | (reservation . No) (type . Thai) (waitestimate . 10) )
14 | ((willwait . No) (alternate . Yes) (bar . No) (fri/sat . Yes)
15 | (hungry . No) (patrons . Full) (price . DDD) (raining . No)
16 | (reservation . Yes) (type . French) (waitestimate . 60) )
17 | ((willwait . Yes) (alternate . No) (bar . Yes) (fri/sat . No)
18 | (hungry . Yes) (patrons . Some) (price . DD) (raining . Yes)
19 | (reservation . Yes) (type . Italian) (waitestimate . 0) )
20 | ((willwait . No) (alternate . No) (bar . Yes) (fri/sat . No)
21 | (hungry . No) (patrons . None) (price . D) (raining . Yes)
22 | (reservation . No) (type . Burger) (waitestimate . 0) )
23 | ((willwait . Yes) (alternate . No) (bar . No) (fri/sat . No)
24 | (hungry . Yes) (patrons . Some) (price . DD) (raining . Yes)
25 | (reservation . Yes) (type . Thai) (waitestimate . 0) )
26 | ((willwait . No) (alternate . No) (bar . Yes) (fri/sat . Yes)
27 | (hungry . No) (patrons . Full) (price . D) (raining . Yes)
28 | (reservation . No) (type . Burger) (waitestimate . 60) )
29 | ((willwait . No) (alternate . Yes) (bar . Yes) (fri/sat . Yes)
30 | (hungry . Yes) (patrons . Full) (price . DDD) (raining . No)
31 | (reservation . Yes) (type . Italian) (waitestimate . 10) )
32 | ((willwait . No) (alternate . No) (bar . No) (fri/sat . No)
33 | (hungry . No) (patrons . None) (price . D) (raining . No)
34 | (reservation . No) (type . Thai) (waitestimate . 0) )
35 | ((willwait . Yes) (alternate . Yes) (bar . Yes) (fri/sat . Yes)
36 | (hungry . Yes) (patrons . Full) (price . D) (raining . No)
37 | (reservation . No) (type . Burger) (waitestimate . 30) )))
38 |
39 | (setq *attributes*
40 | '((alternate yes no)
41 | (bar yes no)
42 | (fri/sat yes no)
43 | (hungry yes no)
44 | (patrons None Some Full)
45 | (price D DD DDD)
46 | (raining yes no)
47 | (reservation yes no)
48 | (type French Italian Thai Burger)
49 | (waitestimate 0 10 30 60)))
50 |
51 | (setq *goal* '(willwait yes no))
52 |
53 | (defvar *target*)
54 |
55 | (setq *target*
56 | '((patrons none some full)
57 | (none . no)
58 | (some . yes)
59 | (full
60 | (waitestimate 60 30 10 0)
61 | (60 . no)
62 | (30
63 | (alternate yes no)
64 | (yes
65 | (fri/sat yes no)
66 | (no . no)
67 | (yes . yes))
68 | (no
69 | (reservation yes no)
70 | (no
71 | (bar yes no)
72 | (no . no)
73 | (yes . yes))
74 | (yes . yes)))
75 | (10
76 | (hungry yes no)
77 | (no . yes)
78 | (yes
79 | (alternate yes no)
80 | (no . yes)
81 | (yes
82 | (raining yes no)
83 | (no . no)
84 | (yes . yes))))
85 | (0 . yes))))
86 |
87 |
--------------------------------------------------------------------------------
/search/domains/ttt.lisp:
--------------------------------------------------------------------------------
1 | ;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- File: search/domains/ttt.lisp
2 |
3 | ;;;; The Game of Tic-Tac-Toe
4 |
5 | ;;; Generalized Tic-Tac-Toe, in which any number of players take turns
6 | ;;; placing marks on an NxN board, trying to get K marks in a row. There
7 | ;;; are much more efficient representations than what we have chosen here,
8 | ;;; but this suffices to run an environment quickly. If an agent wants to
9 | ;;; search a large number of possible game states, then the agent should use
10 | ;;; its own efficient representation. After all, an agent's internal
11 | ;;; representation is independent of what's "actually" out there in the
12 | ;;; environment.
13 |
14 | (defstructure (ttt-game (:include game) (:constructor create-ttt-game))
15 | "Define an NxN tic-tac-toe game in which the object is to get K in a row."
16 | n k)
17 |
18 | (defun make-ttt-game (&key (n 3) (k n) (players '(X O)))
19 | "Define an NxN tic-tac-toe game in which the object is to get K in a row."
20 | (create-ttt-game
21 | :n n :k k
22 | :initial-state (make-game-state
23 | :board (make-array (list n n) :initial-element '-)
24 | :players players)))
25 |
26 | (defmethod legal-moves ((game ttt-game) state)
27 | "List all possible legal moves."
28 | (let* ((board (game-state-board state))
29 | (dims (array-dimensions board)))
30 | ;; Iterate over all squares; make moves in empty ones.
31 | (let ((moves nil))
32 | (dotimes (x (xy-x dims))
33 | (dotimes (y (xy-y dims))
34 | (when (eq (aref board x y) '-)
35 | (push (@ x y) moves))))
36 | moves)))
37 |
38 | (defmethod make-move ((game ttt-game) state move)
39 | "Return the new state that results from making this move."
40 | (make-game-state
41 | :board (let ((new-board (copy-array (game-state-board state))))
42 | (setf (aref new-board (xy-x move) (xy-y move))
43 | (current-player state))
44 | new-board)
45 | :players (left-rotate (game-state-players state))
46 | :scores (copy-list (game-state-scores state))
47 | :previous-move move))
48 |
49 | (defmethod game-over? ((game ttt-game) state)
50 | "Checks if the last player to move made a complete row,
51 | column, or diagonal of length k, or if the board is full.
52 | If so, assign scores and return true; otherwise return nil."
53 | (let* ((n (ttt-game-n game))
54 | (k (ttt-game-k game))
55 | (board (game-state-board state))
56 | (players (game-state-players state))
57 | (x (first (game-state-previous-move state)))
58 | (y (second (game-state-previous-move state)))
59 | (previous (previous-player state)))
60 | (cond ((and x y
61 | (or (check-k-in-a-row board x y n k +1 0 previous)
62 | (check-k-in-a-row board x y n k 0 +1 previous)
63 | (check-k-in-a-row board x y n k -1 +1 previous)
64 | (check-k-in-a-row board x y n k +1 +1 previous)))
65 | (for each player in players do
66 | (setf (getf (game-state-scores state) player)
67 | (if (eq player previous) +1 -1)))
68 | 'win)
69 | ((not (find '- (array->vector board)))
70 | 'draw)
71 | (t nil))))
72 |
73 | ;;;; Auxiliary Functions
74 |
75 | (defun check-k-in-a-row (board x y n k dx dy player)
76 | "Does player have k in a row, through (x y) in direction (+/-dx +/-dy)?"
77 | (>= (+ (count-pieces-in-direction board x y n (- dx) (- dy) player)
78 | (count-pieces-in-direction board x y n dx dy player)
79 | -1) ; because the piece at (x y) gets counted twice
80 | k))
81 |
82 | (defun count-pieces-in-direction (board x y n dx dy player)
83 | "Count player's pieces starting at (x y) going in direction (dx dy)."
84 | (if (and (< -1 x n) (< -1 y n) (eq (aref board x y) player))
85 | (+ 1 (count-pieces-in-direction board (+ x dx) (+ y dy)
86 | n dx dy player))
87 | 0))
88 |
--------------------------------------------------------------------------------
/language/test-language.lisp:
--------------------------------------------------------------------------------
1 |
2 | (deftest language
3 | "Test the chart parser on some grammars."
4 | "First the simple E0 grammar from page 665."
5 | ((chart-parses '(I smell a stench) *E0*)
6 | '((S (NP (PRONOUN I))
7 | (VP (VP (VERB SMELL)) (NP (ARTICLE A) (NOUN STENCH))))))
8 | ((chart-parses '(the gold is in 2 2) *E0*)
9 | '((S (NP (ARTICLE THE) (NOUN GOLD))
10 | (VP (VP (VERB IS)) (PP (PREPOSITION IN) (NP (DIGIT 2) (DIGIT 2)))))))
11 | "Now the E1 grammar to show how pronoun case is handled."
12 | "It is grammatical to use 'I' as a subject, but not 'me'."
13 | ((chart-parses '(I shot the wumpus) *E1*)
14 | (renaming? * '((S ((NP SUBJECTIVE) ((PRONOUN SUBJECTIVE) I))
15 | (VP (VERB SHOT)
16 | ((NP $CASE.10) (ARTICLE THE) (NOUN WUMPUS)))))))
17 | ((chart-parses '(Me shot the wumpus) *E1*)
18 | 'NIL)
19 | "The E0 grammar allows anything (including 'me') as a subject:"
20 | ((chart-parses '(Me shot the wumpus) *E0*)
21 | '((S (NP (PRONOUN ME))
22 | (VP (VP (VERB SHOT)) (NP (ARTICLE THE) (NOUN WUMPUS))))))
23 | "Now for a longer sentence"
24 | ((chart-parses '(I see the wumpus in 2 3 and it is smelly ) *e1*)
25 | (renaming?
26 | *
27 | '((S (S ((NP SUBJECTIVE) ((PRONOUN SUBJECTIVE) I))
28 | (VP (VERB SEE)
29 | ((NP $CASE.218) ((NP $CASE.220) (ARTICLE THE) (NOUN WUMPUS))
30 | (PP (PREPOSITION IN) ((NP $CASE.225) (DIGIT 2) (DIGIT 3))))))
31 | (CONJUNCTION AND)
32 | (S ((NP $CASE.234) ((PRONOUN $CASE) IT))
33 | (VP (VERB IS) (ADJECTIVE SMELLY)))))))
34 | "An example from the simple arithmetic grammar."
35 | ((chart-parses '([ 1 + 2 ] * 3 0) *arithmetic-grammar*)
36 | '(((EXP (* (+ 1 2) (+ (* 10 3) 0)))
37 | ((EXP (+ 1 2))
38 | ([ [)
39 | ((EXP (+ 1 2))
40 | ((EXP 1) ((NUMBER 1) ((DIGIT 1) 1)))
41 | ((OPERATOR +) +)
42 | ((EXP 2) ((NUMBER 2) ((DIGIT 2) 2))))
43 | (] ]))
44 | ((OPERATOR *) *)
45 | ((EXP (+ (* 10 3) 0))
46 | ((NUMBER (+ (* 10 3) 0)) ((NUMBER 3) ((DIGIT 3) 3)) ((DIGIT 0) 0))))))
47 | "The function MEANINGS picks out just the semantics"
48 | ((meanings '([ 1 + 2 ] * 3 0) *arithmetic-grammar*)
49 | '((* (+ 1 2) (+ (* 10 3) 0))))
50 | "Note that strings can be ambiguous, yielding two or more parses."
51 | ((meanings '(1 + 2 * 3) *arithmetic-grammar*)
52 | '((* (+ 1 2) 3) (+ 1 (* 2 3))))
53 | ((chart-parses '(1 + 2 * 3) *arithmetic-grammar*)
54 | '(((EXP (* (+ 1 2) 3))
55 | ((EXP (+ 1 2)) ((EXP 1) ((NUMBER 1) ((DIGIT 1) 1)))
56 | ((OPERATOR +) +) ((EXP 2) ((NUMBER 2) ((DIGIT 2) 2))))
57 | ((OPERATOR *) *) ((EXP 3) ((NUMBER 3) ((DIGIT 3) 3))))
58 | ((EXP (+ 1 (* 2 3)))
59 | ((EXP 1) ((NUMBER 1) ((DIGIT 1) 1)))
60 | ((OPERATOR +) +)
61 | ((EXP (* 2 3)) ((EXP 2) ((NUMBER 2) ((DIGIT 2) 2))) ((OPERATOR *) *)
62 | ((EXP 3) ((NUMBER 3) ((DIGIT 3) 3)))))))
63 | ((chart-parses '(i shot the wumpus that stinks) *e2*)
64 | (renaming?
65 | *
66 | '(((S ((SHOT (THE $X.648 (AND (WUMPUS $X.648) (STINKS $X.648)))) I))
67 | ((NP I) ((PRONOUN I) I))
68 | ((VP (SHOT (THE $X.648 (AND (WUMPUS $X.648) (STINKS $X.648)))))
69 | ((VP SHOT) ((VERB SHOT) SHOT))
70 | ((NP (THE $X.648 (AND (WUMPUS $X.648) (STINKS $X.648))))
71 | ((NP (THE $X.655 (WUMPUS $X.655))) ((ARTICLE THE) THE)
72 | ((NOUN WUMPUS) WUMPUS))
73 | ((RELCLAUSE STINKS) (THAT THAT)
74 | ((VP STINKS) ((VERB STINKS) STINKS)))))))))
75 | ((meanings '(i shoot the wumpus that stinks and i grab the gold) *e2*)
76 | (renaming?
77 | *
78 | '((AND ((SHOOT (THE $X.746 (AND (WUMPUS $X.746) (STINKS $X.746)))) I)
79 | ((GRAB (THE $X.851 (GOLD $X.851))) I)))))
80 |
81 | )
--------------------------------------------------------------------------------
/search/algorithms/repeated.lisp:
--------------------------------------------------------------------------------
1 | ;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- File: search/algorithms/repeated
2 |
3 | ;;;; Search Algorithms That Avoid Repeated States
4 |
5 | ;;; In this file we show algorithms that worry about repeated states.
6 | ;;; Here are the three ways to deal with repeated states, from [p 82]:
7 |
8 | (defun eliminate-returns (nodes)
9 | "Get rid of nodes that return to the state they just came from,
10 | i.e., where the last two actions just undo each other."
11 | (remove-if #'return-node? nodes))
12 |
13 | (defun eliminate-cycles (nodes)
14 | "Get rid of nodes that end in a state that has appeared before in the path."
15 | (remove-if #'looping-node? nodes))
16 |
17 | (defun eliminate-all-duplicates (nodes node-table)
18 | "Get rid of all nodes that have been seen before in any path."
19 | (let ((result nil))
20 | (for each node in nodes do
21 | (let ((state (node-state node)))
22 | (when (not (gethash state node-table))
23 | (push node result))
24 | (setf (gethash state node-table) node)))
25 | result))
26 |
27 | ;;; Here are examples of search algorithms that use these methods. In
28 | ;;; retrospect, a better organization would have been to have GENERAL-SEARCH
29 | ;;; take two arguments, a problem and a strategy, where the strategy would
30 | ;;; have a queueing function and an expansion function as components. That
31 | ;;; way, we wouldn't have EXPAND generate nodes that we are just going to
32 | ;;; throw away anyway.
33 |
34 | (defun no-cycles-depth-first-search (problem)
35 | "Do depth-first search, but eliminate paths with repeated states."
36 | (general-search problem
37 | #'(lambda (old-q nodes)
38 | (enqueue-at-front old-q (eliminate-cycles nodes)))))
39 |
40 | (defun no-returns-breadth-first-search (problem)
41 | "Do breadth-first search, but eliminate immediate returns to a prior state."
42 | (general-search problem
43 | #'(lambda (old-q nodes)
44 | (enqueue-at-end old-q (eliminate-returns nodes)))))
45 |
46 | (defun no-duplicates-breadth-first-search (problem)
47 | "Do breadth-first search, but eliminate all duplicate states."
48 | (let ((table (make-hash-table :test #'equal)))
49 | (general-search problem
50 | #'(lambda (old-q nodes)
51 | (enqueue-at-end old-q (eliminate-all-duplicates
52 | nodes table))))))
53 |
54 | (defun A*-search (problem)
55 | "Search the nodes with the best f cost first. If a node is ever reached by
56 | two different paths, keep only the better path."
57 | (general-search problem (make-eliminating-queuing-fn #'node-f-cost)))
58 |
59 | (defun make-eliminating-queuing-fn (eval-fn)
60 | (let ((table (make-hash-table :test #'equal)))
61 | #'(lambda (old-q nodes)
62 | (enqueue-by-priority
63 | old-q
64 | (let ((result nil))
65 | (for each node in nodes do
66 | (let ((old-node (gethash (node-state node) table)))
67 | (cond
68 | ((null old-node)
69 | ;; First time we've reached state; just return node
70 | (setf (gethash (node-state node) table) node)
71 | (push node result))
72 | ((<= (funcall eval-fn old-node) (funcall eval-fn node))
73 | ;; If the old node is better, discard the new node
74 | nil)
75 | (t;; Otherwise, discard the old node
76 | (setf (node-expanded? old-node) t)
77 | (setf (gethash (node-state node) table) node)
78 | (push node result)))))
79 | (nreverse result))
80 | eval-fn))))
81 |
82 |
83 | ;;;; Auxiliary Functions
84 |
85 | (defun looping-node? (node &optional (depth infinity))
86 | "Did this node's state appear previously in the path?"
87 | ;; Search up to DEPTH nodes deep in the path
88 | (let ((n (node-parent node)))
89 | (for i = 1 to depth do
90 | (when (null n) (return nil))
91 | (when (equal (node-state node) (node-state n)) (return t))
92 | (setf n (node-parent n)))))
93 |
94 | (defun return-node? (node)
95 | "Is this a node that returns to the state it just came from?"
96 | (looping-node? node 2))
97 |
--------------------------------------------------------------------------------
/search/test-search.lisp:
--------------------------------------------------------------------------------
1 | ;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- File: search/test.lisp
2 |
3 | ;;;; Test Cases for Search
4 |
5 | (deftest search
6 | "Test the code for Solving Problems by Searching"
7 | "Start with a trivial version of the missionaries and cannibals puzzle."
8 | ((setq p1 (make-cannibal-problem
9 | :initial-state (make-cannibal-state :m1 2 :c1 1))))
10 | "We search for a solution node:"
11 | ((setq result (breadth-first-search p1)) *)
12 | "We can get information out of that solution:"
13 | ((solution-actions result) *)
14 | ((solution-nodes result) *)
15 | "Or we can use SOLVE to print the results nicely. By default, SOLVE
16 | uses A*-search, but you can give it another algorithm as the second arg."
17 | ((solve p1) *)
18 | "For the full 3 missionary and 3 cannibal problem, breadth-first-search"
19 | "is very inefficient. Better to use something that handles repeated states,"
20 | "like A*-search or no-duplicates-breadth-first-search:"
21 | ((solve (make-cannibal-problem) 'A*-search) *)
22 | ((solve (make-cannibal-problem) 'no-duplicates-breadth-first-search) *)
23 |
24 | "Here is how to get a problem-solving agent to find the solution,"
25 | "and then go ahead and execute the actions that comprise the solution."
26 | ((run-environment (problem->environment p1)))
27 |
28 | "Now we look at the route-finding domain."
29 | "First, solve the Arad-to-Bucharest problem with A*-search:"
30 | ((solve (make-romanian-problem :initial-state 'Arad :goal 'Bucharest)) *)
31 | "Now turn it around:"
32 | ((solve (make-romanian-problem :goal 'Arad :initial-state 'Bucharest)) *)
33 | "Let's just see the actions:"
34 | ((solution-actions (A*-search (make-romanian-problem)))
35 | '(Sibiu Rimnicu Pitesti Bucharest))
36 | "Now on a random map:"
37 | ((solve (make-route-finding-problem)))
38 |
39 | "Here's how to compare several algorithms."
40 | ((setq searchers '(A*-search no-cycles-depth-first-search
41 | no-duplicates-breadth-first-search)))
42 | ((compare-search-algorithms #'make-route-finding-problem searchers))
43 | ((compare-search-algorithms #'make-romanian-problem searchers :n 1))
44 | ((compare-search-algorithms #'make-cannibal-problem
45 | '(no-returns-breadth-first-search A*-search
46 | no-duplicates-breadth-first-search)
47 | :n 1))
48 | ((compare-search-algorithms #'make-romanian-problem
49 | '(tree-A*-search A*-search tree-IDA*-search)
50 | :n 1))
51 | "We'll look at the iterative improvement algorithms on a harder map problem."
52 | ((setq searchers '(A*-search hill-climbing-search
53 | simulated-annealing-search)))
54 | ((compare-search-algorithms #'(lambda () (make-romanian-problem :goal 'Iasi))
55 | searchers :n 1))
56 | "Let's take a look at the 8-puzzle:"
57 | ((solve (make-8-puzzle-problem)) *)
58 | ((compare-search-algorithms 'make-8-puzzle-problem '(A*-search) :n 2))
59 | "And the path-planning problem among polygonal obstacles:"
60 | ((solve (make-path-planning-problem :scene *scene-4.17*)))
61 | "Now the 8-queens problem"
62 | ((solve (make-nqueens-problem) 'csp-backtracking-search) *)
63 | ((compare-search-algorithms
64 | 'make-nqueens-problem
65 | '(csp-backtracking-search csp-forward-checking-search)
66 | :n 1))
67 | "Here is the Travelling Salesperson Problem (TSP)."
68 | ((solve (make-tsp-problem)))
69 | ((compare-search-algorithms 'make-tsp-problem
70 | '(A*-search greedy-search uniform-cost-search)
71 | :n 5))
72 | "Now we test the environments for 2-player and 3-player games:"
73 | ((run-game (make-ttt-game)))
74 | ((run-game (make-cognac-game :players '(X O @))))
75 | "Now we see that 2x2 tic-tac-toe is a win for the first player, X."
76 | ((run-game (make-ttt-game :n 2)
77 | :agents '(alpha-beta-ttt-agent alpha-beta-ttt-agent)))
78 | "In a full 3x3 game, alpha-beta search (playing O) often wins."
79 | ((run-game (make-ttt-game) :agents '(random-game-agent alpha-beta-ttt-agent)))
80 | )
81 |
82 |
83 |
--------------------------------------------------------------------------------
/learning/domains/restaurant-boolean.lisp:
--------------------------------------------------------------------------------
1 | ;;; learning/domains/restaurant-boolean.lisp
2 | ;;; Restaurant learning problem encoded using boolean attributes only,
3 | ;;; as appropriate for decision-list learning.
4 | ;;; Target is encoded as a decision list.
5 |
6 | (defvar *restaurant-boolean*
7 | '( (0 ((patrons 1 0) . 0))
8 | (1 ((full 1 0) . 0))
9 | (0 ((>30 1 0) . 1))
10 | (1 ((wait 1 0) . 0))
11 | (1 ((>10 1 0) . 0) ((hungry 1 0) . 0))
12 | (1 ((>10 1 0) . 0) ((hungry 1 0) . 1) ((alternate 1 0) . 0))
13 | (0 ((>10 1 0) . 0) ((hungry 1 0) . 1) ((alternate 1 0) . 1) ((raining 1 0) . 0))
14 | (1 ((>10 1 0) . 0) ((hungry 1 0) . 1) ((alternate 1 0) . 1) ((raining 1 0) . 1))
15 | (0 ((>10 1 0) . 1) ((alternate 1 0) . 1) ((fri/sat 1 0) . 0))
16 | (1 ((>10 1 0) . 1) ((alternate 1 0) . 1) ((fri/sat 1 0) . 1))
17 | (0 ((>10 1 0) . 1) ((alternate 1 0) . 0) ((reservation 1 0) . 0) ((bar 1 0) . 0))
18 | (1 ((>10 1 0) . 1) ((alternate 1 0) . 0) ((reservation 1 0) . 0) ((bar 1 0) . 1))
19 | (1)))
20 |
21 |
22 |
23 | (defvar *restaurant-boolean-problem*)
24 |
25 | (setq *restaurant-boolean-problem*
26 | (make-learning-problem
27 | :attributes '((alternate 1 0)
28 | (bar 1 0)
29 | (fri/sat 1 0)
30 | (hungry 1 0)
31 | (patrons 1 0) ;; none some full 0 0.5 1
32 | (full 1 0)
33 | (cheap 1 0)
34 | (expensive 1 0)
35 | (raining 1 0)
36 | (reservation 1 0)
37 | (french 1 0)
38 | (italian 1 0)
39 | (thai 1 0)
40 | (burger 1 0)
41 | (wait 1 0)
42 | (>10 1 0)
43 | (>30 1 0))
44 | :goals '((willwait 1 0))
45 | :examples '(((willwait . 1) (alternate . 1) (bar . 0) (fri/sat . 0)
46 | (hungry . 1) (patrons . 0.5) (price . 1) (raining . 0)
47 | (reservation . 1) (type . 1) (waitestimate . 0) )
48 | ((willwait . 0) (alternate . 1) (bar . 0) (fri/sat . 0)
49 | (hungry . 1) (patrons . 1) (price . 0) (raining . 0)
50 | (reservation . 0) (type . 0.33) (waitestimate . 0.5) )
51 | ((willwait . 1) (alternate . 0) (bar . 1) (fri/sat . 0)
52 | (hungry . 0) (patrons . 0.5) (price . 0) (raining . 0)
53 | (reservation . 0) (type . 0) (waitestimate . 0) )
54 | ((willwait . 1) (alternate . 1) (bar . 0) (fri/sat . 1)
55 | (hungry . 1) (patrons . 1) (price . 0) (raining . 0)
56 | (reservation . 0) (type . 0.33) (waitestimate . 0.17) )
57 | ((willwait . 0) (alternate . 1) (bar . 0) (fri/sat . 1)
58 | (hungry . 0) (patrons . 1) (price . 1) (raining . 0)
59 | (reservation . 1) (type . 1) (waitestimate . 1) )
60 | ((willwait . 1) (alternate . 0) (bar . 1) (fri/sat . 0)
61 | (hungry . 1) (patrons . 0.5) (price . 0.5) (raining . 1)
62 | (reservation . 1) (type . 0.67) (waitestimate . 0) )
63 | ((willwait . 0) (alternate . 0) (bar . 1) (fri/sat . 0)
64 | (hungry . 0) (patrons . 0) (price . 0) (raining . 1)
65 | (reservation . 0) (type . 0) (waitestimate . 0) )
66 | ((willwait . 1) (alternate . 0) (bar . 0) (fri/sat . 0)
67 | (hungry . 1) (patrons . 0.5) (price . 0.5) (raining . 1)
68 | (reservation . 1) (type . 0.33) (waitestimate . 0) )
69 | ((willwait . 0) (alternate . 0) (bar . 1) (fri/sat . 1)
70 | (hungry . 0) (patrons . 1) (price . 0) (raining . 1)
71 | (reservation . 0) (type . 0) (waitestimate . 1) )
72 | ((willwait . 0) (alternate . 1) (bar . 1) (fri/sat . 1)
73 | (hungry . 1) (patrons . 1) (price . 1) (raining . 0)
74 | (reservation . 1) (type . 0.67) (waitestimate . 0.17) )
75 | ((willwait . 0) (alternate . 0) (bar . 0) (fri/sat . 0)
76 | (hungry . 0) (patrons . 0) (price . 0) (raining . 0)
77 | (reservation . 0) (type . 0.33) (waitestimate . 0) )
78 | ((willwait . 1) (alternate . 1) (bar . 1) (fri/sat . 1)
79 | (hungry . 1) (patrons . 1) (price . 0) (raining . 0)
80 | (reservation . 0) (type . 0) (waitestimate . 0.5) )
81 | )))
82 |
83 |
--------------------------------------------------------------------------------
/doc/old-install.html:
--------------------------------------------------------------------------------
1 | Downloading and Installing Lisp Code for AIMA
2 |
3 |
4 | Downloading and Installing Lisp Code for AIMA
5 |
6 | This page gives instructions for retrieving the code for the book, and
7 | installing it on your local system. This installation procedure need
8 | only be followed once. If you are using the book in a course, your
9 | instructor (or an assistant) will probably do this for you, and you
10 | can move on to using the code.
11 |
12 | Downloading the Code
13 |
14 | The Lisp source code (and documentation) that accompanies the book is packaged
15 | up in the file code.tar.Z in the directory /ucb/people/russell/aima on the machine ftp.cs.berkeley.edu. To download the code, you have four choices:
17 |
18 | - Select code.tar.Z from your Web browser.
19 |
- Use ftp directly. On a UNIX
20 | system, a typical ftp session looks like this:
21 |
22 |
23 | Computer prompts: You type:
24 | ================ ========
25 | % cd where-you-want-the-code-to-be
26 | % ftp ftp.cs.berkeley.edu
27 | Name: anonymous
28 | Password: your-login-name@your.mail.address
29 | ftp> cd ucb/people/russell/aima
30 | 250 CWD command successful.
31 | ftp> binary
32 | 200 Type set to I.
33 | ftp> get code.tar.Z
34 | 150 Opening ASCII connection
35 | 226 Transfer complete.
36 | ftp> quit
37 | 221 Goodbye.
38 | % zcat code.tar.Z | tar xvf -
39 | % rm code.tar.Z
40 |
41 | - If you don't have the zcat (or uncompress) and tar programs, or another
42 | suitable unpacking utility, you can get the files one at a time from the ftp site, or by using a web browser to the code directory.
43 |
44 |
- If you don't have access to ftp, but do have an email account, you can
45 | retrieve the files by sending a message to ftpmail@decwrl.dec.com with
46 | the following body (or send a message with the body help to see all
47 | your options):
48 |
49 |
50 | connect ftp.cs.berkeley.edu
51 | binary
52 | uuencode
53 | get README
54 | get code.tar.Z
55 | quit
56 |
57 |
58 |
59 | Installing the Code
60 |
61 |
62 | - Make sure you have both read-permission and write-permission for
63 | the directory where the code is kept.
64 |
65 |
- Edit the file "aima.lisp" and change the value of the parameter
66 | *aima-root* to reflect the location of the files. Make sure to use the
67 | proper syntax for a directory, not a regular file. For example, on a Unix
68 | file system, you want something like "/usr/local/aima/", where the final "/"
69 | indicates that /usr/local/aima is a directory.
70 |
71 |
- Depending on your version of Lisp, you may need to edit the parameter
72 | *aima-binary-type* to indicate the type of files created by your Lisp
73 | compiler. If the compiler creates files of the form "name.bin", then set
74 | this parameter to "bin". Do include the double-quote marks.
75 |
76 |
- Start up your Common Lisp, and enter the following two forms:
77 |
78 | (load "aima.lisp")
79 | (aima-compile)
80 |
81 |
82 | - Most versions of Lisp provide a way to dump out an image -- an
83 | executable file that contains all the code that has been loaded so far. If
84 | your Lisp has this feature, it might be a good idea to create such an image
85 | at this point, and save it for later use.
86 |
87 |
Then exit from Lisp (and if you like, you can remove write-permission from
88 | this directory and its sub-directories).
89 |
90 |
91 |
92 |
93 |