;;;; -*- Mode: Lisp; Syntax: Common-Lisp -*- ;;;; Code from Paradigms of AI Programming ;;;; Copyright (c) 1991 Peter Norvig ;;;; updated for SBCL 2007 by tim@menzies.us #+SBCL (DECLAIM (SB-EXT:MUFFLE-CONDITIONS CL:STYLE-WARNING)) ;w x t (defmacro o (x) "print a named value; e.g. (let ((a 22)) (o a)) ==> [a]=[22]" `(progn (format t "[~a]=[~a] " (quote ,x) ,x) ,x)) (defmacro oo (&rest l) "print a list of names values; e.g. (let ((aa 22) (b 33)) (oo a b)) ==> [a]=22;[b]=[33]" `(progn ,@(mapcar #'(lambda(x) `(o ,x)) l) (terpri))) ;;;;;;;;; (defconstant fail nil) ;;;; search.lisp: Search routines from section 6.4 (defun tree-search (states goal-p successors combiner) "Find a state that satisfies goal-p. Start with states, and search according to successors and combiner." (dbg :search "~&;; Search: ~a" states) (cond ((null states) fail) ((funcall goal-p (first states)) (first states)) (t (tree-search (funcall combiner (funcall successors (first states) ) (rest states)) goal-p successors combiner)))) (defun depth-first-search (start goal-p successors) "Search new states first until goal is reached." (tree-search (list start) goal-p successors #'append)) (defun binary-tree (x) (list (* 2 x) (+ 1 (* 2 x)))) (defun is (value) #'(lambda (x) (eql x value))) (defun prepend (x y) "Prepend y to start of x" (append y x)) (defun breadth-first-search (start goal-p successors) "Search old states first until goal is reached." (tree-search (list start) goal-p successors #'prepend)) (defun finite-binary-tree (n) "Return a successor function that generates a binary tree with n nodes." #'(lambda (x) (remove-if #'(lambda (child) (> child n)) (binary-tree x)))) (defun diff (num) "Return the function that finds the difference from num." #'(lambda (x) (abs (- x num)))) (defun sorter (cost-fn) "Return a combiner function that sorts according to cost-fn." #'(lambda (new old) (sort (append new old) #'< :key cost-fn))) (defun best-first-search (start goal-p successors cost-fn) "Search lowest cost states first until goal is reached." (tree-search (list start) goal-p successors (sorter cost-fn))) (defun price-is-right (price) "Return a function that measures the difference from price, but gives a big penalty for going over price." #'(lambda (x) (if (> x price) most-positive-fixnum (- price x)))) (defun beam-search (start goal-p successors cost-fn beam-width) "Search highest scoring states first until goal is reached, but never consider more than beam-width states at a time." (tree-search (list start) goal-p successors #'(lambda (old new) (let ((sorted (funcall (sorter cost-fn) old new))) (if (> beam-width (length sorted)) sorted (subseq sorted 0 beam-width)))))) (defstruct (city (:type list)) name long lat) (defparameter *cities* '((Atlanta 84.23 33.45) (Los-Angeles 118.15 34.03) (Boston 71.05 42.21) (Memphis 90.03 35.09) (Chicago 87.37 41.50) (New-York 73.58 40.47) (Denver 105.00 39.45) (Oklahoma-City 97.28 35.26) (Eugene 123.05 44.03) (Pittsburgh 79.57 40.27) (Flagstaff 111.41 35.13) (Quebec 71.11 46.49) (Grand-Jct 108.37 39.05) (Reno 119.49 39.30) (Houston 105.00 34.00) (San-Francisco 122.26 37.47) (Indianapolis 86.10 39.46) (Tampa 82.27 27.57) (Jacksonville 81.40 30.22) (Victoria 123.21 48.25) (Kansas-City 94.35 39.06) (Wilmington 77.57 34.14))) (setf (symbol-function 'find-all-if) #'remove-if-not) (defun neighbors (city) "Find all cities within 1000 kilometers." (find-all-if #'(lambda (c) (and (not (eq c city)) (< (air-distance c city) 1000.0))) *cities*)) (defconstant earth-diameter 12765.0 "Diameter of planet earth in kilometers.") (defun air-distance (city1 city2) "The great circle distance between two cities." (let ((d (distance (xyz-coords city1) (xyz-coords city2)))) ;; d is the straight-line chord between the two cities, ;; The length of the subtending arc is given by: (* earth-diameter (asin (/ d 2))))) (defun xyz-coords (city) "Returns the x,y,z coordinates of a point on a sphere. The center is (0 0 0) and the north pole is (0 0 1)." (let ((psi (deg->radians (city-lat city))) (phi (deg->radians (city-long city)))) (list (* (cos psi) (cos phi)) (* (cos psi) (sin phi)) (sin psi)))) (defun distance (point1 point2) "The Euclidean distance between two points. The points are coordinates in n-dimensional space." (sqrt (reduce #'+ (mapcar #'(lambda (a b) (expt (- a b) 2)) point1 point2)))) (defun deg->radians (deg) "Convert degrees and minutes to radians." (* (+ (truncate deg) (* (rem deg 1) 100/60)) pi 1/180)) (defun city (name) "Find the city with this name." (assoc name *cities*)) (defun trip (start dest) "Search for a way from the start to dest." (beam-search start (is dest) #'neighbors #'(lambda (c) (air-distance c dest)) 1)) ;;; debugging trvial (defvar *dbg-ids* nil "Identifiers used by dbg") (defun dbg (id format-string &rest args) "Print debugging info if (DEBUG ID) has been specified." (when (member id *dbg-ids*) (fresh-line *debug-io*) ;(read-line ) (apply #'format *debug-io* format-string args))) ;; changed from norvig: "debug" is some reserved symbol in SBCL. ;; we use "dabug (defun dabug (&rest ids) "Start dbg output on the given ids." (setf *dbg-ids* (union ids *dbg-ids*))) (defun undabug (&rest ids) "Stop dbg on the ids. With no ids, stop dbg altogether." (setf *dbg-ids* (if (null ids) nil (set-difference *dbg-ids* ids)))) (defun shuffle (l) (let ((n (length l))) (loop for i below n do (rotatef (elt l i) (elt l (random n))))) l) (defstruct graph "a graph is a list of nodes and edges" nodes edges) (defstruct node "nodes have a name and a position" name at) (defstruct point "a point has an x,y position" x y) #| 1 2 3 4 5 6 7 8 9 10 11 12 1 a - b - c - d - e - f | 2 g - h - i k l | | | 3 m - n - o - p - q - r - s - t | 4 u - v - w | 5 x - y - z |# (defun graph2 () (graph '((d 1 4 e) (e 1 5 f g) (f 1 6) (g 2 5 h) (h 2 6)))) (defun graph1 () (graph '((a 1 1 b) (b 1 2 c) (c 1 3 d) (d 1 4 e) (e 1 5 f g) (f 1 6 ) (g 2 5 h) (h 2 6 i n) (i 2 7) (j 2 8 ) (k 2 10 r) (l 2 11 s) (m 3 5 n) (n 3 6 o) (o 3 7 p) (p 3 8 q) (q 3 9 r) (r 3 10 s) (s 3 11 t) (t 3 12 w) (u 4 10 y) (v 4 11 w) (w 4 12 ) (x 5 9 y) (y 5 10 z) (z 5 11 )))) (defun graph (l &optional (g (make-graph))) "Add the nodes of 'l' into the graph 'g'" (dolist (x l g) (node x g))) (defun node (x g) "Localize all our knowledge of how to pull apart our node-specs." (node-edges g :name (first x) :xpos (second x) :ypos (third x) :neighbors (cdddr x))) (defun node-edges (g &key name xpos ypos neighbors) "Add 'nodes' and 'edges' to 'g'." (defnode name xpos ypos g) (dolist (neighbor neighbors) (defedge name neighbor g) (defedge neighbor name g) )) (defun defnode (name xpos ypos g) "Push a new node onto the graph 'g'." (push (make-node :name name :at (make-point :x xpos :y ypos)) (graph-nodes g))) (defun defedge (from to g) "Push a new edge onto the graph 'g'." (push (cons from to) (graph-edges g))) (defun xy-distance (name1 name2 g) "Retuen the straight line distance from name1 to name2 in 'g'" (point-distance (node-at (find-node name1 g)) (node-at (find-node name2 g)))) (defun point-distance (p1 p2) "Return the straight line distance from 'p1' to 'p2'" (euclidian (point-x p1) (point-y p1) (point-x p2) (point-y p2))) (defun euclidian (x1 y1 x2 y2) "Return the euclidian distance from x1@y1 to x2@y2" (sqrt (+ (expt (- x1 x2) 2) (expt (- y1 y2) 2)))) (defun find-node (x g) "Find the node names 'x' in 'g'" (find-if #'(lambda (y) (eql x y)) (graph-nodes g) :key #'node-name)) (defun next2 (x g visited) "Find the node names that are next to x in 'g'" (push x visited) (let (out) (dolist (y (graph-edges g) (shuffle out)) (if (eql x (car y)) (dolist (item (cdr y)) (if (not (member item visited)) (push item out))))))) (defun graph-successors (g visited) #'(lambda (x) (next2 x g visited))) (defun path (start stop g) (let (visited) (beam-search start (is stop) (graph-successors g visited) #'(lambda (x) (xy-distance x stop g)) 10)))