Skip to content

Commit

Permalink
format code
Browse files Browse the repository at this point in the history
  • Loading branch information
Ethan Stanley committed Apr 17, 2024
1 parent 45fd7da commit 85777a6
Show file tree
Hide file tree
Showing 2 changed files with 132 additions and 121 deletions.
156 changes: 78 additions & 78 deletions checkers.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,11 +7,9 @@
(define W 3)
(define B 4)

;(define max-depth 6)

(struct state (board turn jumper won) #:transparent)
(struct square (row col) #:transparent)
(struct move (from to) #:transparent)
(struct square (row col) #:transparent)

(define start-board (list (list 0 w 0 w 0 w 0 w)
(list w 0 w 0 w 0 w 0)
Expand All @@ -22,16 +20,6 @@
(list 0 b 0 b 0 b 0 b)
(list b 0 b 0 b 0 b 0)))



(define board2 (list (list 0 0 0 0 0 0 0 0)
(list 0 0 0 0 0 0 0 0)
(list 0 0 0 0 0 0 0 0)
(list 0 0 0 0 0 0 0 0)
(list 0 0 0 0 w 0 0 0)
(list 0 0 0 w 0 b 0 0)
(list 0 0 b 0 0 0 0 0)
(list 0 0 0 0 0 0 0 0)))
(define start-state (state start-board b #f #f))

(define (piece state square)
Expand All @@ -54,7 +42,7 @@
[(equal? player B) W]))

(define (do-jump board move)
(if (equal? (abs (- (square-row (move-from move)) (square-row (move-to move)))) 2)
(if (jump? move)
(update-board board
(square (quotient (+ (square-row (move-from move)) (square-row (move-to move))) 2)
(quotient (+ (square-col (move-from move)) (square-col (move-to move))) 2))
Expand Down Expand Up @@ -98,15 +86,15 @@
W
(if (equal? piece b)
B
piece)))
piece)))

(define (same-color? piece1 piece2)
(equal? (promote piece1) (promote piece2)))

(define (legal-moves game-state)
(let* ([player (state-turn game-state)]
[jumper (state-jumper game-state)]
[board (if (equal? player b) (reverse (state-board game-state)) (state-board game-state))]
[jumper (state-jumper game-state)]
[board (if (equal? player b) (reverse (state-board game-state)) (state-board game-state))]
[right-jumps (for/list ([r (range 8)]
#:when #t
[c (range 8)]
Expand All @@ -121,101 +109,113 @@
(equal? (get board (+ r 2) (- c 2)) 0)
(same-color? (get board (+ r 1) (- c 1)) (opponent player))))
(move (square r c) (square (+ r 2) (- c 2))))]

[king-left-jumps (for/list ([r (range 8)]
#:when #t
[c (range 8)]
#:when (and (equal? (get board r c) (promote player))
(equal? (get board (- r 2) (- c 2)) 0)
(same-color? (get board (- r 1) (- c 1)) (opponent player))))
(move (square r c) (square (- r 2) (- c 2))))]
[king-right-jumps (for/list ([r (range 8)]
#:when #t
[c (range 8)]
#:when (and (equal? (get board r c) (promote player))
(equal? (get board (- r 2) (+ c 2)) 0)
(same-color? (get board (- r 1) (+ c 1)) (opponent player))))
(move (square r c) (square (- r 2) (+ c 2))))]
[king-right-steps (if (equal? 0 (length (append left-jumps right-jumps king-left-jumps king-right-jumps)))
(for/list ([r (range 8)]
[king-left-jumps (for/list ([r (range 8)]
#:when #t
[c (range 8)]
#:when (and (equal? (get board r c) (promote player))
(equal? (get board (- r 1) (+ c 1)) 0)))
(move (square r c) (square (- r 1) (+ c 1))))
(list))]
[king-left-steps (if (equal? 0 (length (append left-jumps right-jumps king-left-jumps king-right-jumps)))
(for/list ([r (range 8)]
#:when #t
[c (range 8)]
#:when (and (equal? (get board r c) (promote player))
(equal? (get board (- r 1) (- c 1)) 0)))
(move (square r c) (square (- r 1) (- c 1))))
(list))]
[right-steps (if (equal? 0 (length (append left-jumps right-jumps king-left-jumps king-right-jumps)))
(equal? (get board (- r 2) (- c 2)) 0)
(same-color? (get board (- r 1) (- c 1)) (opponent player))))
(move (square r c) (square (- r 2) (- c 2))))]
[king-right-jumps (for/list ([r (range 8)]
#:when #t
[c (range 8)]
#:when (and (equal? (get board r c) (promote player))
(equal? (get board (- r 2) (+ c 2)) 0)
(same-color? (get board (- r 1) (+ c 1)) (opponent player))))
(move (square r c) (square (- r 2) (+ c 2))))]
[no-jumps-possible (equal? 0 (length (append left-jumps right-jumps king-left-jumps king-right-jumps)))]
[king-right-steps (if no-jumps-possible
(for/list ([r (range 8)]
#:when #t
[c (range 8)]
#:when (and (equal? (get board r c) (promote player))
(equal? (get board (- r 1) (+ c 1)) 0)))
(move (square r c) (square (- r 1) (+ c 1))))
(list))]
[king-left-steps (if no-jumps-possible
(for/list ([r (range 8)]
#:when #t
[c (range 8)]
#:when (and (equal? (get board r c) (promote player))
(equal? (get board (- r 1) (- c 1)) 0)))
(move (square r c) (square (- r 1) (- c 1))))
(list))]
[right-steps (if no-jumps-possible
(for/list ([r (range 8)]
#:when #t
[c (range 8)]
#:when (and (same-color? (get board r c) player) (equal? (get board (+ r 1) (+ c 1)) 0)))
(move (square r c) (square (+ r 1) (+ c 1))))
(list))]
[left-steps (if (equal? 0 (length (append left-jumps right-jumps king-left-jumps king-right-jumps)))
[left-steps (if no-jumps-possible
(for/list ([r (range 8)]
#:when #t
[c (range 8)]
#:when (and (same-color? (get board r c) player) (equal? (get board (+ r 1) (- c 1)) 0)))
(move (square r c) (square (+ r 1) (- c 1))))
(list))]
[all-moves (if (equal? player b)
(map reverse-move (append right-jumps left-jumps right-steps left-steps king-left-jumps king-right-jumps king-left-steps king-right-steps))
(append right-jumps left-jumps right-steps left-steps king-right-jumps king-left-jumps king-left-steps king-right-steps))]
[jumper-moves (if jumper
(filter (lambda (move) (and (jump? move) (equal? (move-from move) jumper))) all-moves)
all-moves)])
jumper-moves))

(map reverse-move (append right-jumps left-jumps right-steps left-steps king-left-jumps king-right-jumps king-left-steps king-right-steps))
(append right-jumps left-jumps right-steps left-steps king-right-jumps king-left-jumps king-left-steps king-right-steps))]
[jumper-moves (if jumper
(filter (lambda (move) (and (jump? move) (equal? (move-from move) jumper))) all-moves)
all-moves)])
jumper-moves))

