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