home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / xl21hos2.zip / SEARCH.LSP < prev    next >
Lisp/Scheme  |  1995-12-27  |  5KB  |  178 lines
  1. ; Winston & Horn (3rd Edition) Chapter 19 
  2.  
  3.  
  4. ; First set up the network
  5.  
  6. (setf    (get 's 'neighbors) '(a d)
  7.     (get 'a 'neighbors) '(s b d)
  8.     (get 'b 'neighbors) '(a c e)
  9.     (get 'c 'neighbors) '(b)
  10.     (get 'd 'neighbors) '(s a e)
  11.     (get 'e 'neighbors) '(b d f)
  12.     (get 'f 'neighbors) '(e))
  13.  
  14. (setf    (get 's 'coordinates) '(0 3)
  15.     (get 'a 'coordinates) '(4 6)
  16.     (get 'b 'coordinates) '(7 6)
  17.     (get 'c 'coordinates) '(11 6)
  18.     (get 'd 'coordinates) '(3 0)
  19.     (get 'e 'coordinates) '(6 0)
  20.     (get 'f 'coordinates) '(11 3))
  21.  
  22.  
  23. ; The extend function is used everywhere to provide a new queue
  24.  
  25. (defun extend (path)
  26.     (print (reverse path))        ; for observing what is happening
  27.     (mapcar #'(lambda (new-node) (cons new-node path))
  28.             (remove-if #'(lambda (neighbor) (member neighbor path))
  29.                (get (first path) 'neighbors))))
  30.  
  31. ; depth first search
  32.  
  33. (defun depth-first (start finish &optional (queue (list (list start))))
  34.     (cond    ((endp queue) nil)        ; Queue empty?
  35.         ((eq finish (first (first queue))) ; finish found?
  36.          (reverse (first queue)))
  37.         (t (depth-first
  38.             start
  39.             finish
  40.             (append (extend (first queue))
  41.                     (rest queue))))))
  42.  
  43. ; breadth first search
  44.  
  45. (defun breadth-first (start finish &optional (queue (list (list start))))
  46.     (cond    ((endp queue) nil)        ; Queue empty?
  47.         ((eq finish (first (first queue))) ; finish found?
  48.          (reverse (first queue)))
  49.         (t (breadth-first
  50.             start
  51.             finish
  52.             (append (rest queue)
  53.                     (extend (first queue)))))))
  54.  
  55. ; best first search
  56.  
  57. (defun best-first (start finish &optional (queue (list (list start))))
  58.     (cond    ((endp queue) nil)        ; Queue empty?
  59.         ((eq finish (first (first queue))) ; finish found?
  60.          (reverse (first queue)))
  61.         (t (best-first
  62.             start
  63.             finish
  64.             (sort (append (extend (first queue))
  65.                           (rest queue))
  66.               #'(lambda (p1 p2) (closerp p1 p2 finish)))))))
  67.  
  68.  
  69.  
  70. (defun square (x) (* x x))
  71.  
  72. (defun straight-line-distance (node-1 node-2)
  73.     (let ((coord-1 (get node-1 'coordinates))
  74.           (coord-2 (get node-2 'coordinates)))
  75.          (sqrt (float (+ (square (- (first coord-1) (first coord-2)))
  76.                       (square (- (second coord-1) (second coord-2))))))))
  77.  
  78. (defun closerp (path-1 path-2 target-node)
  79.     (< (straight-line-distance (first path-1) target-node)
  80.        (straight-line-distance (first path-2) target-node)))
  81.  
  82.  
  83.  
  84. ; hill climb search
  85.  
  86. (defun hill-climb (start finish &optional (queue (list (list start))))
  87.     (cond    ((endp queue) nil)        ; Queue empty?
  88.         ((eq finish (first (first queue))) ; finish found?
  89.          (reverse (first queue)))
  90.         (t (hill-climb 
  91.             start
  92.             finish
  93.             (append (sort (extend (first queue))
  94.                     #'(lambda (p1 p2) 
  95.                            (closerp p1 p2 finish)))
  96.                 (rest queue))))))
  97.  
  98.  
  99.  
  100. ; branch and bound search (shortest length guarenteed)
  101.  
  102. (defun branch-and-bound (start finish &optional (queue (list (list start))))
  103.     (cond    ((endp queue) nil)        ; Queue empty?
  104.         ((eq finish (first (first queue))) ; finish found?
  105.          (reverse (first queue)))
  106.         (t (branch-and-bound
  107.             start
  108.             finish
  109.             (sort (append (extend (first queue))
  110.                           (rest queue))
  111.               #'shorterp)))))
  112.  
  113. (defun shorterp (path-1 path-2)
  114.     (< (path-length path-1) (path-length path-2)))
  115.  
  116. (defun path-length (path)
  117.     (if    (endp (rest path))
  118.         0
  119.         (+ (straight-line-distance (first path) (second path))
  120.            (path-length (rest path)))))
  121.  
  122.  
  123.  
  124. ; pert chart searching (problem 19-7)
  125.  
  126. (setf    (get 's 'successors) '(a d)
  127.     (get 'a 'successors) '(b d)
  128.     (get 'b 'successors) '(c e)
  129.     (get 'c 'successors) '()
  130.     (get 'd 'successors) '(e)
  131.     (get 'e 'successors) '(f)
  132.     (get 'f 'successors) '())
  133.  
  134. (setf    (get 's 'time-consumed) 3
  135.     (get 'a 'time-consumed) 2
  136.     (get 'b 'time-consumed) 4
  137.     (get 'c 'time-consumed) 3
  138.     (get 'd 'time-consumed) 3
  139.     (get 'e 'time-consumed) 2
  140.     (get 'f 'time-consumed) 1)
  141.  
  142. (defun pextend (path)
  143.     (mapcar #'(lambda (new-node) (cons new-node path))
  144.             (remove-if #'(lambda (successor) (member successor path))
  145.                (get (first path) 'successors))))
  146.  
  147. (defun all-paths (start &optional (queue (list (list start))))
  148.     (let ((extended (pextend (first queue))))
  149.          (cond ((endp extended)
  150.                 (mapcar #'reverse queue))
  151.            (t (all-paths
  152.                 start
  153.             (sort (append extended (rest queue))
  154.               #'first-path-incomplete-p))))))
  155.  
  156. (defun first-path-incomplete-p (p1 p2)
  157.     (not (endp (pextend p1))))
  158.  
  159.  
  160. ; Pert chart searching (problem 19-8)
  161.  
  162. (defun time-consumed (path)
  163.     (if (endp path)
  164.         0
  165.         (+ (get (first path) 'time-consumed)
  166.            (time-consumed (rest path)))))
  167.  
  168. (defun longerp (p1 p2) (> (time-consumed p1) (time-consumed p2)))
  169.  
  170. (defun critical-path (start &optional (queue (list (list start))))
  171.     (let ((extended (pextend (first queue))))
  172.          (cond ((endp extended)
  173.                 (reverse (first (sort queue #'longerp))))
  174.            (t (critical-path
  175.                 start
  176.             (sort (append extended (rest queue))
  177.               #'first-path-incomplete-p))))))
  178.