;;;; Rebecca Orton
;;;; Project 1
;;;; Fall 2000 Artificial Intelligence Class
;;;; Professor Marcus Maloof
;;;; Some functions are not available in my Xlisp environment.
;;;; Therefore, I needed to program them myself.
;;; A tree used to test functions
(setq G (list 'G '() '() '() '()))
(setq E (list 'E G '() '(G) '()))
(setq D (list 'D E '() '(E) '()))
(setq F (list 'F E '() '(E) '()))
(setq C (list 'C D F '(D) '(F)))
(setq B (list 'B C D '(C) '(D)))
(setq A (list 'A B C '(B) '(C)))
A
B
C
D
E
F
G
(defun first (a-list)
(cond ((null a-list) nil)
((not (listp a-list)) nil)
(t (car a-list))))
(first A)
(first B)
(first C)
(first D)
(first E)
(first F)
(first G)
(first 'A)
(first ())
(defun rest (a-list)
(cond ((null a-list) nil)
((atom a-list) nil)
(t(cdr a-list))))
(rest A)
(rest B)
(rest C)
(rest D)
(rest E)
(rest F)
(rest G)
(rest 'A)
(rest ())
(defun second (a-list)
(cond ((null a-list) nil)
((not (listp a-list)) nil)
(t (car (cdr a-list)))))
(second A)
(second B)
(second C)
(second D)
(second E)
(second F)
(second G)
(second 'A)
(second ())
(defun third (a-list)
(cond ((null a-list) nil)
((not (listp a-list)) nil)
(t (car (cdr (cdr a-list))))))
(third A)
(third B)
(third C)
(third D)
(third E)
(third F)
(third G)
(third 'A)
(third ())
(defun fourth (a-list)
(cond ((null a-list) nil)
((not (listp a-list)) nil)
(t (car (cdr (cdr (cdr a-list)))))))
(fourth A)
(fourth B)
(fourth C)
(fourth D)
(fourth E)
(fourth F)
(fourth G)
(fourth 'A)
(fourth ())
(defun fifth (a-list)
(cond ((null a-list) nil)
((not (listp a-list)) nil)
(t (car (cdr (cdr (cdr (cdr a-list))))))))
(fifth A)
(fifth B)
(fifth C)
(fifth D)
(fifth E)
(fifth F)
(fifth G)
(fifth 'A)
(fifth ())
;;; The function get-1st-child gets the first child of a particular
;;; node in a tree.
(defun get-1st-child (tree-node tree-list)
(cond ((null tree-node) nil)
((null tree-list) nil)
((not (atom tree-node)) nil)
((not (listp tree-list)) nil)
((not (eq tree-node (car tree-list))) nil)
(t(car (second tree-list)))))
;;; The function get-2nd-child gets the second child of a particular
;;; node in a tree.
(defun get-2nd-child (tree-node tree-list)
(cond ((null tree-node) nil)
((null tree-list) nil)
((not (atom tree-node)) nil)
((not (listp tree-list)) nil)
((not (eq tree-node (car tree-list))) nil)
(t (car (third tree-list)))))
;;; Testing get-1st-child
(get-1st-child 'A A)
(get-1st-child 'B B)
(get-1st-child 'C C)
(get-1st-child 'D D)
(get-1st-child 'E E)
(get-1st-child 'F F)
(get-1st-child 'G G)
(get-1st-child 'H A)
(get-1st-child () A)
(get-1st-child 'A ())
(get-1st-child A 'A)
;;; Testing get-2nd-child
(get-2nd-child 'A A)
(get-2nd-child 'B B)
(get-2nd-child 'C C)
(get-2nd-child 'D D)
(get-2nd-child 'E E)
(get-2nd-child 'F F)
(get-2nd-child 'G G)
(get-2nd-child 'H A)
(get-2nd-child () A)
(get-2nd-child 'A ())
(get-2nd-child A 'A)
;;; The reverse function is an old function I wrote for a previous
;;; Artificial Intelligence Topics class at the University of
;;; Northern Iowa.
(defun reverse (lst)
(cond ((null lst) nil)
(t (append (reverse (cdr lst)) (list (car lst))))
)
)
(setq l1 '(a b c d e f g h i j k l))
(setq l2 '(a (b c) (d e f ) g ((h i))))
(reverse l1)
(reverse l2)
;;;; Problem 1 Encode the following tree as a list assigned to a
;;;; globally declared variable. Write two Lisp functions,
;;;; preorder and postorder, that print the pre-order and post-order
;;;; traversals of the tree passed in as the argument, respectively.
;;; The graph is encoded below.
(setq E1 (list 'E '(G) '(O)))
(setq E2 (list 'E '(G) '(T)))
(setq N (list 'N '(W) '(H)))
(setq A (list 'A '(Y) '(S)))
(setq R (list 'R E1 E2))
(setq O (list 'O N A))
(setq var-tree (list 'O R O))
E1
E2
N
A
R
O
var-tree
;;; The function defvar doesn't work in my XLISP environment.
(defvar global-var-tree var-tree)
;;; Testing get-1st-child
(get-1st-child (car A) A)
(get-1st-child (car E1) E1)
(get-1st-child (car E2) E2)
(get-1st-child (car O) O)
(get-1st-child (car N) N)
(get-1st-child (car R) R)
(get-1st-child (car var-tree) var-tree)
(get-1st-child 'H A)
(get-1st-child () A)
(get-1st-child 'A ())
(get-1st-child A 'A)
;;; Testing get-2nd-child
(get-2nd-child (car A) A)
(get-2nd-child (car E1) E1)
(get-2nd-child (car E2) E2)
(get-2nd-child (car O) O)
(get-2nd-child (car N) N)
(get-2nd-child (car R) R)
(get-2nd-child (car var-tree) var-tree)
(get-2nd-child 'H A)
(get-2nd-child () A)
(get-2nd-child 'A ())
(get-2nd-child A 'A)
;;; The function get-preorder returns a list containing the root
;;; and its two children in prefix order (for example
;;; as explained in class, the root would be a binary operator
;;; such as a '+' and the children would be its arguments
;;; such as 1 and 2 and the order in which they would appear is
;;; (+ 1 2)
;;; This function supports the preorder function below.
(defun get-preorder (node-tree)
(cond ((null node-tree) nil)
((atom node-tree) nil)
((null (car node-tree)) nil)
((null (get-1st-child (car node-tree) node-tree)) nil)
((null (get-2nd-child (car node-tree) node-tree))
(list (car node-tree) (get-1st-child (car node-tree) node-tree)
)
)
(t(list (car node-tree)
(get-1st-child (car node-tree) node-tree)
(get-2nd-child (car node-tree) node-tree)
)
)
)
)
(get-preorder A)
(get-preorder E1)
(get-preorder E2)
(get-preorder O)
(get-preorder N)
(get-preorder R)
(get-preorder var-tree)
;;; The function get-postorder returns a list containing the root
;;; and its two children in postfix order (for example
;;; as explained in class, the root would be a binary operator
;;; such as a '+' and the children would be its arguments
;;; such as 1 and 2 and the order in which they would appear is
;;; (1 2 +)
;;; This function supports the postorder function below.
(defun get-postorder (node-tree)
(cond ((null node-tree) nil)
((atom node-tree) nil)
((null (car node-tree)) nil)
((null (get-1st-child (car node-tree) node-tree)) nil)
((null (get-2nd-child (car node-tree) node-tree))
(list (get-1st-child (car node-tree) node-tree)
(car node-tree)
)
)
(t(list (get-1st-child (car node-tree) node-tree)
(get-2nd-child (car node-tree) node-tree)
(car node-tree)
)
)
)
)
(get-postorder A)
(get-postorder E1)
(get-postorder E2)
(get-postorder O)
(get-postorder N)
(get-postorder R)
(get-postorder var-tree)
;;; The preorder function traverses a binary tree and returns
;;; a list of nodes in prefix order (for example (root, root-left-
;;; branch, root-right-branch, left-sub-root,
;;; left-sub-root-left-branch, left-sub-root-right-branch,
;;; right-sub-root, right-sub-root-left-branch,
;;; right-sub-root-right-branch, etc)).
(defun preorder (tree-list)
(cond ((null tree-list) nil)
((atom tree-list) nil)
((null (car tree-list)) nil)
((null (second tree-list)) nil)
((null (third tree-list)) nil)
((not (atom (car tree-list))) nil)
((not (listp (second tree-list))) nil)
((not (listp (third tree-list))) nil)
(t(append (get-preorder
(list (car tree-list)
(list (car (second tree-list)))
(list (car (third tree-list)))
)
)
(preorder (second tree-list))
(preorder (third tree-list))
)
)
)
)
(preorder A)
(preorder E1)
(preorder E2)
(preorder O)
(preorder N)
(preorder R)
(preorder var-tree)
;;; The postorder function traverses a binary tree and returns
;;; a list of nodes in postfix order (for example (root-left-
;;; branch, root-right-branch, root, right-sub-root-left-branch,
;;; right-sub-root-right-branch, right-sub-root,
;;; left-sub-root-left-branch, left-sub-root-right-branch,
;;; left-sub-root, etc)).
(defun postorder (tree-list)
(cond ((null tree-list) nil)
((atom tree-list) nil)
((null (car tree-list)) nil)
((null (second tree-list)) nil)
((null (third tree-list)) nil)
((not (atom (car tree-list))) nil)
((not (listp (second tree-list))) nil)
((not (listp (third tree-list))) nil)
(t(append (get-postorder
(list (car tree-list)
(list (car (second tree-list)))
(list (car (third tree-list)))
)
)
(postorder (third tree-list))
(postorder (second tree-list))
)
)
)
)
(postorder A)
(postorder E1)
(postorder E2)
(postorder O)
(postorder N)
(postorder R)
(postorder var-tree)
(print (preorder var-tree))
(print (postorder var-tree))
;;; var-tree is already in prefix order if I was to ignore
;;; the nested listing.
(print var-tree)
;;; The function print-atoms-preorder prints all the atoms found
;;; in the input in preorder and then prints -done at the end.
(defun print-atoms-preorder (input)
(cond ((null input) '-done)
((atom input)(princ input) '-done)
(t(print-atoms-preorder (car input))
(print-atoms-preorder (cdr input))
'-done)
)
)
(print-atoms-preorder var-tree)
(print-atoms-preorder A)
(print-atoms-preorder E1)
(print-atoms-preorder E2)
(print-atoms-preorder O)
(print-atoms-preorder N)
(print-atoms-preorder R)
(print-atoms-preorder 'H)
(print-atoms-preorder ())
;;; The function print-atoms-postorder prints all the atoms found
;;; in the input in postorder and then prints -done at the end.
(defun print-atoms-postorder (input)
(cond ((null input) '-done)
((atom input)(princ input) '-done)
(t(print-atoms-postorder (cdr input))
(print-atoms-postorder (car input))
'-done)
)
)
(print-atoms-postorder var-tree)
(print-atoms-postorder A)
(print-atoms-postorder E1)
(print-atoms-postorder E2)
(print-atoms-postorder O)
(print-atoms-postorder N)
(print-atoms-postorder R)
(print-atoms-postorder 'H)
(print-atoms-postorder ())
;;; The function list-atoms-preorder returns of flat list of atoms
;;; found in the tree in preorder no matter how nested it is.
(defun list-atoms-preorder (input)
(cond ((null input) nil)
((atom input) (list input))
(t (append (list-atoms-preorder (car input))
(list-atoms-preorder (cdr input)))
)
)
)
(print (list-atoms-preorder var-tree))
(print (list-atoms-preorder A))
(print (list-atoms-preorder E1))
(print (list-atoms-preorder E2))
(print (list-atoms-preorder O))
(print (list-atoms-preorder N))
(print (list-atoms-preorder R))
(print (list-atoms-preorder 'H))
(print (list-atoms-preorder ()))
;;; The function list-atoms-postorder returns of flat list of atoms
;;; found in the tree in postorder no matter how nested it is.
(defun list-atoms-postorder (input)
(cond ((null input) nil)
((atom input) (list input))
(t (append (list-atoms-postorder (cdr input))
(list-atoms-postorder (car input)))
)
)
)
(print (list-atoms-postorder var-tree))
(print (list-atoms-postorder A))
(print (list-atoms-postorder E1))
(print (list-atoms-postorder E2))
(print (list-atoms-postorder O))
(print (list-atoms-postorder N))
(print (list-atoms-postorder R))
(print (list-atoms-postorder 'H))
(print (list-atoms-postorder ()))
;;;; Problem 2 Encode the following graph using property lists.
;;;; Write a Lisp function that, when given a start and an end
;;;; node, uses depth-first search to return a path between them.
;;; The graph is encoded below.
(setq G (list 'G))
(setq E (list 'E G))
(setq D (list 'D E))
(setq F (list 'F E))
(setq C (list 'C F D))
(setq B (list 'B C D))
(setq A (list 'A C B))
A
B
C
D
E
F
G
;;; The match function finds all nodes with the same letter
;;; and returns a list of those duplicate nodes. It basically
;;; tell me if a node is unique or not within the tree.
(defun match (tree-node tree-list)
(cond ((null tree-node) nil)
((null tree-list) nil)
((not (atom tree-node)) nil)
((not (listp tree-list)) nil)
((eq tree-node (car tree-list)) (list tree-node))
(t(append(match tree-node (second tree-list))
(match tree-node (third tree-list))))))
(match 'A A)
(match 'B A)
(match 'C A)
(match 'D A)
(match 'E A)
(match 'F A)
(match 'G A)
(match 'A ())
(match () 'A)
(match A 'A)
;;; The get-node-tree function returns the subtree of a particular
;;; node (including the node itself).
(defun get-node-tree (tree-node)
(cond ((null tree-node) nil)
((not (atom tree-node)) nil)
((eq tree-node 'A) A)
((eq tree-node 'B) B)
((eq tree-node 'C) C)
((eq tree-node 'D) D)
((eq tree-node 'E) E)
((eq tree-node 'F) F)
((eq tree-node 'G) G)))
(get-node-tree 'A)
(get-node-tree 'B)
(get-node-tree 'C)
(get-node-tree 'D)
(get-node-tree 'E)
(get-node-tree 'F)
(get-node-tree 'G)
(get-node-tree 'H)
(get-node-tree ())
(get-node-tree A)
;;; The function get-1st-nonnull-atom gets the first non-nil atom
;;; of a list or tree no matter how deeply nested it is.
;;; This function provides the flexibility to use nils to
;;; mark non-existing children within a tree if desired.
;;; But ultimately, I found it unnecessary.
(defun get-1st-nonnull-atom (input-list)
(cond ((null input-list) nil)
((atom input-list) nil)
((null (car input-list)) (get-1st-nonnull-atom (cdr input-list)))
((listp (car input-list)) (get-1st-nonnull-atom (car input-list)))
(t(car input-list))))
(get-1st-nonnull-atom '(nil nil A B C))
(get-1st-nonnull-atom '(nil (nil A) B C))
(get-1st-nonnull-atom A)
(get-1st-nonnull-atom '(nil (nil (nil A) B C)))
(get-1st-nonnull-atom '(nil (nil (nil nil) nil nil)))
(get-1st-nonnull-atom '((A B)))
(get-1st-nonnull-atom 'A)
;;; The function get-children gets all the children of a particular
;;; node, including grand-children, great-grandchildren, etc.
(defun get-children (tree-node tree-list)
(cond ((null tree-node) nil)
((null tree-list) nil)
((not (atom tree-node)) nil)
((not (listp tree-list)) nil)
((not (eq tree-node (car tree-list))) nil)
(t(cdr tree-list))))
(get-children 'A A)
(get-children 'B (get-node-tree 'B))
(get-children 'C (get-node-tree 'C))
(get-children 'D (get-node-tree 'D))
(get-children 'E (get-node-tree 'E))
(get-children 'F (get-node-tree 'F))
(get-children 'G (get-node-tree 'G))
(get-children 'H A)
(get-children () A)
(get-children 'A ())
(get-children A 'A)
;;; Testing get-1st-child
(get-1st-child 'A A)
(get-1st-child 'B (get-node-tree 'B))
(get-1st-child 'C (get-node-tree 'C))
(get-1st-child 'D (get-node-tree 'D))
(get-1st-child 'E (get-node-tree 'E))
(get-1st-child 'F (get-node-tree 'F))
(get-1st-child 'G (get-node-tree 'G))
(get-1st-child 'H A)
(get-1st-child () A)
(get-1st-child 'A ())
(get-1st-child A 'A)
;;; Testing get-2nd-child
(get-2nd-child 'A A)
(get-2nd-child 'B (get-node-tree 'B))
(get-2nd-child 'C (get-node-tree 'C))
(get-2nd-child 'D (get-node-tree 'D))
(get-2nd-child 'E (get-node-tree 'E))
(get-2nd-child 'F (get-node-tree 'F))
(get-2nd-child 'G (get-node-tree 'G))
(get-2nd-child 'H A)
(get-2nd-child () A)
(get-2nd-child 'A ())
(get-2nd-child A 'A)
;;; The next function is a supporting function for dfs function
;;; below. DFS is an abbreviation for depth first search.
;;; It gets the children of a particular node (WITHOUT all its
;;; grand-children, great grand-children, etc.).
(defun next (a-node)
(cond ((null a-node) nil)
((not (atom a-node)) nil)
((null (get-node-tree a-node)) nil)
((null (get-1st-child a-node (get-node-tree a-node))) nil)
((null (get-2nd-child a-node (get-node-tree a-node)))
(list (get-1st-child a-node (get-node-tree a-node))
)
)
(t(list (get-1st-child a-node (get-node-tree a-node))
(get-2nd-child a-node (get-node-tree a-node))))))
(next 'A)
(next 'B)
(next 'C)
(next 'D)
(next 'E)
(next 'F)
(next 'G)
(next 'H)
(next ())
(next A)
;;; The dfs function below also has a search path in its
;;; parameter list. The search path needs to be passed
;;; down recursively through all of its sub-environments.
;;; The search path is listed backwards to support efficient
;;; removal of nils if nils are used within a tree to represent
;;; non-existent children.
(defun dfs (goal-node start-list search-path)
(cond ((null goal-node) nil)
((null start-list) nil)
((listp goal-node) nil)
((atom start-list) nil)
((null (car start-list))
(dfs goal-node (cdr start-list)(cdr search-path)))
((null (get-node-tree goal-node)) nil)
((null (get-node-tree (car start-list))) nil)
((eq goal-node (car start-list))
(append (list (car start-list)) search-path))
(t (dfs goal-node
(append (next (car start-list))
(rest start-list))
(append (list (car start-list)) search-path)))))
(dfs 'A A ())
(dfs 'B A ())
(dfs 'C A ())
(dfs 'D A ())
(dfs 'E A ())
(dfs 'F A ())
(dfs 'G A ())
(dfs 'H A ())
(dfs 'F C ())
;;; The function b-parent-of-a checks to see if the second
;;; node is a parent of the first node. It doesn't matter
;;; if a node has more than one parent, this function would
;;; still work. Returns t if true and returns nil if not.
;;; This function is a supporting function for the function
;;; trim below.
(defun b-parent-of-a (a-node b-node)
(cond ((null a-node) nil)
((listp a-node) nil)
((null b-node) nil)
((listp b-node) nil)
((eq a-node (get-1st-child b-node (get-node-tree b-node))) 't)
((eq a-node (get-2nd-child b-node (get-node-tree b-node))) 't)
)
)
(b-parent-of-a 'F 'G)
(b-parent-of-a 'B 'A)
(b-parent-of-a 'F 'C)
(b-parent-of-a (car '(F G E D C)) (car (cdr '(F G E D C))))
(b-parent-of-a (car '(G E D C)) (car (cdr '(G E D C))))
(setq search-path (dfs 'B A ()))
search-path
(b-parent-of-a (car search-path) (car (cdr search-path)))
(setq search-path (dfs 'G A ()))
search-path
(b-parent-of-a (car search-path) (car (cdr search-path)))
;;; This function trim removes dead branches from the search
;;; path of the dfs function above. It is also flexible enough
;;; to use for trimming a list of nodes so that the list is ordered
;;; from child to parent, removing any node that is not a parent
;;; of the previous node in the list.
(defun trim (a-list)
(cond ((null a-list) a-list)
((atom a-list) a-list)
((null (car a-list)) a-list)
((null (car (cdr a-list))) a-list)
((b-parent-of-a (car a-list)(car (cdr a-list)))
(append (list (car a-list))
(trim (cdr a-list))))
(t(trim (append (list (car a-list))
(cdr (cdr a-list))
)))))
(trim (dfs 'F A ()))
(trim (dfs 'G A ()))
(trim (dfs 'G F ()))
(trim (dfs 'C E ()))
(trim (reverse '(A B C D E F G)))
(trim (reverse '(F D C)))
(trim '(C D F))
(trim nil)
(trim 'A)
(trim '(A))
(trim '(B A))
(trim '(C B A))
(trim '(D C B A))
(trim '(F C B A))
(trim '(F C F A))
(trim '(F (C) F A))
(trim '(F (C) C A))
(trim '(F (C)))
(trim '(F C (C) A))
(trim '(F C A A))
(trim '(A B))
(trim '(C A))
(trim (dfs 'B A ()))
(trim '(B G E D G E F C A))
(trim (dfs 'D A ()))
(trim '(D G E F C A))
;;; This function get-path is the final solution to Problem 2
;;; as defined above.
(defun get-path (root-node goal-node)
(cond ((null root-node) nil)
((null goal-node) nil)
((listp root-node) nil)
((listp goal-node) nil)
((null (get-node-tree root-node)) nil)
((null (get-node-tree goal-node)) nil)
(t(reverse(trim (dfs goal-node (get-node-tree root-node) ())
)))))
(get-path 'A 'G)
(get-path 'F 'G)
(get-path 'E 'C)
(get-path 'A 'G)
(get-path 'F 'G)
(get-path 'E 'C)
(get-path 'A 'A)
(get-path 'A 'B)
(get-path 'A 'C)
(get-path 'A 'D)
(get-path 'A 'E)
(get-path 'A 'F)
(get-path 'A 'G)
(get-path 'A 'H)
(get-path 'A '())
(get-path '() 'A)
(get-path A 'A)
(get-path 'A A)
(get-path 'B 'A)
(get-path 'B 'B)
(get-path 'B 'C)
(get-path 'B 'D)
(get-path 'B 'E)
(get-path 'B 'F)
(get-path 'B 'G)
(get-path 'C 'A)
(get-path 'C 'B)
(get-path 'C 'C)
(get-path 'C 'D)
(get-path 'C 'E)
(get-path 'C 'F)
(get-path 'C 'G)
(get-path 'D 'A)
(get-path 'D 'B)
(get-path 'D 'C)
(get-path 'D 'D)
(get-path 'D 'E)
(get-path 'D 'F)
(get-path 'D 'G)
(get-path 'E 'A)
(get-path 'E 'B)
(get-path 'E 'C)
(get-path 'E 'D)
(get-path 'E 'E)
(get-path 'E 'F)
(get-path 'E 'G)
(get-path 'F 'A)
(get-path 'F 'B)
(get-path 'F 'C)
(get-path 'F 'D)
(get-path 'F 'E)
(get-path 'F 'F)
(get-path 'F 'G)
(get-path 'H 'A)
(get-path 'H 'B)
(get-path 'H 'C)
(get-path 'H 'D)
(get-path 'H 'E)
(get-path 'H 'F)
(get-path 'H 'G)
;;; The dfs-b function below is an alternative depth first search
;;; without a search path in its parameter list. It returns
;;; the node atom if found and nil otherwise.
(defun dfs-b (goal-node start-list)
(cond ((null goal-node) nil)
((null start-list) nil)
((listp goal-node) nil)
((atom start-list) nil)
((null (car start-list)) (dfs-b goal-node (cdr start-list)))
((null (get-node-tree goal-node)) nil)
((null (get-node-tree (car start-list))) nil)
((eq goal-node (car start-list))
(car start-list))
(t (dfs-b goal-node
(append (next (car start-list))
(rest start-list))))))
(dfs-b 'A A)
(dfs-b 'B A)
(dfs-b 'C A)
(dfs-b 'D A)
(dfs-b 'E A)
(dfs-b 'F A)
(dfs-b 'G A)
(dfs-b 'H A)
(dfs-b 'A B)
(dfs-b 'B B)
(dfs-b 'C B)
(dfs-b 'D B)
(dfs-b 'E B)
(dfs-b 'F B)
(dfs-b 'G B)
(dfs-b 'H B)
(dfs-b 'A C)
(dfs-b 'B C)
(dfs-b 'C C)
(dfs-b 'D C)
(dfs-b 'E C)
(dfs-b 'F C)
(dfs-b 'G C)
(dfs-b 'H C)
(dfs-b 'A D)
(dfs-b 'B D)
(dfs-b 'C D)
(dfs-b 'D D)
(dfs-b 'E D)
(dfs-b 'F D)
(dfs-b 'G D)
(dfs-b 'H D)
(dfs-b 'A E)
(dfs-b 'B E)
(dfs-b 'C E)
(dfs-b 'D E)
(dfs-b 'E E)
(dfs-b 'F E)
(dfs-b 'G E)
(dfs-b 'H E)
(dfs-b 'A F)
(dfs-b 'B F)
(dfs-b 'C F)
(dfs-b 'D F)
(dfs-b 'E F)
(dfs-b 'F F)
(dfs-b 'G F)
(dfs-b 'H F)
(dfs-b 'A G)
(dfs-b 'B G)
(dfs-b 'C G)
(dfs-b 'D G)
(dfs-b 'E G)
(dfs-b 'F G)
(dfs-b 'G G)
(dfs-b 'H G)
;;;; Problem 3 Develop a representation for a tic-tac-toe board
;;;; Write a function that, when given a board configuration as
;;;; its argument, returns a list containing all of the next
;;;; possible moves.
;;; The tic-tac-toe board is represented below
;;; The graph is encoded below. It's basically a trinary tree.
;;; Currently, the board is completely empty
;;; empty X O
(setq left-1 (list 'left-1 '(1) '(0) '(0)))
(setq mide-1 (list 'mide-1 '(1) '(0) '(0)))
(setq rite-1 (list 'rite-1 '(1) '(0) '(0)))
(setq left-2 (list 'left-2 '(1) '(0) '(0)))
(setq mide-2 (list 'mide-2 '(1) '(0) '(0)))
(setq rite-2 (list 'rite-2 '(1) '(0) '(0)))
(setq left-3 (list 'left-3 '(1) '(0) '(0)))
(setq mide-3 (list 'mide-3 '(1) '(0) '(0)))
(setq rite-3 (list 'rite-3 '(1) '(0) '(0)))
(setq line1 (list 'line1 left-1 mide-1 rite-1))
(setq line2 (list 'line2 left-2 mide-2 rite-2))
(setq line3 (list 'line3 left-3 mide-3 rite-3))
(setq board (list 'board line1 line2 line3))
line1
line2
line3
board
;;; This function emptyp checks to see if the particular node
;;; is empty (=1 in the first child) or not. It returns the
;;; a list containing the node if true and nil otherwise)
(defun emptyp (node-tree)
(cond ((null node-tree) nil)
((atom node-tree) nil)
((null (car node-tree)) nil)
((null (get-1st-child (car node-tree) node-tree)) nil)
((eq 1 (get-1st-child (car node-tree) node-tree))
(list(car node-tree)))
)
)
(emptyp left-1)
(emptyp left-2)
(emptyp left-3)
(emptyp mide-1)
(emptyp mide-2)
(emptyp mide-3)
(emptyp rite-1)
(emptyp rite-2)
(emptyp rite-3)
(emptyp line1)
(emptyp line2)
(emptyp line3)
(emptyp board)
(emptyp 'line)
(emptyp ())
;;; This function next-moves returns a list of all possible
;;; moves in a configuration listed as a trinary tree.
(defun next-moves (tree-list)
(cond ((null tree-list) nil)
((atom tree-list) nil)
((null (car tree-list)) nil)
((null (second tree-list)) nil)
((null (third tree-list)) nil)
((null (fourth tree-list)) nil)
((not (atom (car tree-list))) nil)
((not (listp (second tree-list))) nil)
((not (listp (third tree-list))) nil)
((not (listp (fourth tree-list))) nil)
(t(append (emptyp
(list (car tree-list)
(list (car (second tree-list)))
(list (car (third tree-list)))
(list (car (fourth tree-list)))
)
)
(next-moves (second tree-list))
(next-moves (third tree-list))
(next-moves (fourth tree-list))
)
)
)
)
(next-moves left-1)
(next-moves left-2)
(next-moves left-3)
(next-moves mide-1)
(next-moves mide-2)
(next-moves mide-3)
(next-moves rite-1)
(next-moves rite-2)
(next-moves rite-3)
(next-moves line1)
(next-moves line2)
(next-moves line3)
(next-moves board)
;;; Currently, the board has some X's and O's
;;;
;;; X | 0 |
;;; -----------
;;; 0 | X |
;;; -----------
;;; | |
;;;
;;; empty X O
(setq left-1 (list 'left-1 '(0) '(1) '(0)))
(setq mide-1 (list 'mide-1 '(0) '(0) '(1)))
(setq rite-1 (list 'rite-1 '(1) '(0) '(0)))
(setq left-2 (list 'left-2 '(0) '(0) '(1)))
(setq mide-2 (list 'mide-2 '(0) '(1) '(0)))
(setq rite-2 (list 'rite-2 '(1) '(0) '(0)))
(setq left-3 (list 'left-3 '(1) '(0) '(0)))
(setq mide-3 (list 'mide-3 '(1) '(0) '(0)))
(setq rite-3 (list 'rite-3 '(1) '(0) '(0)))
(setq line1 (list 'line1 left-1 mide-1 rite-1))
(setq line2 (list 'line2 left-2 mide-2 rite-2))
(setq line3 (list 'line3 left-3 mide-3 rite-3))
(setq board (list 'board line1 line2 line3))
line1
line2
line3
board
(next-moves board)
;;;; Problem 4 Tanimoto defined a heuristic evaluation function for
;;;; tic-tac-toe boards as
;;;; f=100A + 10B + C - (100D + 10E + F),
;;;; where
;;;; A is the number of lines with 3 X's,
;;;; B is the number of unblocked lines with 2 X's,
;;;; C is the number of unblocked lines with 1 X,
;;;; D is the number of lines with 3 O's,
;;;; E is the number of unblocked lines with 2 O's, and
;;;; F is the number of unblocked lines with 1 O.
;;;; Implement Tanimoto's heuristic evaluation function.
;;;; That is, when given a tic-tac-toe board configuration
;;;; the function returns f.
;;; The tanimoto function returns the value of the heuristic
;;; evaluation function for tic-tac-toe boards.
(defun tanimoto-f (board)
(setq get-line1-num-of-X
(+ (car(third left-1)) (car(third mide-1)) (car(third rite-1))))
(setq get-line2-num-of-X
(+ (car(third left-2)) (car(third mide-2)) (car(third rite-2))))
(setq get-line3-num-of-X
(+ (car(third left-3)) (car(third mide-3)) (car(third rite-3))))
(setq get-line1-num-of-0
(+ (car(fourth left-1)) (car(fourth mide-1)) (car(fourth rite-1))))
(setq get-line2-num-of-0
(+ (car(fourth left-2)) (car(fourth mide-2)) (car(fourth rite-2))))
(setq get-line3-num-of-0
(+ (car(fourth left-3)) (car(fourth mide-3)) (car(fourth rite-3))))
(setq get-line1-num-of-empty
(+ (car(second left-1)) (car(second mide-1)) (car(second rite-1))))
(setq get-line2-num-of-empty
(+ (car(second left-2)) (car(second mide-2)) (car(second rite-2))))
(setq get-line3-num-of-empty
(+ (car(second left-3)) (car(second mide-3)) (car(second rite-3))))
(setq A 0)
(setq B 0)
(setq C 0)
(cond ((eq 3 get-line1-num-of-X) (setq A (+ 1 A)))
((and (eq 2 get-line1-num-of-X)
(eq 1 get-line1-num-of-empty)) (setq B (+ 1 B)))
((and (eq 1 get-line1-num-of-X)
(eq 2 get-line1-num-of-empty)) (setq C (+ 1 C))))
(setq D 0)
(setq E 0)
(setq F 0)
(cond ((eq 3 get-line1-num-of-0) (setq D (+ 1 D)))
((and (eq 2 get-line1-num-of-0)
(eq 1 get-line1-num-of-empty)) (setq E (+ 1 E)))
((and (eq 1 get-line1-num-of-0)
(eq 2 get-line1-num-of-empty)) (setq F (+ 1 F))))
(cond ((eq 3 get-line2-num-of-X) (setq A (+ 1 A)))
((and (eq 2 get-line2-num-of-X)
(eq 1 get-line2-num-of-empty)) (setq B (+ 1 B)))
((and (eq 1 get-line2-num-of-X)
(eq 2 get-line2-num-of-empty)) (setq C (+ 1 C))))
(cond ((eq 3 get-line2-num-of-0) (setq D (+ 1 D)))
((and (eq 2 get-line2-num-of-0)
(eq 1 get-line2-num-of-empty)) (setq E (+ 1 E)))
((and (eq 1 get-line2-num-of-0)
(eq 2 get-line2-num-of-empty)) (setq F (+ 1 F))))
(cond ((eq 3 get-line3-num-of-X) (setq A (+ 1 A)))
((and (eq 2 get-line3-num-of-X)
(eq 1 get-line3-num-of-empty)) (setq B (+ 1 B)))
((and (eq 1 get-line3-num-of-X)
(eq 2 get-line3-num-of-empty)) (setq C (+ 1 C))))
(cond ((eq 3 get-line3-num-of-0) (setq D (+ 1 D)))
((and (eq 2 get-line3-num-of-0)
(eq 1 get-line3-num-of-empty)) (setq E (+ 1 E)))
((and (eq 1 get-line3-num-of-0)
(eq 2 get-line3-num-of-empty)) (setq F (+ 1 F))))
(setq return-f (- (+ (* 100 A) (* 10 B) (* 1 C))
(+ (* 100 D) (* 10 E) (* 1 F))))
)
;;; Testing tanimoto function
;;; Currently, the board has some X's and O's
;;;
;;; X | 0 |
;;; -----------
;;; 0 | X |
;;; -----------
;;; | |X
;;;
;;; empty X O
(setq left-1 (list 'left-1 '(0) '(1) '(0)))
(setq mide-1 (list 'mide-1 '(0) '(0) '(1)))
(setq rite-1 (list 'rite-1 '(1) '(0) '(0)))
(setq left-2 (list 'left-2 '(0) '(0) '(1)))
(setq mide-2 (list 'mide-2 '(0) '(1) '(0)))
(setq rite-2 (list 'rite-2 '(1) '(0) '(0)))
(setq left-3 (list 'left-3 '(1) '(0) '(0)))
(setq mide-3 (list 'mide-3 '(1) '(0) '(0)))
(setq rite-3 (list 'rite-3 '(0) '(1) '(0)))
(setq line1 (list 'line1 left-1 mide-1 rite-1))
(setq line2 (list 'line2 left-2 mide-2 rite-2))
(setq line3 (list 'line3 left-3 mide-3 rite-3))
(setq board (list 'board line1 line2 line3))
(tanimoto-f board)
;;; Currently, the board has some X's and O's
;;;
;;; X | 0 |
;;; -----------
;;; 0 | X |
;;; -----------
;;; | 0 |
;;;
;;; empty X O
(setq left-1 (list 'left-1 '(0) '(1) '(0)))
(setq mide-1 (list 'mide-1 '(0) '(0) '(1)))
(setq rite-1 (list 'rite-1 '(1) '(0) '(0)))
(setq left-2 (list 'left-2 '(0) '(0) '(1)))
(setq mide-2 (list 'mide-2 '(0) '(1) '(0)))
(setq rite-2 (list 'rite-2 '(1) '(0) '(0)))
(setq left-3 (list 'left-3 '(1) '(0) '(0)))
(setq mide-3 (list 'mide-3 '(0) '(0) '(1)))
(setq rite-3 (list 'rite-3 '(1) '(0) '(0)))
(setq line1 (list 'line1 left-1 mide-1 rite-1))
(setq line2 (list 'line2 left-2 mide-2 rite-2))
(setq line3 (list 'line3 left-3 mide-3 rite-3))
(setq board (list 'board line1 line2 line3))
(tanimoto-f board)
;;; Currently, the board has some X's and O's
;;;
;;; X | 0 | 0
;;; -----------
;;; X | X |
;;; -----------
;;; | |
;;;
;;; empty X O
(setq left-1 (list 'left-1 '(0) '(1) '(0)))
(setq mide-1 (list 'mide-1 '(0) '(0) '(1)))
(setq rite-1 (list 'rite-1 '(0) '(0) '(1)))
(setq left-2 (list 'left-2 '(0) '(1) '(0)))
(setq mide-2 (list 'mide-2 '(0) '(1) '(0)))
(setq rite-2 (list 'rite-2 '(1) '(0) '(0)))
(setq left-3 (list 'left-3 '(1) '(0) '(0)))
(setq mide-3 (list 'mide-3 '(1) '(0) '(0)))
(setq rite-3 (list 'rite-3 '(1) '(0) '(0)))
(setq line1 (list 'line1 left-1 mide-1 rite-1))
(setq line2 (list 'line2 left-2 mide-2 rite-2))
(setq line3 (list 'line3 left-3 mide-3 rite-3))
(setq board (list 'board line1 line2 line3))
(tanimoto-f board)
;;; Currently, the board has some X's and O's
;;;
;;; 0 | X | X
;;; -----------
;;; 0 | 0 |
;;; -----------
;;; | |
;;;
;;; empty X O
(setq left-1 (list 'left-1 '(0) '(0) '(1)))
(setq mide-1 (list 'mide-1 '(0) '(1) '(0)))
(setq rite-1 (list 'rite-1 '(0) '(1) '(0)))
(setq left-2 (list 'left-2 '(0) '(0) '(1)))
(setq mide-2 (list 'mide-2 '(0) '(0) '(1)))
(setq rite-2 (list 'rite-2 '(1) '(0) '(0)))
(setq left-3 (list 'left-3 '(1) '(0) '(0)))
(setq mide-3 (list 'mide-3 '(1) '(0) '(0)))
(setq rite-3 (list 'rite-3 '(1) '(0) '(0)))
(setq line1 (list 'line1 left-1 mide-1 rite-1))
(setq line2 (list 'line2 left-2 mide-2 rite-2))
(setq line3 (list 'line3 left-3 mide-3 rite-3))
(setq board (list 'board line1 line2 line3))
(tanimoto-f board)
;;; Currently, the board has some X's and O's
;;;
;;; X | 0 | 0
;;; -----------
;;; X | X | X
;;; -----------
;;; | | 0
;;;
;;; empty X O
(setq left-1 (list 'left-1 '(0) '(1) '(0)))
(setq mide-1 (list 'mide-1 '(0) '(0) '(1)))
(setq rite-1 (list 'rite-1 '(0) '(0) '(1)))
(setq left-2 (list 'left-2 '(0) '(1) '(0)))
(setq mide-2 (list 'mide-2 '(0) '(1) '(0)))
(setq rite-2 (list 'rite-2 '(0) '(1) '(0)))
(setq left-3 (list 'left-3 '(1) '(0) '(0)))
(setq mide-3 (list 'mide-3 '(1) '(0) '(0)))
(setq rite-3 (list 'rite-3 '(0) '(0) '(1)))
(setq line1 (list 'line1 left-1 mide-1 rite-1))
(setq line2 (list 'line2 left-2 mide-2 rite-2))
(setq line3 (list 'line3 left-3 mide-3 rite-3))
(setq board (list 'board line1 line2 line3))
(tanimoto-f board)
;;; Currently, the board has some X's and O's
;;;
;;; 0 | X | X
;;; -----------
;;; 0 | 0 | 0
;;; -----------
;;; | | X
;;;
;;; empty X O
(setq left-1 (list 'left-1 '(0) '(0) '(1)))
(setq mide-1 (list 'mide-1 '(0) '(1) '(0)))
(setq rite-1 (list 'rite-1 '(0) '(1) '(0)))
(setq left-2 (list 'left-2 '(0) '(0) '(1)))
(setq mide-2 (list 'mide-2 '(0) '(0) '(1)))
(setq rite-2 (list 'rite-2 '(0) '(0) '(1)))
(setq left-3 (list 'left-3 '(1) '(0) '(0)))
(setq mide-3 (list 'mide-3 '(1) '(0) '(0)))
(setq rite-3 (list 'rite-3 '(0) '(1) '(0)))
(setq line1 (list 'line1 left-1 mide-1 rite-1))
(setq line2 (list 'line2 left-2 mide-2 rite-2))
(setq line3 (list 'line3 left-3 mide-3 rite-3))
(setq board (list 'board line1 line2 line3))
(tanimoto-f board)
