#| This file at:
http://interweave-consulting.blogspot.co.uk/2017/01/noughts-and-crosses-in-common-lisp.html
This is the complete code in Common Lisp for implementing the game of noughts and crosses (tic-tac-toe). You should be able to select this entire post, paste it into a CL system, and compile and load.
Some examples are
here.
There are three kinds of players defined: humans, random players and a minimax player which searches a game-tree to a configurable depth.
To invoke the three kinds of players use one of these function calls - see the end of the file.
(play-game 'X *initial-board* #'human #'human)
(play-game 'X *initial-board* #'rand-player #'human)
(play-game 'X *initial-board* #'mx-player-X #'human)
A game looks like
this (using the random player). Warning: there may still be bugs - I have not tested the functions to death, particularly minimax.
---------
|#
;;; Noughts and Crosses
;;; Functions to explore game tree management and minimax
;;;
;;; December 29th 2016 - January 25th 2017
;
; ------------------- Datatype BOARD ------------------------------------
(defparameter *initial-board* '(0 1 2 3 4 5 6 7 8)) ; empty board
(defvar *win-score* 32) ; the score assigned to a terminal win position
(defvar *lose-score* -32) ; the score assigned to a terminal lose position
(defvar *draw-score* 0) ; the score assigned to a terminal draw position
(defun print-board (b)
(let ((b0 (nth 0 b))
(b1 (nth 1 b))
(b2 (nth 2 b))
(b3 (nth 3 b))
(b4 (nth 4 b))
(b5 (nth 5 b))
(b6 (nth 6 b))
(b7 (nth 7 b))
(b8 (nth 8 b)))
(format t "~%")
(format t " ~{~a~^ | ~} ~%" (list b0 b1 b2))
(format t " ~{~a~^ | ~} ~%" (list b3 b4 b5))
(format t " ~{~a~^ | ~} ~%" (list b6 b7 b8))
))
; This is the output of 'print-board' when applied to *arbitrary*
;
; X | 1 | O
; O | 4 | 5
; X | 7 | X
; These parameters available for testing
(defparameter *top-side-win* '(X X X 3 4 5 6 7 8))
(defparameter *bot-side-win* '(0 1 2 3 4 5 X X X))
(defparameter *arbitrary* '(X 1 O O 4 5 X 7 X))
(defparameter *end-in-draw* '(X X O O X X X O O)) ; this is a draw position
(defun opp (m) ; MARK -> MARK - switches player around
(if (equal m 'X) 'O 'X) )
(defun triple-score (m r) ; MARK x POSITION-list -> Int
"my good positions - opponent's good positions"
(let ((good (if (zerop (count (opp m) r)) (count m r) 0) )
(bad (if (zerop (count m r)) (count (opp m) r) 0)) )
(- good bad) ))
(defun heuristic-score (m B) ; MARK x BOARD -> Nat
"heuristic score absolute value <= around 4 or 5 "
(let ((sum1 (triple-score m (list (nth 0 B) (nth 1 B) (nth 2 B))))
(sum2 (triple-score m (list (nth 3 B) (nth 4 B) (nth 5 B))))
(sum3 (triple-score m (list (nth 6 B) (nth 7 B) (nth 8 B))))
(sum4 (triple-score m (list (nth 0 B) (nth 3 B) (nth 6 B))))
(sum5 (triple-score m (list (nth 1 B) (nth 4 B) (nth 7 B))))
(sum6 (triple-score m (list (nth 2 B) (nth 5 B) (nth 8 B))))
(sum7 (triple-score m (list (nth 0 B) (nth 4 B) (nth 8 B))))
(sum8 (triple-score m (list (nth 2 B) (nth 4 B) (nth 6 B)))) )
(+ sum1 sum2 sum3 sum4 sum5 sum6 sum7 sum8) ))
(defun is-win (mark B) ; MARK x BOARD -> Bool
"mark is X or O, B is the board"
(let ((triple (list mark mark mark)))
(or (equal triple (list (nth 0 B) (nth 1 B) (nth 2 B)))
(equal triple (list (nth 3 B) (nth 4 B) (nth 5 B)))
(equal triple (list (nth 6 B) (nth 7 B) (nth 8 B)))
(equal triple (list (nth 0 B) (nth 3 B) (nth 6 B)))
(equal triple (list (nth 1 B) (nth 4 B) (nth 7 B)))
(equal triple (list (nth 2 B) (nth 5 B) (nth 8 B)))
(equal triple (list (nth 0 B) (nth 4 B) (nth 8 B)))
(equal triple (list (nth 2 B) (nth 4 B) (nth 6 B)))
)))
(defun is-draw (b) ; BOARD -> BOOL
(null (remove 'O (remove 'X b))))
; ------------------ Datatype OXO-NODE -----------------------------
;
; BOARD x MOVE (Nat) x SCORE (Nat)
;
; MOVE: 9 is the non-assigned move (legal values 0-8)
; the number is the move which got to this node.
;
; SCORE: only applies to minimax.
; t is the non-assigned score (assigned scores are terminal,
; heuristic or backed up via minimax).
;
(defun mknode (board move score)
"node is board + move (undefined=9 or 0-8) + board-score (undefined=t)"
(list board move score))
(defparameter *initial-node* (mknode *initial-board* 9 t)) ; empty root node
; ------------- Node projection functions -----------------------------------
(defun board (n) ; OXO-NODE -> BOARD (1st element)
(car n))
(defun cmove (n) ; OXO-NODE -> Nat (2nd element) -- Index number of current move
(cadr n))
(defun score (n) ; OXO-NODE -> Nat (3rd element) -- (backed up) board rating
(caddr n))
; ------------------- Datatype OXO-TREE --------------------------------------
;
(defun mktree (node treelist) ; OXO-NODE x TREE-list -> TREE
"build a tree"
(list node treelist))
(defun tree-node (tree)
(car tree))
(defun tree-children (tree) ; TREE -> TREE-list
(cadr tree))
(defun leafp (tree) ; TREE -> bool
(null (tree-children tree)))
; ----------- XTREE: the main function to build a game-tree to depth n -----
(defun xtree (s m n d) ; MARK x MARK x OXO-NODE x Nat -> TREE
"Generate game tree. Mark s is the mark the player is playing (X or O).
Mark m to move next. Initial node n to depth d"
(let ( (s1 (opp s))
(m1 (opp m))
(b (board n))
(i (cmove n)) )
(cond ((is-win s b) (mktree (mknode b i *win-score*) nil) )
((is-win s1 b) (mktree (mknode b i *lose-score*) nil) )
((is-draw b) (mktree (mknode b i *draw-score*) nil) )
((zerop d) (mktree (mknode b i (heuristic-score m b)) nil))
( t (mktree n
(mapcar #'(lambda (n1) (xtree s m1 n1 (1- d)))
(mk-children m n) ) ))
) ) )
; -----------MK-CHILDREN: main function for building a game-tree -----------
(defun mk-children (m n) ; MARK x OXO-NODE -> OXO-NODE-list
"From (board node) creates list of possible next-boards, then
changes them into nodes.
The 'currently unknown' board-score is t, meaning unassigned"
(let ((possibles (poss-boards m (board n) ) ) )
(mapcar #'(lambda (b i) (mknode b i t)) ; create a child-node
(car possibles) ; .. over list of boards
(cadr possibles) ) )) ; .. and list of moves
(defun poss-boards (m b) ; MARK x BOARD -> BOARD-list x Nat-list
"Creat next poss boards for 'mark' m from board b, + list of poss moves"
(let* ((remaining-moves (remove 'O (remove 'X b))) ; example (2 5 6 8)
; "use remaining-moves to make copies of board b, then insert m"
(pre-boards (mapcar #'(lambda (n) b) remaining-moves))
(child-boards (mapcar #'(lambda (n b1) (substitute m n b1))
remaining-moves pre-boards)) )
(list child-boards remaining-moves) ) )
; test: (poss-boards 'X *initial-board*)
; ----- TEST XTREE -----
; test: (xtree 'X 'X *initial-node* 0)
; test: (pprint (xtree 'X 'X *initial-node* 0)) ; one level deep for X
; test: (pprint (xtree 'X 'X *initial-node* 5)) ; first wins for X
;;
;; ------------------------ TREE-BUILDING MINIMAX --------------------------
;;
;; --- This version of minimax rebuilds the tree, updated with
;; --- minimax scores and best move. (First found. Perhaps Random better?)
(defun txminimax (tree maxp) ; TREE x Bool -> TREE
"Traverses tree, rebuilds it using minimax with leaf-scores from xtree.
We always start with tree root as maxplayer (maxp) = true as any
player invoking this function always wants to win."
(let* ( (n1 (tree-node tree))
(minp (not maxp))
(ch1 (mapcar #'(lambda (tr) (txminimax tr minp)) (tree-children tree)) )
(b1 (board n1))
(move1 (cmove n1))
(score1 (score n1)) )
(cond ((leafp tree) (mktree (mknode b1 move1 score1) ch1) ) ; xtree leaf-score
( maxp (mktree (mknode b1 move1 (tmax-child-value ch1) ) ch1) )
( minp (mktree (mknode b1 move1 (tmin-child-value ch1) ) ch1) ) )
) )
(defun tmax-child-value (ch1) ; TREE-list -> Nat
" Finds the maximum score-value of the children of the root-node of tree"
(apply #'max (mapcar #'(lambda (tr1) (score (tree-node tr1))) ch1) ) )
(defun tmin-child-value (ch1) ; TREE-list -> Nat
" Finds the minimum score-value of the children of the root-node of tree"
(apply #'min (mapcar #'(lambda (tr1) (score (tree-node tr1))) ch1) ) )
; test: (pprint (txminimax (xtree 'X 'X *initial-node* 2) t) )
;; -------------------- GAME FRAMEWORK -----------------------------------
;;
;; The game is about boards, not nodes or trees. Those are purely internal
;; to tree-search players.
;;
;; The function 'play' takes functional arguments as players
;;
(defun play-game (m b p1 p2) ; MARK x BOARD x PLAYER x PLAYER -> BOARD
"This is the top-level function to play oxo, p1 plays first and so 'X' "
(cond ((is-win m b) (format t "Win for ~a~2%" m) (print-board b))
((is-win (opp m) b) (format t "Win for ~a~2%" (opp m)) (print-board b))
((is-draw b) (format t "It's a draw ~2%" ) (print-board b) )
( t (format t "~%")
(let ((board1 (next-board m b p1)))
(play-game (opp m) board1 p2 p1) ) )) )
(defun next-board (m b p) ; MARK x BOARD x PLAYER -> BOARD
(print-board b)
(let ((next (funcall p m b)))
(substitute m next b) ) )
; ------------- HUMAN PLAYER --------------------------------
(defun human (m b) ; (MARK x BOARD -> NAT) ... aka type PLAYER
(format t "~%")
(format t "You play: ~a~%" m)
(print "Please enter an available number: ")
(read) )
; test: (play-game 'X *initial-board* #'human #'human)
; ------------- RANDOM PLAYER --------------------------------
(defun rand-player (m b) ; (MARK x BOARD -> NAT)
(let* ((remaining-numbers (remove 'O (remove 'X b)))
(n (length remaining-numbers))
(random-index (random n)) )
(format t "~%")
(format t "Rand is playing: ~a~%" m)
(sleep 2)
(nth random-index remaining-numbers)) )
; test: (rand-player 'X *arbitrary*)
; test: (play-game 'X *initial-board* #'human #'rand-player)
; test: (play-game 'X *initial-board* #'rand-player #'human)
; ------------- MINIMAX PLAYER --------------------------------
(defvar *depth* 4) ; minimax search depth
(defun mx-player-X (m b) ; MARK x BOARD -> Nat Plays X
(mx-player 'X m b))
(defun mx-player-O (m b) ; MARK x BOARD -> Nat Plays O
(mx-player 'O m b))
(defun mx-player (s m b) ; (MARK x MARK x BOARD -> Nat)
"Builds a game tree to *depth*, uses minimax for best move"
(let* ((initial-node (mknode b 9 t) )
(initial-tree (xtree s m initial-node *depth*))
(mx-tree (txminimax initial-tree t)) )
(format t "~%")
(format t "MX is playing: ~a~2%" m)
(if (< *depth* 4) (sleep 3) (sleep 1))
(choose-mx-move mx-tree)) )
(defun choose-mx-move (tree) ; TREE -> Nat
(let* ( (n1 (tree-node tree))
(ch1 (tree-children tree))
(best-score (score n1))
(child-nodes (mapcar #'tree-node ch1))
(move-score-pairs (mapcar 'cdr child-nodes)) )
(first (find best-score move-score-pairs :key #'second)) ) )
; ----- TEST -----
; test: (play-game 'X *initial-board* #'human #'mx-player-O)
; test: (play-game 'X *initial-board* #'mx-player-X #'human)
#|
; ----------------- MINIMAX TESTING (Historical bug) --------------------
; Bug: in b below, X plays 1 rather than 7. Easy win for O.
(setf b '(X 1 2 3 X 5 O 7 O)) ; -- X to play next
(print-board b)
; X | 1 | 2
; 3 | X | 5
; O | 7 | O
(setf n (mknode b 9 T))
(setf initial-tree (xtree 'X 'X n *depth*))
(pprint initial-tree)
(setf mx-tree (txminimax initial-tree t))
(setf mx-tree (txminimax (xtree 'X 'X (mknode b 9 T) *depth*) t) )
(pprint mx-tree)
(setf nodes (mapcar #'car (tree-children mx-tree)))
(pprint nodes)
(mx-player 'X 'X b)
(choose-mx-move mx-tree)
(play-game 'X b #'mx-player-X #'human)
; ------- test board this works correctly -----
(setf b1 '(X 1 2 3 X O O X O)) ; -- X to play next
(print-board b1)
;
; X | 1 | 2 -- X plays 1 and win. If X plays 2
; 3 | X | O -- If O plays 3, X plays 1 and wins
; O | X | O -- so O will play 1 => draw
;
(setf mx-tree1 (txminimax (xtree 'X 'X (mknode b1 9 T) *depth*) t) )
(pprint mx-tree1)
|#
;---------------------------- END -----------------------------