; value of each piece according to white player
; used in heuristic
(define (value-of piece)
(cond [(equal? piece w) 1]
[(equal? piece b) -1]
[(equal? piece W) 2]
[(equal? piece B) -2]
[else 0]))

; estimate utility of board for white player
; 0 -> tied
; > 0 -> good for white
; < 0 -> good for black
(define (heuristic game-state)
(apply + (map (lambda (row) (apply + row)) (map (lambda (row) (map (lambda (piece) (value-of piece)) row)) (state-board game-state)))))

;(define (heuristic game-state)
; (- (apply + (map (lambda (row) (count (lambda (piece) (equal? (promote piece) W)) row)) (state-board game-state)))
; (apply + (map (lambda (row) (count (lambda (piece) (equal? (promote piece) B)) row)) (state-board game-state)))))

; if white's turn, return max state of all legal moves
; if blacks turn, return min
(apply +
(map (lambda (row) (apply + row))
(map (lambda (row) (map (lambda (piece) (value-of piece))
row))
(state-board game-state)))))

; if white's turn:
; return max utility over next possible states
; if blacks turn:
; return min
(define (state-utility-for-white game-state max-depth depth)
(if (equal? depth max-depth)
(heuristic game-state)
(let ([moves (legal-moves game-state)])
(if (equal? w (state-turn game-state))
(if (empty? moves) -100 (apply max (map (lambda (state) (state-utility-for-white state max-depth (+ 1 depth))) (map (lambda (move) (try-move game-state move)) moves))))
(if (empty? moves) 100 (apply min (map (lambda (state) (state-utility-for-white state max-depth (+ 1 depth))) (map (lambda (move) (try-move game-state move)) moves))))))))


