;Michael Chungkun Chen

;SEAS ID: mchen

;CS 161

;Project 3

 

;*****************************************************************************

;Part 1 ********** Best-First-Search *****************************************

(defun Best-First-Search (tree cost)

;This is the wrapper function

  (cond

    ((atom tree) nil)

    ((atom cost) nil)

    (t (BFS cost (list (list 0 tree))))

  )

)

;===================

(defun BFS (cost queue)

;This function looks at the queue and expands the first node and sorts

    (cond

      ;End case empty queue

      ((null queue) nil)

      ;Else, attach whatever we take out of queue with the evaluation of new queue

      (t (cons (car (cadar queue))

              (BFS cost (sort  ;Sorts

                       (append (BFSexpand cost (car queue))  ;Expanding node and inserting

                              (cdr queue))

                       #'sorthelp))))

    )

)

;===================

(defun BFSexpand (cost node)

;This function expands the nodes in the queues into a number/subtree list.

  (let (;Finds the furrent cost to node

       (curcost (car node))

       ;Finds the subtree of this node

       (subt    (cadr node))

       )

    (cond

      ((null subt) nil)            ;Terminating case, nil subtree

      ((null (cadr subt)) nil)     ;Terminating case, subtree contains nil

      ((atom (cadr (cadr subt)))   ;This is where the child has no children

          (cons (list (+ curcost   ;Make a list of...

                      (findcost cost (list (car subt) (caadr subt))))

                    (list (caadr subt) nil)) ;cost-subtree list of the first child

              (BFSexpand cost    ;And the expansion of the rest of the siblings

                        (list curcost

                             (list (car subt)

                                   (cdadr subt)))))) ;Skip one

      ;This case the children has children

      (t (cons (list (+ (findcost cost (list (car subt) (caadr subt)))

                     curcost) ;Return the child and cost as a list of list

                   (list (car (cadr subt)) (cadr (cadr subt))))

              (BFSexpand cost   ;Append the expansion of the other siblings.

                       (list curcost

                            (list (car subt)

                                  (cddr (cadr subt))))))) ;Skip two

    )

  )

)

;===================

(defun findcost (cost nodes)

;This function finds the cost of an edge by going through the cost list

  (cond

    ((null cost) 'Cost-not-Found)

    ((null nodes) 'Error)

    ((equal (butlast (car cost)) nodes) (car (last (car cost))))

    (t (findcost (cdr cost) nodes))

  )

)

;===================

(defun sorthelp (item1 item2)

;This item helps sort the priority queue

  (cond

    ((or (atom item1) (atom item2)) 'ERROR-NON-LIST)

    ((< (car item1) (car item2)) t)

    (t nil)

  )

)

 

;********************************* End part 1 ********************************

;Part 2 ********* A-Star Search **********************************************

(defun A-Star (tree cost heuristic)

;Wrapper function to run the A-Star heuristic search on the tree

  (cond

    ((null tree) 'EMPTY-TREE)

    ((null cost) 'EMPTY-COST)

    ((null heuristic) 'EMPTY-HEURISTIC)

    (t (A-StarH cost heuristic (list (list 0 tree))))

  )

)

;===================

(defun A-StarH (cost heuristic pqueue)

;A-Star Helper function which enqueues each node and sorts and performs more on it.

  (cond

   ((null pqueue) nil)  ;Null queue, done

   ((atom pqueue) 'ERROR) ;Queue is atom, error.

   (t (cons (car (cadar pqueue)) ;Return list with current node,

           (A-StarH cost heuristic

                   (sort (append (A-StarCon cost heuristic (car pqueue))

                               (cdr pqueue)) ;appeneded with the expansion of current node

                        #'sorthelp2)  ;Sorted by sorthelp2

           );End A-Star-H calling function

   ));End t case

  );End cond

);End defun

;===================

(defun A-StarCon (cost heur node)

  (let (;Find out the current cost of node

       (curcost (car node))

       ;Find out the subtree of node

       (subt    (cadr node))

       )

    (cond

      ((null subt) nil) ;tree has nil subtree

      ((null (cadr subt)) nil) ;End of subtree

      ((atom (cadr (cadr subt)))   ;This is where the child has no children

          ;Create a list of...

          (cons (list (+ curcost ;list of the current cost summed with

                              ;the cost and heuristic of subtree

                      (findf cost heur (list (car subt) (caadr subt))))

                    (list (caadr subt) nil)) ;'(node ())

 

              ;Attach to the result of calling A-Starcon on the next part inside the subtree

              (A-StarCon cost heur

                        (list curcost

                             (list (car subt)

                                   (cdadr subt)))))) ;Skip one

                ;Not the immediate child, but the next child in the subtree

      ;This child has children

      (t (cons (list (+ (findf cost heur (list (car subt) (caadr subt)))

        ;Create list of...

                     curcost)

 

                   ;The f-cost And the subtree of the child

                   (list (car (cadr subt)) (cadr (cadr subt))))

              ;And the result from expanding the rest of the siblings

              (A-StarCon cost heur

                       (list curcost

                            (list (car subt)

                                  (cddr (cadr subt))))))) ;Skip two

    )

  )

)

;===================

(defun findf (cost heur nodes)

  ;This function finds the mini f value, cost from parent to child + heuristic of child.

  (cond

    ((null cost) 'Cost-not-Found)

    ((null heur) 'Heuristics-not-Found)

    ((null nodes) 'Error)

 

    ;Found our cost, and our heuristic

    ((and (equal (butlast (car cost)) nodes)

         (equal (caar heur) (cadr nodes)))

     ;Return value of the sums

     (+ (car (last (car cost))) (car (last (car heur)))))

 

    ;Finding our heuristic, already found our cost

    ((equal (butlast (car cost)) nodes) (findf cost (cdr heur) nodes))

 

    ;Finding our cost for now, no heuristics

    (t (findf (cdr cost) heur nodes))

  )

)

;===================

(defun sorthelp2 (item1 item2)

;Helper function to sort my list of number first lists.

 

  (cond

    ((or (atom item1) (atom item2)) 'ERROR-NON-LIST)

    ((< (car item1) (car item2)) t)

    (t nil)

  )

)

 

;********************************* End part 2 ****************************

;Part 3 ********* idA-Star Search ****************************************

(defun IDA-Star (tree cost heuristic)

;driving function (wrapper)

  (cond

    ((null tree) 'EMPTY-TREE)

    ((null cost) 'EMPTY-COST)

    ((null heuristic) 'EMPTY-HEURISTIC)

    ;Passes in the flist from the calcf function.

    (t (IDA-StarH (cons (list (findh heuristic (car tree))

                           (car tree)) ;Insert root node

                     (calcf tree cost heuristic 0))

                tree 0)) ;pass in the tree and a starting depth of 0

  )

)

;===================

(defun IDA-StarH (flist tree depth)

;Helper function for IDA-Star handles incremental depth

  (cond

   ((= (maxf flist) depth) (IDA-StarD flist tree depth))

   ;reached the maximum depth limit, stop recursing

 

   (t (append (IDA-StarD flist tree depth)

             ;output a fcost bounded depth first search on tree

             (IDA-StarH flist tree (nextdepth flist tree depth))

             ;and append with the rest of the IDA* results

   ))

  )

)

;===================

(defun IDA-StarD (flist tree depth)

;This function actually does the depth first, fcost bounded search

  (cond

      ((null tree) nil) ;Tree empty, done

 

      ;We have a list in front, subtree part from calling function

      ((listp (car tree)) (append (IDA-StarD flist (car tree) depth)

                              (IDA-StarD flist (cdr tree) depth)))

 

      ;Our f value for the current node is less than depth, process subtree

      ((<= (findidaf flist (car tree)) depth) (cons (car tree)

                                              (IDA-StarD flist (cdr tree) depth)))

     

      ;Our f value must have been bigger, so if the node has a subtree skip it

      ((listp (cadr tree)) (IDA-StarD flist (cddr tree) depth))

      ;Otherwise process the rest of the list for rest of the nodes on this level

      (t (IDA-StarD flist (cdr tree) depth))

  )

)

;===================

(defun nextdepth (flist tree depth)

;This function determines the next depth level

  (cond

   ((null tree) (maxf flist)) ;End of tree, return max

   ((atom tree) if (findidaf flist tree)) ;we have an atom

 

   ;List, so we are probably processing children that had parents lessthan or equal to depth

   ((listp (car tree)) (min (nextdepth flist (car tree) depth)

                         (nextdepth flist (cdr tree) depth)))

   ((and (atom (car tree))    ;Suppose we the first element is an atom

        (<= (findidaf flist (car tree)) depth)  ;who's f value is less than or equal to depth

        (listp (cadr tree))) ;and has a child

             ;So we would find the minimum f-value from the children,

             (min (nextdepth flist (cadr tree) depth)

            ;And from the other siblings

                (nextdepth flist (cddr tree) depth)))

             ;In other words, skip the children

 

   ;case that current node is greater than depth and has children

   ((and (> (findidaf flist (car tree)) depth)

        (listp (cdr tree))) ;detect children 

    ;Result is the minimum of...

    (min (findidaf flist (car tree))           ;this node's value (skip children)

        (nextdepth flist (cddr tree) depth))) ;and the value of the other siblings

   ;Otherwise we just skip the current node and go on to the cdr

   (t (nextdepth flist (cdr tree) depth))

  )

)

;===================

(defun calcf (tree cost heur curc)

;This function calculates each F(n)=g(n)+h(n) for the nodes and returns

;those values and nodes in a list of pairs

  (cond

   ((null tree) nil)         ;Empty tree -> done

   ((null (cadr tree)) nil)  ;2nd node is nil -> done

   ((listp (cadr (cadr tree))) ;Child of node has children

      (let (;Find the cost to get to the child

           (nextcost (+ (findc cost (list (car tree) (caadr tree)))

                      curc))

           ;Find heuristic of the child

           (heurs (findh heur (caadr tree)))

           ;Find the subtree of the child

           (subt (list (caadr tree) (cadr (cadr tree))))

           ;Find the next child of current tree

           (nexttr (list (car tree) (cddr (cadr tree))))

          )

       ;Return f-cost of child and child node appended with...

       (append (list (list (+ heurs nextcost) (caadr tree)))

              ;The list of f-costs from the other childs of this node

              (calcf nexttr cost heur curc)

              ;And the list of f-costs from the children of this child

              (calcf subt cost heur nextcost))

      );End let

   ) ;End (listp (cadr (cadr tree)))

 

   ;This case the child doesn't have children

   (t (let (;Find the next child of current tree

           (nexttr (list (car tree) (cdr (cadr tree))))

           ;Find out cost to reach child

           (nextcost (+ (findc cost (list (car tree) (caadr tree)))

                      curc))

           ;Find out heuristic of child

           (heurs (findh heur (caadr tree)))

          )

       ;Append the f-cost of the child and child node to...

       (append (list (list (+ heurs nextcost) (caadr tree)))

              ;The list of f-costs from the other children of this node.

              (calcf nexttr cost heur curc))

      );End let

   );End t

  );End cond

);End defun

;===================

;The rest of these functions are simple ones

(defun findidaf (flist node)

;Finds the f value of node, by searching the flist,

;and returns the numeric value

  (cond

    ((null flist) nil)

    ((equal (cadar flist) node) (caar flist))

    (t (findidaf (cdr flist) node))

  )

)

 

(defun findc (cost nodes)

;Finds the cost to move from the two nodes specified in nodes

;Done by going through the cost list and finding an edge match

  (cond

    ((null cost) 'Cost-not-Found)

    ((null nodes) 'Error)

    ((equal (butlast (car cost)) nodes)

     (car (last (car cost))))

    (t (findc (cdr cost) nodes))

  )

)

 

(defun findh (heur node)

;Finds the heuristic cost of each node, done by traversing

;down the heuristic list, to find the node, and then returning the value

  (cond

   ((null node) 'Invalid-node)

   ((null heur) 'No-Heuristics)

   ((equal (caar heur) node) (cadar heur))

   (t (findh (cdr heur) node))

  )

)

 

(defun maxf (flist)

;Finds the maximum f value from flist

  (cond

   ((null flist) 0)

   (t (max (caar flist) (maxf (cdr flist))))

  )

)

;********************************* End part 3 ***************************

Script started on Sat Nov 09 23:20:09 2001

[36l>[root@forbidden cs161]# gcl

GCL (GNU Common Lisp)  Version(2.3) Thu Sep 27 23:26:44 PDT 2001

Licensed under GNU Library General Public License

Contains Enhancements by W. Schelter

 

>(load "b project3.lsp")

 

Loading project3.lsp

Finished loading project3.lsp

T

 

>'BEST-FIRST-SERAC   ACH  r                P (print 'BEST-FIRST  -SEARCH-TESTING**************************)

 

BEST-FIRST-SEARCH-TESTING**************************

BEST-FIRST-SEARCH-TESTING**************************

 

>(Best-First-Search '(A (B (E) C (G))) '((A B 30) (A C 10) (B E 50) (C G 15)))

 

(A C G B E)

 

>(Best-First-Search '(a (b (d e) c (f g (h)))) '( (a b 23) (a c 28) (b d 21) (b e 34) (c f 9) (c g 1) (g h 2)))

 

(A B C G H F D E)

 

>(Best-First-Search '(A (B (E F (H)) C D (G))) '((A B 1) (A C 4) (A D 1) (B E 2) (B F 3) (F H 8) (D G 9)))

 

(A B D E F C G H)

 

>(Best-First-Search '(a (b c d e f g)) '((a b 11) (a c 12) (a d 15) (a e 7) (a f 9) (a g 10)))

 

(A E F G B C D)

 

>(Best-First-Search '(be (*fi (*wo (s!)) st* (rs (t*) *se (ar)) ch (rk))) '((be *fi 2) (be st* 1) (be ch 21) (*fi *wo 22) (st* rs 3) (st* *se 9) (ch rk 5) (*wo s! 5) (rs t* 4) (*se ar 10)))

 

(BE ST* *FI RS T* *SE AR CH *WO RK S!)

 

>(print 'A-STAR-SEARCH-TEST**********************************)

 

A-STAR-SEARCH-TEST**********************************

A-STAR-SEARCH-TEST**********************************

 

>(A-Star '(a (b c d e f g)) '((a b 11) (a c 12) (a d 15) (a e 7) (a f 9) (a g 10)) '((a 3) (b 5) (c 4) (d 8) (e 9) (f 3) (g 6)))

 

(A F B C E G D)

 

>(A-Star  '(a (b (d e) c (f g (h)))) '( (a b 23) (a c 28) (b d 21) (b e 34) (c f 9) (c g 1) (g h 2)) '((a 20) (b 15) (c 10) (d 17) (e 32) (f 11) (g 6) (h 1)))

 

(A B C G H F D E)

 

>(A-Star '(A (B (E) C (G))) '((A B 30) (A C 10) (B E 50) (C G 15)) '((A 7) (B 6) (C 1) (E 1) (G 4)))

 

(A C G B E)

 

>(A-Star '(A (B (E F (H)) C D (G))) '((A B 1) (A C 4) (A D 1) (B E 2) (B F 3) (F H 8) (D G 9)) '((A 3) (B 2) (C 1 ) (D 4) (E 1) (F 2) (G 2) (H 1)))

 

(A B C D E F G H)

 

>(A-Star '(th (*wo (s! (!!) rk) is* (*a- (st ar*) *se (ar ch*)))) '((th *wo 19) (th is* 7) (*wo s! 9) (*wo rk 12) (is* *a- 1) (is* *se 3) (s! !! 8) (*a- st 1) (*a- ar* 2) (*se ar 3) (*se ch* 1)) '((th 5) (*wo 20) (is* 8) (s! 17) (rk 5) (*a- 4) (*se 7) (!! 3) (st 2) (ar* 3) (ar 3) (ch* 6)))

 

(TH IS* *A- ST AR* *SE AR CH* *WO RK S! !!)

 

>(print " 'IDA-D STAR-SEARCH-TESTING****************************************)

 

IDA-STAR-SEARCH-TESTING****************************************

IDA-STAR-SEARCH-TESTING****************************************

 

>(IDA-Star '(a (b c d e f g)) '((a b 11) (a c 12) (a d 15) (a e 7) (a f 9) (a g 10)) '((a 3) (b 5) (c 4) (d 8) (e 9) (f 3) (g 6)))

 

(A A F A B C E F G A B C D E F G)

 

>

(IDA-Star  '(a (b (d e) c (f g (h)))) '( (a b 23) (a c 28) (b d 21) (b e 34) (c f 9) (c g 1) (g h 2)) '((a 20) (b 15) (c 10) (d 17) (e 32) (f 11) (g 6) (h 1)))

 

(A A B C G H A B C F G H A B D C F G H A B D E C F G H)

 

>(IDA-Star '(A (B (E) C (G))) '((A B 30) (A C 10) (B E 50) (C G 15)) '((A 7) (B 6) (C 1) (E 1) (G 4)))

 

(A A C A C G A B C G A B E C G)

 

>(IDA-Star '(A (B (E F (H)) C D (G))) '((A B 1) (A C 4) (A D 1) (B E 2) (B F 3) (F H 8) (D G 9)) '((A 3) (B 2) (C 1 ) (D 4) (E 1) (F 2) (G 2) (H 1)))

 

(A B A B E A B E C D A B E F C D A B E F C D G A B E F H C D G)

 

>(IDA-Star '(*id (a* (*st (ar *s) ea (rc)) h* (*wo (rk) s! (!!)))) '((*id a* 3) (*id h* 10) (a* *st 4) (a* ea 12) (h* *wo 15) (h* s! 10) (*st ar 2) (*st *s 13) (ea rc 5) (*wo rk 2) (s! !! 5)) '((*id 5) (a* 2) (h* 15) (*st 3) (ea 10) (*wo 5) (s! 10) (ar 1) (*s 5) (rc 5) (rk 3) (!! 10)))

 

(*ID A* *ID A* *ST AR *ID A* *ST AR *S EA RC H* *ID A* *ST AR *S EA RC

     H* *WO RK S! *ID A* *ST AR *S EA RC H* *WO RK S! !!)

 

>(bye)

[root@forbidden cs161]#

Script done on Sat Nov 09 23:25:31 2001