xlisponly/lsp/search.lsp

   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))))))