; minimax player
; have:
; legal moves : state -> list(move)
; try-move : state, move -> state
(if (empty? moves)
-100
(apply max
(map (lambda (state) (state-utility-for-white state max-depth (+ 1 depth)))
(map (lambda (move) (try-move game-state move))
moves))))
(if (empty? moves)
100
(apply min
(map (lambda (state) (state-utility-for-white state max-depth (+ 1 depth)))
(map (lambda (move) (try-move game-state move))
moves))))))))

; return best move in this state
; iterate over possible moves
; estimate utility for white for each move using minimax
; return argmax if white, argmin if black
(define (best-move game-state search-depth)
(let* ([choices (legal-moves game-state)])
(if (equal? (state-turn game-state) w)
(argmax (lambda (move) (state-utility-for-white (try-move game-state move) search-depth 0)) choices)
(argmin (lambda (move) (state-utility-for-white (try-move game-state move) search-depth 0)) choices))))
(argmax (lambda (move) (state-utility-for-white (try-move game-state move) search-depth 0)) choices)
(argmin (lambda (move) (state-utility-for-white (try-move game-state move) search-depth 0)) choices))))

(define (print-board board)
(begin (for ([row board])
(begin (display row)
(display "\n")))
(display "\n")))

(define (print-moves moves)
(for ([board moves])
(print-board board)))

(display "\n")))
97 changes: 54 additions & 43 deletions gui.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,88 +3,103 @@
(require racket/gui/base)
(require "checkers.rkt")

;; MUTABLE STATE
; state of the checkers game
(define state start-state)
; move selected by gui user
(define req-move (move #f #f))
; maximum depth of minimax search
(define search-depth 5)
;; END MUTABLE STATE

; diameter of pieces (pixels)
(define piece-size 75)

(define (y row)
(* piece-size row))
(define (x col)
(* piece-size col))

; callback when user clicks on the board
; if selected which piece should move, update req-move
; if selected where piece should move, send move to model
(define (select-square r c)
(if (move-from req-move)
(begin (set! req-move (move (move-from req-move) (square r c)))
(set! state (try-move state req-move))
(set! req-move (move #f #f))
(send canvas refresh))
(set! state (try-move state req-move))
(set! req-move (move #f #f))
(send canvas refresh))
(set! req-move (move (square r c) #f))))

; draw the board
; callback for canvas refresh event
(define (draw-state canvas dc)
(for ([pieces (state-board state)]
[row (range 0 (length (state-board state)))])
(draw-row canvas dc pieces row))
(send turn-indicator set-label (format "~a to move" (if (equal? w (state-turn state)) "White" "Red")))
;(send utility-indicator set-label (format "~a" (state-utility-for-white state 0)))
)
(send turn-indicator set-label (format "~a to move" (if (equal? w (state-turn state)) "White" "Red"))))

; ask model to compute best move and update the state
(define (ai-move)
(set! state (try-move state (best-move state search-depth)))
(set! state (try-move state (best-move state search-depth)))
(send canvas refresh))

(define (draw-row canvas dc pieces row)
(for ([piece pieces]
[col (range 0 (length pieces))])
(begin (if (equal? 0 (modulo (+ row col) 2))
(send dc set-brush "white" 'solid)
(send dc set-brush "black" 'solid))
(when (and (move-from req-move) (equal? row (square-row (move-from req-move))) (equal? (square-col (move-from req-move)) col))
(send dc set-brush "gray" 'solid))
(begin (if (equal? 0 (modulo (+ row col) 2)) ; checkerboard pattern
(send dc set-brush "white" 'solid)
(send dc set-brush "black" 'solid))
(when (and (move-from req-move)
(equal? row (square-row (move-from req-move)))
(equal? (square-col (move-from req-move)) col))
(send dc set-brush "gray" 'solid)) ; highlight selected piece with gray
(send dc draw-rectangle (x col) (y row) piece-size piece-size)
(when (equal? piece w) (send dc set-brush "white" 'solid)
(send dc draw-ellipse (x col) (y row) piece-size piece-size))
(when (equal? piece b) (send dc set-brush "red" 'solid)
(send dc draw-ellipse (x col) (y row) piece-size piece-size))
(when (equal? piece W) (send dc set-brush "white" 'solid)
(send dc draw-ellipse (x col) (y row) piece-size piece-size)
(send dc set-brush "black" 'solid)
(send dc draw-ellipse (x (+ 0.25 col)) (y (+ 0.25 row)) (* 0.5 piece-size) (* 0.5 piece-size)))
(when (equal? piece B) (send dc set-brush "red" 'solid)
(send dc draw-ellipse (x col) (y row) piece-size piece-size)
(send dc set-brush "black" 'solid)
(send dc draw-ellipse (x (+ 0.25 col)) (y (+ 0.25 row)) (* 0.5 piece-size) (* 0.5 piece-size))))))

(when (equal? piece w) ; white piece
(send dc set-brush "white" 'solid)
(send dc draw-ellipse (x col) (y row) piece-size piece-size))
(when (equal? piece b) ; red piece
(send dc set-brush "red" 'solid)
(send dc draw-ellipse (x col) (y row) piece-size piece-size))
(when (equal? piece W) ; white king
(send dc set-brush "white" 'solid)
(send dc draw-ellipse (x col) (y row) piece-size piece-size)
(send dc set-brush "black" 'solid)
(send dc draw-ellipse (x (+ 0.25 col)) (y (+ 0.25 row)) (* 0.5 piece-size) (* 0.5 piece-size)))
(when (equal? piece B) ; red king
(send dc set-brush "red" 'solid)
(send dc draw-ellipse (x col) (y row) piece-size piece-size)
(send dc set-brush "black" 'solid)
(send dc draw-ellipse (x (+ 0.25 col)) (y (+ 0.25 row)) (* 0.5 piece-size) (* 0.5 piece-size))))))

; gui window
(define frame (new frame% [label "Example"] [width (* (length (first (state-board state))) piece-size)] [height (* (+ 2 (length (state-board state))) piece-size)]))

; drawable canvas class
; override draw, keyboard, and mouse event callbacks
(define board-canvas
(class canvas%
(inherit get-width get-height refresh)

(define/override (on-char ch)
(when (equal? #\a (send ch get-key-code))
(ai-move)))
(when (equal? #\a (send ch get-key-code))
(ai-move)))

(define/override (on-event event)
(when (and (is-a? event mouse-event%) (send event button-down?))
(let ([r (quotient (send event get-y) piece-size)]
[c (quotient (send event get-x) piece-size)])
(select-square r c)
(send canvas refresh))))


(when (and (is-a? event mouse-event%) (send event button-down?))
(let ([r (quotient (send event get-y) piece-size)]
[c (quotient (send event get-x) piece-size)])
(select-square r c)
(send canvas refresh))))

(super-new (paint-callback draw-state))))

(define canvas (new board-canvas (parent frame)))

(define turn-indicator (new message% [parent frame]
[label "aksjdalksdjalksdjal"]))

;(define utility-indicator (new message% [parent frame]
; [label "alskdajlskdajlds"]))
[label "aksjdalksdjalksdjal"]))

; text box to control search depth
(define search-depth-control (new text-field% [parent frame]
[init-value "5"]
[label "Search depth"]
Expand All @@ -99,8 +114,4 @@
[label "AI move"]
[callback (lambda (button event) (ai-move))]))


(send frame show #t)

(send canvas refresh)

(send frame show #t)

0 comments on commit 85777a6

Please sign in to comment.