| PasteRack.org | ||
| Paste # 2589 | ||
| 2016-04-29 18:47:33 | ||
Fork as a new paste. | ||
Paste viewed 173 times. | ||
Tweet | ||
Embed: | ||
#lang racket
(require rackunit rackunit/text-ui racket/random (only-in racket/gui/base message-box) 2htdp/image 2htdp/universe lang/posn)
(struct world (tree selected first) #:transparent)
(struct pos (x y) #:transparent)
(define-values (PLAYER0 PLAYER1 UNCLAIMED AI-DEPTH WIDTH HEIGHT)
(values "X" "O" "-" 4 600 600))
(define EMPTY-BOARD
(list (list UNCLAIMED UNCLAIMED UNCLAIMED)
(list UNCLAIMED UNCLAIMED UNCLAIMED)
(list UNCLAIMED UNCLAIMED UNCLAIMED)))
(define-values (ttt-tree ttt-tree-board ttt-tree-moves ttt-tree?)
(let ()
(struct ttt-tree (board moves) #:transparent)
(values ttt-tree ttt-tree-board (lambda (t) (force (ttt-tree-moves t))) ttt-tree?)))
;; Gets the winner of a board, of #f if there is none
(define (winner board)
(or
(ormap (lambda (row) (if (and (all-equal? row) (not (equal? (first row) UNCLAIMED))) (first row) #f)) board) ; Horizontal
(ormap (lambda (i) (if ; Vertical
(and (all-equal?
(map (lambda (j) (list-ref (list-ref board j) i))
(stream->list (in-range (length board)))))
(not (equal? UNCLAIMED (list-ref (first board) i))))
(list-ref (first board) i) #f))
(stream->list (in-range (length board))))
(if ; Diagonal
(and (all-equal?
(map (lambda (i) (list-ref (list-ref board i) i))
(stream->list (in-range (length board)))))
(not (equal? (first (first board)) UNCLAIMED)))
(first (first board)) #f)
(if ; Diagonal cont.
(and (all-equal?
(map (lambda (i) (list-ref (reverse (list-ref board i)) i))
(stream->list (in-range (length board)))))
(not (equal? (last (first board)) UNCLAIMED)))
(last (first board)) #f)))
;; Finds all free fields e.g '((- 0 -) (x y z) (- 0 -)) => '((0 0) (0 2) (2 0) (2 2))
(define (find-free-fields board)
(for*/list ([x (in-range (length board))]
[y (in-range (length (first board)))]
#:when (equal? (list-ref (list-ref board x) y) UNCLAIMED))
(list x y)))
;; Returns a new board with the specified field taken by the specified player
(define (board-take-field board player field)
(map (lambda (i) (map
(lambda (j)
(if (equal? (list i j) field)
player
(list-ref (list-ref board i) j)))
(stream->list (in-range (length (first board))))))
(stream->list (in-range (length board)))))
;; Returns true if all the values in lst are equal
(define (all-equal? lst)
(for/and
([i (in-permutations lst)])
(equal? (first i) (second i))))
;; Generates a game tree; uses delay so it dosen't lag like s***
(define (generate-ttt-tree player1 player2)
(define (generate-tree board player opponent)
(ttt-tree board (generate-moves board player opponent)))
(define (generate-moves board0 player opponent)
(define free-fields (find-free-fields board0))
(delay (for/list ([f free-fields])
(define board1 (board-take-field board0 player f))
(list f (generate-tree board1 opponent player)))))
(generate-tree EMPTY-BOARD player1 player2))
;; Impliments the minimax algorithm
(define (minimax tree player depth)
(define (generate-score tree player depth)
(define won (winner (ttt-tree-board tree)))
(if (<= depth 0) 0
(+ (cond
[(false? won) 0]
[(equal? won player) 1]
[else -1])
(apply +
(for/list ([t (ttt-tree-moves tree)])
(generate-score (second t) player (sub1 depth)))))))
(for/fold
([scores '()]
[moves '()])
([t (ttt-tree-moves tree)])
(values (append scores (list (generate-score (second t) player depth))) (append moves (list (first t))))))
;; Invokes the minimax function to return the next level in the tree with the highest score
(define (ai tree player [depth AI-DEPTH])
(define board (ttt-tree-board tree))
(define-values (scores moves)
(minimax tree player depth))
(if (= (length scores) 0)
tree
(let ([best (apply max scores)])
(random-ref
(for/fold ([best-moves '()])
([i (in-range (length scores))])
(if (equal? best (list-ref scores i))
(append best-moves (list (second (list-ref (ttt-tree-moves tree) i))))
best-moves))))))
;
;
;
; ;;;; ; ;
; ;; ;; ; ;
; ; ;
; ; ; ;;; ;;;;; ; ;;;; ; ;;;;; ;;; ;;;; ;;;;;
; ; ;; ; ; ;; ;; ; ;; ;; ; ; ; ;; ;
; ; ; ; ; ; ; ; ; ; ;
; ; ;;; ; ;;;;;; ; ; ; ; ; ; ;;
; ; ; ; ;; ; ; ; ; ; ; ; ;;;;;;
; ; ; ; ; ; ; ; ; ; ; ; ;;
; ; ; ; ; ;; ; ; ; ; ; ; ;
; ;; ; ; ;; ;;; ;; ; ; ; ; ; ; ; ;;
; ;;;; ; ;;;;; ; ; ;;;; ; ; ;;;;;;; ;;;; ;;;;;
; ;
; ;
; ;
;
;; Some constants
(define SELECT (circle (/ WIDTH 6) "outline" "black"))
(define X (text PLAYER0 (/ WIDTH 3) "black"))
(define O (text PLAYER1 (/ WIDTH 3) "black"))
(define EMPTY-TILE (square (/ WIDTH 3) "solid" (color 0 0 0 0)))
(define TILE (square (/ WIDTH 3) "outline" "black"))
(define BACKGROUND (beside (above TILE TILE TILE) (above TILE TILE TILE) (above TILE TILE TILE)))
;; Handles a turn
(define (turn w)
(if (equal?
(list-ref (list-ref (ttt-tree-board (world-tree w)) (pos-y (world-selected w))) (pos-x (world-selected w))) UNCLAIMED)
(world
(let ([players-move
(second (ormap (lambda (t)
(if (equal?
(board-take-field (ttt-tree-board (world-tree w)) PLAYER0 (list (pos-y (world-selected w)) (pos-x (world-selected w))))
(ttt-tree-board (second t))) t #f))
(ttt-tree-moves (world-tree w))))])
(if (winner (ttt-tree-board players-move)) players-move (ai players-move PLAYER1)))
(world-selected w) (world-first w)) w))
;; Decides if the game is over or not
(define (end? w)
(if (or (winner (ttt-tree-board (world-tree w)))
(not (ormap (lambda (v) (ormap (lambda (v) (equal? v UNCLAIMED)) v)) (ttt-tree-board (world-tree w))))) #t #f))
;; Handles wrapping of the selector
(define (move old-pos x y)
(define new-x (+ (pos-x old-pos) x))
(define new-y (+ (pos-y old-pos) y))
(pos (cond
[(< new-x 0) 2]
[(> new-x 2) 0]
[else new-x])
(cond
[(< new-y 0) 2]
[(> new-y 2) 0]
[else new-y])))
;; Large rendering function...
(define (render w)
(define board (map (lambda (v)
(map (lambda (v)
(cond
[(equal? v PLAYER0) X]
[(equal? v PLAYER1) O]
[else EMPTY-TILE])) v))
(ttt-tree-board (world-tree w))))
(place-image SELECT
(+ (* (pos-x (world-selected w)) (/ WIDTH 3)) (/ HEIGHT 6))
(+ (* (pos-y (world-selected w)) (/ HEIGHT 3)) (/ HEIGHT 6))
(place-images
(list (first (first board)) (second (first board)) (third (first board))
(first (second board)) (second (second board)) (third (second board))
(first (third board)) (second (third board)) (third (third board)))
(map (lambda (v) (make-posn (- (posn-x v) (/ WIDTH 6)) (- (posn-y v) (/ HEIGHT 6))))
(list (make-posn (/ WIDTH 3) (/ HEIGHT 3)) (make-posn (* (/ WIDTH 3) 2) (/ HEIGHT 3)) (make-posn WIDTH (/ HEIGHT 3))
(make-posn (/ WIDTH 3) (* (/ HEIGHT 3) 2)) (make-posn (* (/ WIDTH 3) 2) (* (/ HEIGHT 3) 2)) (make-posn WIDTH (* (/ HEIGHT 3) 2))
(make-posn (/ WIDTH 3) HEIGHT) (make-posn (* (/ WIDTH 3) 2) HEIGHT) (make-posn WIDTH HEIGHT)))
BACKGROUND)))
(define (render-last-scene w)
(define won (winner (ttt-tree-board (world-tree w))))
(place-image
(cond
[(equal? won PLAYER0) (text "YOU WIN" (/ WIDTH 5) "green")]
[(equal? won PLAYER1) (text "YOU LOSE" (/ WIDTH 6) "red")]
[else (text "TIE" 255 "orange")])
(/ WIDTH 2) (/ HEIGHT 2) (render w)))
;; Handles... keys
(define (handle-keys w key)
(case key
[("up" "w") (world (world-tree w) (move (world-selected w) 0 -1) (world-first w))]
[("down" "s") (world (world-tree w) (move (world-selected w) 0 1) (world-first w))]
[("left" "a") (world (world-tree w) (move (world-selected w) -1 0) (world-first w))]
[("right" "d") (world (world-tree w) (move (world-selected w) 1 0) (world-first w))]
[("\r") (turn w)]
[else w]))
;; Tests
;; TODO: finish test suite
(module+ test
(run-tests
(test-suite "Tic Tac Toe Tests"
(test-case "winner"
(check-false (winner EMPTY-BOARD) "true on empty board")
(check-equal? (winner (list (list PLAYER0 PLAYER0 PLAYER0) (list UNCLAIMED UNCLAIMED UNCLAIMED) (list UNCLAIMED UNCLAIMED UNCLAIMED))) PLAYER0 "horizontal")
(check-equal? (winner (list (list PLAYER0 UNCLAIMED UNCLAIMED) (list PLAYER0 UNCLAIMED UNCLAIMED) (list PLAYER0 UNCLAIMED UNCLAIMED))) PLAYER0 "vertical")
(check-equal? (winner (list (list PLAYER0 UNCLAIMED UNCLAIMED) (list UNCLAIMED PLAYER0 UNCLAIMED) (list UNCLAIMED UNCLAIMED PLAYER0))) PLAYER0 "diagonal 1")
(check-equal? (winner (list (list UNCLAIMED UNCLAIMED PLAYER0) (list UNCLAIMED PLAYER0 UNCLAIMED) (list PLAYER0 UNCLAIMED UNCLAIMED))) PLAYER0 "diagonal 2")))
'verbose))
;; Main
(define (play wins losses ties first)
(define won
(winner
(ttt-tree-board (world-tree
(big-bang (cond
[(equal? first 'cancel) (exit 0)]
[(equal? first 'yes) (world (generate-ttt-tree PLAYER0 PLAYER1) (pos 1 1) PLAYER0)]
[(equal? first 'no) (world (ai (generate-ttt-tree PLAYER1 PLAYER0) PLAYER1) (pos 1 1) PLAYER1)])
(name "Tick Tack Toe")
(on-key handle-keys)
(on-draw render)
(stop-when end? render-last-scene))))))
(define wins-losses-ties
(cond
[(equal? won PLAYER0) (list (+ wins 1) losses ties)]
[(equal? won PLAYER1) (list wins (+ losses 1) ties)]
[else (list wins losses (+ ties 1))]))
(define play-again (message-box "Tick Tack Toe"
(apply format (append '("Would you like to play again?\nYou have won ~s times, lost ~s times, and tied ~s times.") wins-losses-ties)) #f '(yes-no)))
(cond
[(equal? play-again 'cancel) (exit 0)]
[(equal? play-again 'yes) (apply play (append wins-losses-ties (list (message-box "Tick Tack Toe" "Would you like to go first?" #f '(yes-no)))))]
[(equal? play-again 'no) wins-losses-ties]))
(module+ main
(define first (message-box "Tick Tack Toe" "Would you like to go first?" #f '(yes-no)))
(play 0 0 0 first))