Skip to content

Instantly share code, notes, and snippets.

@Battleroid
Forked from trhura/tic-tac-toe.lisp
Created February 9, 2016 08:47
Show Gist options
  • Save Battleroid/7d878edd6d082ec1cd01 to your computer and use it in GitHub Desktop.
Save Battleroid/7d878edd6d082ec1cd01 to your computer and use it in GitHub Desktop.
tic-tac-toe AI using two-ply minmax in racket (scheme)
#lang scheme/gui
(define new-game #t)
(define game-finished #f)
(define user-move #\X)
(define computer-move #\O)
(define move-count 0)
(define start-move user-move)
(define current-move start-move)
(define main-board (make-vector 9 #\space))
(define win-paths '((0 1 2) (0 3 6) (0 4 8) (3 4 5) (1 4 7) (2 4 6) (6 7 8) (2 5 8)))
(define win-move '(0 0 0))
(define (prepare-new-game)
;; Reset Data for a new game
(let ((user-first (send start-menu is-checked?)))
;; set start move according to menu
(if user-first
(set! start-move user-move)
(set! start-move computer-move))
;; reset board and other data
(set! main-board (make-vector 9 #\Space))
(set! current-move start-move)
(set! game-finished #f)
(set! move-count 0)
(set! new-game #f)
;; Reset Canvases
(for [(canvas canvases)]
(send canvas set-character #\Space)
(send canvas set-color (make-object color% "gray"))
(send canvas refresh))
(send frame refresh)
;; make a computer move, if supposed to
(unless user-first
(computer-moves))))
(define (make-move-at pos)
;; Make move at pos, return #f if pos is not empty
(if (empty-position? main-board pos)
(begin
(send (list-ref canvases pos) set-character current-move)
(send (list-ref canvases pos) refresh)
(vector-set! main-board pos current-move)
(set! move-count (+ 1 move-count))
(if (has-won? main-board current-move)
(end-game)
(toggle-current-move)))
#f))
(define (end-game)
;; Color Winning moves
;; Lock game board setting game-finished true
(for ([i win-move])
(send (list-ref canvases i) set-color (make-object color% "black"))
(send (list-ref canvases i) refresh))
(set! game-finished #t)
(set! new-game #t))
(define (empty-position? board pos)
(char=? (vector-ref board pos) #\Space))
(define (other-move move)
;; return the reverse of move
(if (char=? move #\X) #\O #\X))
(define (toggle-current-move)
;; toggle current move between X and O
(set! current-move (other-move current-move)))
(define (toggle-user-move)
;; toggle user move between X and O
(set! user-move (other-move user-move)))
(define (toggle-computer-move)
;; toggle computer move between X and O
(set! computer-move (other-move computer-move)))
(define (get-legal-moves board)
;; Get the unoccupied (empty) positions on board
(for/list ((i '(0 1 2 3 4 5 6 7 8))
#:when (char=? (vector-ref board i) #\Space))
i))
(define (full-board? board)
;; Check whether the board is full or not
(not (for/or ((v board))
(char=? v #\Space))))
(define-syntax operate-on-wpath
;; Execute the given func on each of winning paths, (0 1 2), (0 3 6), (0 4 8) ...
;; For example, (operate-on-wpath +) will sequentially run (+ 0 1 2) (+ 0 3 6) ....
(syntax-rules ()
((operate-on-wpath func)
(for ((lst win-paths))
(func (list-ref lst 0) (list-ref lst 1) (list-ref lst 2))))))
(define (check-possible-winning-paths board move)
;; Return total number of possible winning paths
(let ((paths 0))
(let-syntax
((possible-winning-path?
;; We are going to operate this on win-paths
;; If any path in (win-paths), has the opposite of move
;; it is not possible for move to win in that path.
;; Otherwise, it is a potential win move. Increase paths.
(syntax-rules ()
((is-empty-or-move p1 p2 p3)
(when (not (or (char=? (vector-ref board p1) (other-move move))
(char=? (vector-ref board p2) (other-move move))
(char=? (vector-ref board p3) (other-move move))))
(set! paths (+ paths 1)))))))
(operate-on-wpath possible-winning-path?)
paths)))
(define (is-more-likely-to-win? board move)
;; Evaluation function, only by using possible winning paths, is not good enough
;; That is the user still beat the computer ...
;; So this one check any path of winning paths has two of moves
;; if so increase score by two ...
(let ((score 0))
(let-syntax
((path-has-two-move
(syntax-rules ()
((path-has-two-move p1 p2 p3)
(when (or (and (char=? (vector-ref board p1)
(vector-ref board p2) move)
(not (char=? (vector-ref board p3) (other-move move))))
(and (char=? (vector-ref board p1)
(vector-ref board p3) move)
(not (char=? (vector-ref board p2) (other-move move))))
(and (char=? (vector-ref board p2)
(vector-ref board p3) move)
(not (char=? (vector-ref board p1) (other-move move)))))
(set! score (+ score 1)))))))
(operate-on-wpath path-has-two-move))
score))
(define (has-won? board move)
;; Decide whether the given move ( X or O ) has won on board
;; If there is a winning move, set win-move, so that we could highlight
(let-syntax ((has-won-syn
(syntax-rules ()
((has-won-syn p1 p2 p3)
(if (char=? (vector-ref board p1)
(vector-ref board p2)
(vector-ref board p3) move)
(set! win-move (list p1 p2 p3))
#f)))))
(for/or ((pos win-paths))
(has-won-syn (list-ref pos 0) (list-ref pos 1) (list-ref pos 2)))))
(define (get-position-by-minmax)
;;; Implementation of two-ply minmax
(letrec ((position 0)
(eval-function
(lambda (board move)
(let ((m (check-possible-winning-paths board move))
(o (check-possible-winning-paths board (other-move move))))
(let ((lm (is-more-likely-to-win? board move))
(lo (is-more-likely-to-win? board (other-move move))))
(- (+ m (* 2 lm)) (+ o (* 2 lo)))))))</code></pre>
<pre><code class="lisp">
(max-turn (lambda (board move depth)
(cond
((has-won? board (other-move move)) -10)
((or (full-board? board)
(= depth 2)) (eval-function board move))
(else
(let ((maximum -1024))
(for ((i (get-legal-moves board)))
(let ((vec (make-vector 9 #\Space)))
(vector-copy! vec 0 board)
(vector-set! vec i move)
(let ((tmp (min-turn vec (other-move move) (+ 1 depth))))
(when (&gt; tmp maximum)
(set! maximum tmp)
(when (= depth 0)
(set! position i))))))
maximum)))))
(min-turn (lambda (board move depth)
(cond
((has-won? board (other-move move)) 10)
((or (full-board? board)
(= depth 2)) (eval-function board move))
(else
(let ((minimum 1024))
(for ((i (get-legal-moves board)))
(let ((vec (make-vector 9 #\Space)))
(vector-copy! vec 0 board)
(vector-set! vec i move)
(let ((tmp (max-turn vec (other-move move) (+ 1 depth))))
(when (&lt; tmp minimum)
(set! minimum tmp)))))
minimum))))))
(max-turn main-board current-move 0)
position))
(define (computer-moves)
;; Make a computer move based on minmax algorithm
(unless (full-board? main-board)
(make-move-at (get-position-by-minmax))))
;;; Gui ;;;
(define frame
(new frame%
[label "Tic Tac Toe"]
[width 400]
[height 400]))
(define menu-bar
(new menu-bar%
[parent frame]))
(define file-menu
(new menu%
[label "&amp;File"]
[parent menu-bar]))
(define new-menu
(new menu-item%
[label "&amp;New Game"]
[parent file-menu]
[callback (lambda (i e) (prepare-new-game))]
[shortcut #\n]))
(define quit-menu
(new menu-item%
[label "&amp;Quit"]
[parent file-menu]
[callback (lambda (i e) (send frame show #f))]
[shortcut #\q]))
(define edit-menu
(new menu%
[label "&amp;Edit"]
[parent menu-bar]))
(define use-menu
(new checkable-menu-item%
[label "&amp;Use X"]
[parent edit-menu]
[checked #t]
[callback (lambda (i e)
(toggle-user-move)
(toggle-computer-move))]))
(define start-menu
(new checkable-menu-item%
[label "&amp;Start First"]
[parent edit-menu]
[checked #t]
[callback (lambda (i e)
(when (or new-game game-finished)
(prepare-new-game)))]))
(define help-menu
(new menu%
[label "&amp;Help"]
[parent menu-bar]))
(define about-menu
(new menu-item%
[label "A&amp;bout"]
[parent help-menu]
[callback (lambda (i e) (void))]))
(define main-pane
(new vertical-pane%
[parent frame]
[vert-margin 5]
[horiz-margin 5]
[spacing 5]))
(define upper-pane
(new horizontal-pane%
[parent main-pane]
[spacing 5]))
(define middle-pane
(new horizontal-pane%
[parent main-pane]
[spacing 5]))
(define lower-pane
(new horizontal-pane%
[parent main-pane]
[spacing 5]))
(define canvas-box%
(class canvas%
(init-field [character #\Space]
[position 0]
[color (make-object color% "gray")])
(inherit get-dc)
(define/override (on-event e)
(when (equal? (send e get-event-type) 'left-down)
;; When left-button is pressed
(unless (or (full-board? main-board) game-finished)
(when new-game
;; If it is a new game, aka first click, load settings
(prepare-new-game))
(when (make-move-at position)
;; make-move-at return #f if the position is not empty
(unless game-finished
;; If the game is not finished yet, computer turn
(computer-moves))))
(let ((dc (get-dc)))
(send dc clear))
(send this refresh)))
(define/override (on-paint)
;; Handles Drawing of char X or O according to color
(let ((dc (get-dc)))
(let-values (((x y) (send this get-size)))
(send dc set-text-foreground color)
(send dc set-font (make-object font% 50 'default))
(send dc draw-text (string character) (/ (- x 50) 2) (/ (- y 75) 2)))))
(define/public (set-color c)
(set! color c))
(define/public (set-character char)
(set! character char))
(super-new)))
(define canvases
(let ((canvas-one (new canvas-box%
[position 0]
[parent upper-pane]))
(canvas-two (new canvas-box%
[position 1]
[parent upper-pane]))
(canvas-three (new canvas-box%
[position 2]
[parent upper-pane]))
(canvas-four (new canvas-box%
[position 3]
[parent middle-pane]))
(canvas-five (new canvas-box%
[position 4]
[parent middle-pane]))
(canvas-six (new canvas-box%
[position 5]
[parent middle-pane]))
(canvas-seven (new canvas-box%
[position 6]
[parent lower-pane]))
(canvas-eight (new canvas-box%
[position 7]
[parent lower-pane]))
(canvas-nine (new canvas-box%
[position 8]
[parent lower-pane])))
(list canvas-one canvas-two canvas-three
canvas-four canvas-five canvas-six
canvas-seven canvas-eight canvas-nine)))
(send frame center 'both) ;; position frame at center of the screen
(send frame show #t) ;; display frame
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment