Skip to content

Jackie Lee / Backgammon

Go to a project
Commit 95190afc by Jackie Lee
Options

Delete project3.rkt

parent 2685a936
Inline Side-by-side
Showing with 0 additions and 1544 deletions
project3.rkt deleted 100644 → 0
#lang typed/racket
(require "../include/cs151-core.rkt")
(require "../include/cs151-image.rkt")
(require "../include/cs151-universe.rkt")
(require (only-in typed/racket/gui/base put-file get-file))
(require typed/test-engine/racket-tests)
;; === data definitions
(define-type Player (U 'Black 'White))
(define-struct OccupiedPoint
([color : Player]
[count : Integer]))
(define-type Point (U OccupiedPoint 'EmptyPoint))
(define-struct Board
([points : (Listof Point)]
[black-bar : Integer]
[white-bar : Integer]
[black-off : Integer]
[white-off : Integer]))
(define-struct Style
([checker-radius : Integer]
[spacing : Integer]
[black-checker : (Integer -> Image)]
[white-checker : (Integer -> Image)]
[dark-point : (Integer Boolean -> Image)]
[light-point : (Integer Boolean -> Image)]
[background : (Integer Integer -> Image)]
[label : (String Integer -> Image)]
[black-die : (Integer Integer -> Image)]
[white-die : (Integer Integer -> Image)]))
(define-struct Game
([board : Board]
[turn : Player]
[moves : (Listof Integer)]))
(define-struct World
([game : Game]
[style : Style]
[first-white-die : Integer]
[second-white-die : Integer]
[first-black-die : Integer]
[second-black-die : Integer]
[first-click : BoardLoc]))
(define-struct PointNum
([num : Integer]))
(define-type ClickLoc (U PointNum 'BlackBar 'WhiteBar 'BlackOff 'WhiteOff
'BlackDice 'WhiteDice 'Nowhere))
(define-type BoardLoc (U PointNum 'BlackBar 'WhiteBar 'BlackOff 'WhiteOff
'Nowhere))
;; === general helper functions
(: replace-at : All (A) Integer A (Listof A) -> (Listof A))
;; replace the item at the given position
;; position counting starts at 0
;; ex: (replace-at 0 'Z '(a b c)) -> '(Z b c)
;; ex: (replace-at 1 'Z '(a b c)) -> '(a Z c)
(define (replace-at i x xs)
(match xs
['() '()]
[(cons hd tl)
(if (= i 0) (cons x (replace-at (- i 1) x tl))
(cons hd (replace-at (- i 1) x tl)))]))
(check-expect (replace-at 0 'Z '(a b c)) '(Z b c))
(check-expect (replace-at 1 'Z '(a b c)) '(a Z c))
(: remove-int : Integer (Listof Integer) -> (Listof Integer))
;; remove-int: remove the specified Integer from a list of Integer
;; parameter "x": the integer to be removed
;; parameter "xs": the list of integers
;; output: the modified list
(define (remove-int x xs)
(match xs
['() '()]
[(cons hd tl) (if (= hd x) tl (cons hd (remove-int x tl)))]))
(check-expect (remove-int 1 (list 1 2 3 4)) (list 2 3 4))
(check-expect (remove-int 1 (list 1 1 2 3 4)) (list 1 2 3 4))
(: sub-list (All (A) (-> (Listof A) Integer Integer (Listof A))))
;; sub-list: return a sub-list that includes the elements between two given
;; indices in the original list
;; parameter "xs": the original list of elements
;; parameter "start": the starting index in the original list whose element will
;; be the first element in the sub-list
;; parameter "end": the ending index in the original list whose element will be
;; the last element in the sub-list
;; output: a sub-list of elements from the original list, specified by starting
;; and ending indices in the original list
(define (sub-list xs start end)
(local
{(: with-i : Integer -> (Listof A))
(define (with-i i)
(if (<= i end) (cons (list-ref xs i) (with-i (+ i 1))) '()))}
(with-i start)))
(check-expect (sub-list (list "a" "b" "c" "d" "e") 1 3) (list "b" "c" "d"))
(check-expect (sub-list (list 1 2 3 4 5 6 7 8) 0 3) (list 1 2 3 4))
(: player=? : Player Player -> Boolean)
;; player=?: determine whether the two given players are the same
;; parameter "x": the first player for comparison
;; parameter "y": the second player for comparison
;; output: #t if the two symbols are the same, otherwise #f
(define (player=? x y)
(local
{(define x-string : String (symbol->string x))
(define y-string : String (symbol->string y))}
(string=? x-string y-string)))
(check-expect (player=? 'Black 'Black) #t)
(check-expect (player=? 'White 'White) #t)
(check-expect (player=? 'Black 'White) #f)
(check-expect (player=? 'White 'Black) #f)
(: align-top (-> (Listof Image) Image))
;; align-top: call "beside/align 'top'" on all the elements in a list of Image
;; (beside/align has the wrong number of arguments for foldr so this function
;; is written separately
;; parameter "imgs": list of Image on which to call "beside/align 'top'"
;; output: cumulative image result from calling beside/align on a list of Image
(define (align-top imgs)
(match imgs
['() empty-image]
[(cons hd tl) (beside/align "top" hd (align-top tl))]))
(: align-bottom (-> (Listof Image) Image))
;; align-bottom: call "beside/align 'bottom'" on all elements in a list of Image
;; (beside/align has the wrong number of arguments for foldr so this function
;; is written separately
;; parameter "imgs": list of Image on which to call "beside/align 'bottom'"
;; output: composite image result from calling beside/align on a list of Image
(define (align-bottom imgs)
(match imgs
['() empty-image]
[(cons hd tl) (beside/align "bottom" hd (align-bottom tl))]))
;; === styling the backgammon board
(: checker : Image-Color Image-Color -> (Integer -> Image))
;; checker: return a checker image function, given two colors
;; parameter "c1": the main checker color
;; parameter "c2": the checker highlight color
;; output: a checker image function as specified by the style struct
(define (checker c1 c2)
(local
{(: color-checker : Integer -> Image)
(define (color-checker r)
(local
{(define r1 : Real (* 0.675 r))
(define r2 : Real (* 0.8 r))}
(overlay
(circle r1 "solid" c1)
(circle r2 "solid" c2)
(circle r "solid" c1))))}
color-checker))
(: die : Image-Color -> (Integer Integer -> Image))
;; die: return a die image function
;; parameter "c": the background color of the die
;; output: a die image function as specified by the style struct
(define (die c)
(local
{(: color-die : Integer Integer -> Image)
(define (color-die r n)
(local
{(define s : Real (* 2 r))
(define bg : Image (square s "solid" c))
(define w : Real (/ s 5))
(define a : Real (* -0.5 w))
(define b : Real (- (- s (* 1.5 w))))
(define m : Real (* -0.5 (- s w)))
(define pip : Image (circle (/ w 2) "solid" 'white))
(define one : Image (overlay pip bg))
(define two : Image (overlay/xy pip a b (overlay/xy pip b a bg)))
(define three : Image (overlay pip two))
(define four : Image (overlay/xy pip b b (overlay/xy pip a a two)))
(define five : Image (overlay pip four))
(define six : Image (overlay/xy pip m a (overlay/xy pip m b four)))}
(cond
[(= n 0) (square s "solid" (color 255 255 255 0))]
[(= n 1) one]
[(= n 2) two]
[(= n 3) three]
[(= n 4) four]
[(= n 5) five]
[(= n 6) six]
[else (error "die: invalid dice number")])))}
color-die))
(: point : Image-Color -> (Integer Boolean -> Image))
;; point: return a point image function
;; parameter "c": the color of the point
;; output: the point image function as specified by the style struct
(define (point c)
(local
{(: color-point : Integer Boolean -> Image)
(define (color-point r orientation)
(local
{(define a : Real (* 2 (radians->degrees (atan (/ 1 10)))))
(define s : Real (sqrt (+ (sqr r) (* 100 (sqr r)))))}
(match orientation
[#t (isosceles-triangle s a "solid" c)]
[_ (isosceles-triangle s (- 360 a) "solid" c)])))}
color-point))
(define black-checker : (Integer -> Image)
(checker 'steelblue (color 105 155 196)))
(define white-checker : (Integer -> Image)
(checker 'indianred (color 214 122 122)))
(define black-die : (Integer Integer -> Image)
(die 'steelblue))
(define white-die : (Integer Integer -> Image)
(die 'indianred))
(define dark-point : (Integer Boolean -> Image)
(point 'darkred))
(define light-point : (Integer Boolean -> Image)
(point 'lightblue))
(: six-points (-> Integer Integer Boolean (Listof Image)))
;; six-points return a list of Image of 6 alternating dark and light points with
;; specified spacing between the points
;; parameter "r": the radius of a checker for relative sizing of the points
;; parameter "s": the spacing size between the points
;; parameter "orientation": the orientation of the 6 points, represented by a
;; Boolean value, where #t is pointing up and #f is pointing down
;; output: a list of Image of 6 alternating dark and light points with spacing
(define (six-points r s orientation)
(local
{(define p : Image (square s "solid" (color 255 255 255 0)))
(define t-dark : Image (dark-point r #t))
(define f-dark : Image (dark-point r #f))
(define t-light : Image (light-point r #t))
(define f-light : Image (light-point r #f))}
(if (and orientation #t)
(append
(build-list 3 (lambda ([i : Integer]) (beside p t-light p t-dark)))
(list p))
(append
(build-list 3 (lambda ([i : Integer]) (beside p f-dark p f-light)))
(list p)))))
(: background (-> Integer Integer Image))
;; background: return an Image of the styled board, given checker radius and
;; point spacing
;; parameter "r": the radius of the checker
;; parameter "s": the spacing size between the points
;; output: an Image of the styled board
(define (background r s)
(local
{(define w : Real (+ (* 14 s) (* 24 r) (* 2 r) (* 3 r)))
(define h : Real (+ (* 20 r) (* 5 r)))
(define scene : Image (rectangle w h "solid" 'tan))
(define bar : Image (rectangle (* 2 r) h "solid" 'darkred))
(define t-points : Image (foldr beside empty-image (six-points r s #t)))
(define f-points : Image (foldr beside empty-image (six-points r s #f)))
(define clear : Image-Color (color 255 255 255 0))
(define all-points : Image
(above
(beside f-points (square (* 2 r) "solid" clear) f-points)
(square (* 5 r) "solid" clear)
(beside t-points (square (* 2 r) "solid" clear) t-points)))
(define borne : Image (rectangle (* 3 r) h "solid" 'darkred))
(define border : Image (rectangle (+ w (* 2 r)) (+ h (* 2 r)) "solid"
'darkred))}
(overlay (beside (overlay bar all-points) borne) scene border)))
(: label (-> String Integer Image))
;; label: given a string, return a white text Image of the string, with relative
;; font size equivalent to the checker radius
;; parameter "s": the string to be converted to a text Image
;; parameter "r": the radius of a checker for relative font sizing
;; output: a white text Image
(define (label s r)
(if (byte? r) (text s r 'white) (text s 255 'white)))
;; composite style struct, using the above functions
(define test-style : Style
(Style 25 20 black-checker white-checker dark-point light-point background
label black-die white-die))
;; === drawing the backgammon board
(: draw-board : Style Board -> Image)
;; draw-board: return Backgammon board, given style specifications and board
;; state
;; parameter "s": board style as specified by a Style struct
;; parameter "b": board state as specified by a Board struct
;; output: Image of Backgammon board and checkers in play
(define (draw-board s b)
(match* (s b)
[((Style r s b-c w-c d-pt l-pt bg la b-d w-d)
(Board pts b-bar w-bar b-off w-off))
(local
{(: stack (-> Integer Point Image))
(define (stack r p)
(match p
['EmptyPoint (circle r "solid" (color 255 255 255 0))]
[(OccupiedPoint 'Black count)
(cond
[(<= count 5)
(foldr above empty-image
(build-list count (lambda ([i : Integer]) (b-c r))))]
[else
(overlay
(la (number->string count) r)
(foldr above empty-image
(build-list 5 (lambda ([i : Integer]) (b-c r)))))])]
[(OccupiedPoint 'White count)
(cond
[(<= count 5)
(foldr above empty-image
(build-list count (lambda ([i : Integer]) (w-c r))))]
[else
(overlay
(la (number->string count) r)
(foldr above empty-image
(build-list 5 (lambda ([i : Integer]) (w-c r)))))])]))
(: int-stack (-> Player Integer Integer Image))
(define (int-stack p r n)
(match p
['Black
(cond
[(= n 0) (circle r "solid" (color 255 255 255 0))]
[(<= n 5)
(foldr above empty-image
(build-list n (lambda ([i : Integer]) (b-c r))))]
[else
(overlay
(la (number->string n) r)
(foldr above empty-image
(build-list 5 (lambda ([i : Integer]) (b-c r)))))])]
[_
(cond
[(= n 0) (circle r "solid" (color 255 255 255 0))]
[(<= n 5)
(foldr above empty-image
(build-list n (lambda ([i : Integer]) (w-c r))))]
[else
(overlay
(la (number->string n) r)
(foldr above empty-image
(build-list 5 (lambda ([i : Integer]) (w-c r)))))])]))
(: stack-list (-> Integer Integer (Listof Point) (Listof Image)))
(define (stack-list r s pts)
(match pts
['() '()]
[(cons hd tl) (cons (square s "solid" (color 255 255 255 0))
(cons (stack r hd) (stack-list r s tl)))]))
(: top-stack (-> Integer Integer (Listof Image) Image))
(define (top-stack r s imgs)
(align-top
(list
(align-top (sub-list imgs 24 35))
(square (+ s (* 2 r)) "solid" (color 255 255 255 0))
(align-top (sub-list imgs 36 47)))))
(: bottom-stack (-> Integer Integer (Listof Image) Image))
(define (bottom-stack r s imgs)
(align-bottom
(list
(align-bottom (reverse (sub-list imgs 12 23)))
(square (+ s (* 2 r)) "solid" (color 255 255 255 0))
(align-bottom (reverse (sub-list imgs 0 11))))))
(define t-points : Image (top-stack r s (stack-list r s pts)))
(define b-points : Image (bottom-stack r s (stack-list r s pts)))
(define t-x : Real (/ (image-width t-points) 2))
(define t-y : Real (/ (image-height t-points) 2))
(define b-x : Real (/ (image-width b-points) 2))
(define b-y : Real (/ (image-height b-points) 2))
(define w : Real (image-width (background r s)))
(define h : Real (image-height (background r s)))
(define b-bar-stack : Image (int-stack 'Black r b-bar))
(define w-bar-stack : Image (int-stack 'White r w-bar))
(define b-off-stack : Image (int-stack 'Black r b-off))
(define w-off-stack : Image (int-stack 'White r w-off))}
(place-image
t-points
(+ t-x r) (+ t-y r)
(place-image
b-points
(- w (* 4 r) b-x) (- h r b-y)
(place-image
w-off-stack
(- w (* 2.5 r)) (- h r (/ (image-height w-off-stack) 2))
(place-image
b-off-stack
(- w (* 2.5 r)) (+ r (/ (image-height b-off-stack) 2))
(place-image
b-bar-stack
(+ (* 7 s) (* 14 r)) (- h r (/ (image-height b-bar-stack) 2))
(place-image
w-bar-stack
(+ (* 7 s) (* 14 r)) (+ r (/ (image-height w-bar-stack) 2))
(background r s))))))))]))
;; === sample backgammon boards
(define initial-board : Board
(Board
(replace-at 23 (OccupiedPoint 'White 2)
(replace-at 18 (OccupiedPoint 'Black 5)
(replace-at 16 (OccupiedPoint 'Black 3)
(replace-at 12 (OccupiedPoint 'White 5)
(replace-at 11 (OccupiedPoint 'Black 5)
(replace-at 7 (OccupiedPoint 'White 3)
(replace-at 5 (OccupiedPoint 'White 5)
(replace-at 0 (OccupiedPoint 'Black 2)
(make-list 24 'EmptyPoint)))))))))
0 0 0 0))
(define test-board : Board
(Board
(replace-at 0 (OccupiedPoint 'White 1)
(replace-at 1 (OccupiedPoint 'White 2)
(replace-at 2 (OccupiedPoint 'White 3)
(replace-at 3 (OccupiedPoint 'White 4)
(replace-at 4 (OccupiedPoint 'White 5)
(make-list 24 'EmptyPoint))))))
0 0 0 0))
;; === universe support
(: roll : Integer -> Integer)
;; roll: return sum of result of built-in "random" function and one
;; parameter "max": upper bound for built-in function random
;; output: result of built-in random function plus one
(define (roll max)
(+ (random max) 1))
(: click-where : Style Integer Integer -> ClickLoc)
;; click-where: return aspect of backgammon board clicked on, given the board's
;; style specifications and the x and y coordinates of the click
;; parameter "style": board style as specified by a Style struct
;; parameter "x": the x-coordinate of the click
;; parameter "y": the y-coordinate of the click
;; output: a ClickLoc that represents the aspect of the backgammon board clicked
(define (click-where style x y)
(match style
[(Style r s _ _ _ _ _ _ _ _)
(local
{(: left-points? : Integer Integer Integer -> Integer)
(define (left-points? x r s)
(local
{(define a : Integer (- x r))
(define b : Integer (+ s (* 2 r)))}
(if (> (remainder a b) s) (exact-ceiling (/ a b)) 0)))
(: right-points? : Integer Integer Integer -> Integer)
(define (right-points? x r s)
(local
{(define offset : Integer (+ (* 15 r) (* 7 s)))
(define a : Integer (- x offset))
(define b : Integer (+ s (* 2 r)))}
(if (> (remainder a b) s) (exact-ceiling (/ a b)) 0)))}
(cond
[(< r y (* 11 r))
(cond
[(< (+ r s) x (+ (* 13 r) (* 7 s)))
(if (> (left-points? x r s) 0)
(PointNum (+ 12 (left-points? x r s))) 'Nowhere)]
[(< (+ (* 13 r) (* 7 s)) x (+ (* 15 r) (* 7 s))) 'WhiteBar]
[(< (+ (* 15 r) (* 7 s)) x (+ (* 27 r) (* 14 s)))
(if (> (right-points? x r s) 0)
(PointNum (+ 18 (right-points? x r s))) 'Nowhere)]
[(< (+ (* 27 r) (* 14 s)) x (+ (* 30 r) (* 14 s))) 'BlackOff]
[else 'Nowhere])]
[(< (* 11 r) y (* 16 r))
(cond
[(< (+ (* 5 r) (* 2.5 s)) x (+ (* 9 r) (* 4.5 s))) 'WhiteDice]
[(< (+ (* 19 r) (* 9.5 s)) x (+ (* 23 r) (* 11.5 s))) 'BlackDice]
[else 'Nowhere])]
[(< (* 16 r) y (* 27 r))
(cond
[(< (+ r s) x (+ (* 13 r) (* 7 s)))
(if (> (left-points? x r s) 0)
(PointNum (- 13 (left-points? x r s))) 'Nowhere)]
[(< (+ (* 13 r) (* 7 s)) x (+ (* 15 r) (* 7 s))) 'BlackBar]
[(< (+ (* 15 r) (* 7 s)) x (+ (* 27 r) (* 14 s)))
(if (> (right-points? x r s) 0)
(PointNum (- 7 (right-points? x r s))) 'Nowhere)]
[(< (+ (* 27 r) (* 14 s)) x (+ (* 30 r) (* 14 s))) 'WhiteOff]
[else 'Nowhere])]
[else 'Nowhere]))]))
(check-expect (click-where test-style 70 26) (PointNum 13))
(check-expect (click-where test-style 140 26) (PointNum 14))
(check-expect (click-where test-style 210 26) (PointNum 15))
(check-expect (click-where test-style 280 26) (PointNum 16))
(check-expect (click-where test-style 350 26) (PointNum 17))
(check-expect (click-where test-style 420 26) (PointNum 18))
(check-expect (click-where test-style 560 26) (PointNum 19))
(check-expect (click-where test-style 630 26) (PointNum 20))
(check-expect (click-where test-style 700 26) (PointNum 21))
(check-expect (click-where test-style 770 26) (PointNum 22))
(check-expect (click-where test-style 840 26) (PointNum 23))
(check-expect (click-where test-style 910 26) (PointNum 24))
(check-expect (click-where test-style 70 401) (PointNum 12))
(check-expect (click-where test-style 140 401) (PointNum 11))
(check-expect (click-where test-style 210 401) (PointNum 10))
(check-expect (click-where test-style 280 401) (PointNum 9))
(check-expect (click-where test-style 350 401) (PointNum 8))
(check-expect (click-where test-style 420 401) (PointNum 7))
(check-expect (click-where test-style 560 401) (PointNum 6))
(check-expect (click-where test-style 630 401) (PointNum 5))
(check-expect (click-where test-style 700 401) (PointNum 4))
(check-expect (click-where test-style 770 401) (PointNum 3))
(check-expect (click-where test-style 840 401) (PointNum 2))
(check-expect (click-where test-style 910 401) (PointNum 1))
(check-expect (click-where test-style 490 26) 'WhiteBar)
(check-expect (click-where test-style 490 401) 'BlackBar)
(check-expect (click-where test-style 956 26) 'BlackOff)
(check-expect (click-where test-style 956 401) 'WhiteOff)
(check-expect (click-where test-style 235 338) 'WhiteDice)
(check-expect (click-where test-style 735 338) 'BlackDice)
(: distance : BoardLoc BoardLoc -> Integer)
;; distance: return the distance between two board locations (the die roll
;; needed to move from one location to another)
;; parameter "loc1": the origin location
;; parameter "loc2": the destination location
;; output: the distance
(define (distance loc1 loc2)
(match* (loc1 loc2)
[((PointNum p) (PointNum q)) (- q p)]
[((PointNum p) 'BlackOff) (- 25 p)]
[((PointNum p) 'WhiteOff) (- p)]
[('BlackBar (PointNum p)) p]
[('WhiteBar (PointNum p)) (- p 25)]
[(_ _) (error "distance: not applicable")]))
(check-expect (distance (PointNum 24) (PointNum 19)) -5)
(check-expect (distance (PointNum 19) 'BlackOff) 6)
(check-expect (distance (PointNum 6) 'WhiteOff) -6)
(check-expect (distance 'BlackBar (PointNum 3)) 3)
(check-expect (distance 'WhiteBar (PointNum 21)) -4)
(: home? : Player (Listof Point) -> Boolean)
;; home?: return true if all of a player's checkers are in their home quadrant,
;; otherwise false
;; parameter "player": the player whose checkers are in question
;; parameter "pts": a list of points, as represented in the Board struct
;; output: #t if all of the player's checkers are in their home quadrant,
;; else #f
(define (home? player pts)
(local
{(: helper : Integer Integer -> (Listof Integer))
(define (helper a b)
(if (< b 6)
(local
{(define pt : Point (list-ref pts (+ a b)))}
(match pt
[(OccupiedPoint color count)
(if (player=? color player)
(cons count (helper a (+ b 1)))
(helper a (+ b 1)))]
[_ (helper a (+ b 1))]))
'()))}
(if (player=? player 'White)
(= (foldr + 0 (helper 0 0)) 15)
(= (foldr + 0 (helper 18 0)) 15))))
(check-expect (home? 'White (Board-points test-board)) #t)
(check-expect (home? 'White (Board-points initial-board)) #f)
(: matching-move? : Player BoardLoc BoardLoc (Listof Integer) -> Boolean)
;; matching-move?: return true if a player's desired move is possible according
;; to their dice roll
;; parameter "player": the player whose turn it is
;; parameter "loc1": the origin location of the move
;; parameter "loc2": the destination location of the move
;; parameter "moves": the available dice rolls
;; output: #t if the player's desired move is possible, else #f
(define (matching-move? player loc1 loc2 moves)
(local
{(define dist : Integer (distance loc1 loc2))}
(if (player=? player 'Black)
(if (negative? dist)
#f
(ormap (lambda ([i : Integer]) (= i (abs dist))) moves))
(if (positive? dist)
#f
(ormap (lambda ([i : Integer]) (= i (abs dist))) moves)))))
(check-expect (matching-move? 'Black (PointNum 20) 'BlackOff (list 5 3)) #t)
(check-expect (matching-move? 'White (PointNum 20) (PointNum 16) (list 5 3)) #f)
(: legal-move? : Game BoardLoc BoardLoc -> Boolean)
;; legal-move: return true if the proposed move is legal, otherwise false
;; parameter "game": the game state, as represented by the Game struct
;; parameter "loc1": the origin location of the move
;; parameter "loc2": the destination location of the move
;; output: #t if the move is legal, else #f
(define (legal-move? game loc1 loc2)
(match game
[(Game (Board pts b-bar w-bar b-off w-off) 'Black moves)
(if (> b-bar 0)
(match* (loc1 loc2)
[('BlackBar (PointNum p))
(local
{(define ppt : Point (list-ref pts (- p 1)))}
(match ppt
[(OccupiedPoint 'White count)
(if (> count 1)
#f
(matching-move? 'Black 'BlackBar (PointNum p) moves))]
[_ (matching-move? 'Black 'BlackBar (PointNum p) moves)]))]
[(_ _) #f])
(match* (loc1 loc2)
[(_ 'Nowhere) #f]
[(_ 'BlackDice) #f]
[(_ 'WhiteDice) #f]
[(_ 'WhiteOff) #f]
[(_ 'BlackBar) #f]
[(_ 'WhiteBar) #f]
[('Nowhere _) #f]
[('BlackDice _) #f]
[('WhiteDice _) #f]
[('BlackOff _) #f]
[('WhiteOff _) #f]
[('WhiteBar _) #f]
[((PointNum p) (PointNum q))
(local
{(define ppt : Point (list-ref pts (- p 1)))
(define qpt : Point (list-ref pts (- q 1)))}
(match* (ppt qpt)
[('EmptyPoint _) #f]
[((OccupiedPoint 'White _) _) #f]
[(_ (OccupiedPoint 'White count))
(if (> count 1)
#f
(matching-move? 'Black (PointNum p) (PointNum q) moves))]
[(_ _)
(matching-move? 'Black (PointNum p) (PointNum q) moves)]))]
[((PointNum p) 'BlackOff)
(if (home? 'Black pts)
(local
{(define ppt : Point (list-ref pts (- p 1)))}
(match ppt
['EmptyPoint #f]
[(OccupiedPoint 'White _) #f]
[_
(if (matching-move? 'Black (PointNum p) 'BlackOff moves)
#t
(ormap
(lambda ([move : Integer])
(> move (abs (distance (PointNum p) 'BlackOff))))
moves))]))
#f)]
[('BlackBar (PointNum p))
(if (> b-bar 0)
(local
{(define ppt : Point (list-ref pts (- p 1)))}
(match ppt
[(OccupiedPoint 'White count)
(if (> count 1)
#f
(matching-move? 'Black 'BlackBar (PointNum p) moves))]
[_ (matching-move? 'Black 'BlackBar (PointNum p) moves)]))
#f)]
[('BlackBar 'BlackOff) #f]
[(_ _) #t]))]
[(Game (Board pts b-bar w-bar b-off w-off) 'White moves)
(if (> w-bar 0)
(match* (loc1 loc2)
[('WhiteBar (PointNum p))
(local
{(define ppt : Point (list-ref pts (- p 1)))}
(match ppt
[(OccupiedPoint 'Black count)
(if (> count 1)
#f
(matching-move? 'White 'WhiteBar (PointNum p) moves))]
[_ (matching-move? 'White 'WhiteBar (PointNum p) moves)]))]
[(_ _) #f])
(match* (loc1 loc2)
[(_ 'Nowhere) #f]
[(_ 'BlackDice) #f]
[(_ 'WhiteDice) #f]
[(_ 'BlackOff) #f]
[(_ 'BlackBar) #f]
[(_ 'WhiteBar) #f]
[('Nowhere _) #f]
[('BlackDice _) #f]
[('WhiteDice _) #f]
[('BlackOff _) #f]
[('WhiteOff _) #f]
[('BlackBar _) #f]
[((PointNum p) (PointNum q))
(local
{(define ppt : Point (list-ref pts (- p 1)))
(define qpt : Point (list-ref pts (- q 1)))}
(match* (ppt qpt)
[('EmptyPoint _) #f]
[((OccupiedPoint 'Black _) _) #f]
[(_ (OccupiedPoint 'Black count))
(if (> count 1)
#f
(matching-move? 'White (PointNum p) (PointNum q) moves))]
[(_ _)
(matching-move? 'White (PointNum p) (PointNum q) moves)]))]
[((PointNum p) 'WhiteOff)
(if (home? 'White pts)
(local
{(define ppt : Point (list-ref pts (- p 1)))}
(match ppt
['EmptyPoint #f]
[(OccupiedPoint 'Black _) #f]
[_
(if (matching-move? 'White (PointNum p) 'WhiteOff moves)
#t
(ormap
(lambda ([move : Integer])
(> move (abs (distance (PointNum p) 'WhiteOff))))
moves))]))
#f)]
[('WhiteBar (PointNum p))
(if (> w-bar 0)
(local
{(define ppt : Point (list-ref pts (- p 1)))}
(match ppt
[(OccupiedPoint 'Black count)
(if (> count 1)
#f
(matching-move? 'White 'WhiteBar (PointNum p) moves))]
[_ (matching-move? 'White 'WhiteBar (PointNum p) moves)]))
#f)]
[('WhiteBar 'WhiteOff) #f]))]))
(check-expect
(legal-move?
(Game initial-board 'Black (list 2 4)) (PointNum 1) (PointNum 3)) #t)
(check-expect
(legal-move?
(Game initial-board 'Black (list 2 4)) (PointNum 1) (PointNum 2)) #f)
(: available-starts : Game -> (Listof BoardLoc))
;; available-starts: return a list of possible move origin locations, according
;; to the player whose turn it is
;; parameter "game": the game state, as specified by the Game struct
;; output: a list of possible move origin locations
(define (available-starts game)
(match game
[(Game (Board pts b-bar w-bar _ _) turn _)
(local
{(: start-point? : Player Point -> Boolean)
(define (start-point? player pt)
(match pt
[(OccupiedPoint color _) (player=? player color)]
[_ #f]))
(: start-points : Player (Listof Point) Integer -> (Listof PointNum))
(define (start-points player lpt i)
(if (< i 24)
(if (start-point? player (list-ref lpt i))
(cons (PointNum (+ i 1)) (start-points player lpt (+ i 1)))
(start-points player lpt (+ i 1)))
'()))
(define start-pts : (Listof PointNum) (start-points turn pts 0))
(define starts : (Listof BoardLoc)
(if (player=? turn 'White)
(if (> w-bar 0) (append start-pts (list 'WhiteBar)) start-pts)
(if (> b-bar 0) (append start-pts (list 'BlackBar)) start-pts)))}
starts)]
[_ '()]))
(check-expect
(available-starts (Game initial-board 'Black (list 2 4)))
(list (PointNum 1) (PointNum 12) (PointNum 17) (PointNum 19)))
(check-expect
(available-starts (Game initial-board 'White (list 3 6)))
(list (PointNum 6) (PointNum 8) (PointNum 13) (PointNum 24)))
(: available-ends : Game -> (Listof BoardLoc))
;; available-starts: return a list of possible move destinations, according to
;; the player whose turn it is
;; parameter "game": the game state, as specified by the Game struct
;; output: a list of possible move destination locations
(define (available-ends game)
(match game
[(Game (Board pts b-bar w-bar _ _) turn moves)
(local
{(: end-point? : Player Point -> Boolean)
(define (end-point? player pt)
(match pt
[(OccupiedPoint color count)
(if (player=? player color) #t (= count 1))]
['EmptyPoint #t]
[_ #f]))
(: end-points : Player (Listof Point) Integer -> (Listof PointNum))
(define (end-points player lpt i)
(if (< i 24)
(if (end-point? player (list-ref lpt i))
(cons (PointNum (+ i 1)) (end-points player lpt (+ i 1)))
(end-points player lpt (+ i 1)))
'()))
(define end-pts : (Listof PointNum) (end-points turn pts 0))
(define ends : (Listof BoardLoc)
(if (player=? turn 'White)
(if (home? 'White pts) (append end-pts (list 'WhiteOff)) end-pts)
(if (home? 'Black pts)
(append end-pts (list 'BlackOff)) end-pts)))}
ends)]
[_ '()]))
(check-expect
(available-ends (Game initial-board 'Black (list 2 4)))
(list (PointNum 1) (PointNum 2) (PointNum 3) (PointNum 4) (PointNum 5)
(PointNum 7) (PointNum 9) (PointNum 10) (PointNum 11) (PointNum 12)
(PointNum 14) (PointNum 15) (PointNum 16) (PointNum 17) (PointNum 18)
(PointNum 19) (PointNum 20) (PointNum 21) (PointNum 22) (PointNum 23)))
(check-expect
(available-ends (Game initial-board 'White (list 3 6)))
(list (PointNum 2) (PointNum 3) (PointNum 4) (PointNum 5) (PointNum 6)
(PointNum 7) (PointNum 8) (PointNum 9) (PointNum 10) (PointNum 11)
(PointNum 13) (PointNum 14) (PointNum 15) (PointNum 16) (PointNum 18)
(PointNum 20) (PointNum 21) (PointNum 22) (PointNum 23) (PointNum 24)))
(: available-moves? : Game -> Boolean)
;; available-moves?: return true if it is possible for the player whose turn it
;; is to make moves, otherwise false
;; parameter "game": the game state, as specified by the Game struct
;; output: #t if the player can make moves in the game, else #f
(define (available-moves? game)
(match game
[(Game board turn moves)
(if (empty? moves) #f
(local
{(: helper : (Listof BoardLoc) (Listof BoardLoc) -> Boolean)
(define (helper starts ends)
(ormap
(lambda ([start : BoardLoc])
(ormap (lambda ([end : BoardLoc])
(legal-move? game start end)) ends)) starts))
(define starts : (Listof BoardLoc) (available-starts game))
(define ends : (Listof BoardLoc) (available-ends game))}
(helper starts ends)))]))
(check-expect (available-moves? (Game initial-board 'Black (list 2 4))) #t)
(define board1 : Board (Board
(replace-at 23 (OccupiedPoint 'Black 2)
(replace-at 22 (OccupiedPoint 'Black 5)
(replace-at 21 (OccupiedPoint 'Black 3)
(replace-at 20 (OccupiedPoint 'Black 5)
(replace-at 19 (OccupiedPoint 'Black 5)
(replace-at 18 (OccupiedPoint 'Black 3)
(replace-at 5 (OccupiedPoint 'White 5)
(replace-at 0 (OccupiedPoint 'Black 2)
(make-list 24 'EmptyPoint)))))))))
0 1 0 0))
(check-expect (available-moves? (Game board1 'White (list 4 3))) #f)
(: game-over? : Game -> Boolean)
;; game-over?: return true if the game is over (a player has won), else false
;; parameter "game": the game state, as specified by the Game struct
;; output: #t if the game has been won, else #f
(define (game-over? game)
(match game
[(Game (Board _ _ _ b-off w-off) _ _)
(or (= b-off 15) (= w-off 15))]))
(check-expect (game-over? (Game initial-board 'White (list 2 3))) #f)
(check-expect
(game-over? (Game (Board (make-list 24 'EmptyPoint) 0 0 15 0) 'White '())) #t)
(: winner : Game -> Player)
;; winner: return the player that has won the game
;; parameter "game": the game state, as specified by the Game struct
;; output: the Player that has won the game
(define (winner game)
(match game
[(Game (Board _ _ _ b-off _) _ _)
(if (= b-off 15) 'Black 'White)]))
(check-expect
(winner (Game (Board (make-list 24 'EmptyPoint) 0 0 15 0) 'White '())) 'Black)
(check-expect
(winner (Game (Board (make-list 24 'EmptyPoint) 0 0 0 15) 'White '())) 'White)
(: apply-move : Game BoardLoc BoardLoc -> Game)
;; apply-move: move one checker from the given initial board location to the
;; given destination location on the board, if the proposed move is legal.
;; otherwise, leave the board unchanged.
;; parameter "game": the game state, as specified by the Game struct
;; parameter "loc1": initial board location
;; parameter "loc2": destination location on the board
;; output: a Game struct with the move applied, if it is legal; otherwise an
;; error is raised
(define (apply-move game loc1 loc2)
(if (legal-move? game loc1 loc2)
(match game
[(Game (Board pts b-bar w-bar b-off w-off) turn moves)
(match* (loc1 loc2)
[((PointNum p) (PointNum q))
(local
{(define ppt : Point (list-ref pts (- p 1)))
(define qpt : Point (list-ref pts (- q 1)))}
(match* (ppt qpt)
[((OccupiedPoint color count) 'EmptyPoint)
(local
{(define pts-2 : (Listof Point)
(if (= (- count 1) 0)
(replace-at (- p 1) 'EmptyPoint pts)
(replace-at
(- p 1) (OccupiedPoint color (- count 1)) pts)))
(define moves-2 : (Listof Integer)
(remove-int
(abs (distance (PointNum p) (PointNum q))) moves))}
(Game (Board
(replace-at (- q 1) (OccupiedPoint color 1) pts-2)
b-bar w-bar b-off w-off) turn moves-2))]
[((OccupiedPoint color1 count1) (OccupiedPoint color2 count2))
(local
{(define pts-2 : (Listof Point)
(if (= (- count1 1) 0)
(replace-at (- p 1) 'EmptyPoint pts)
(replace-at
(- p 1) (OccupiedPoint color1 (- count1 1)) pts)))
(define moves-2 : (Listof Integer)
(remove-int
(abs (distance (PointNum p) (PointNum q))) moves))}
(if (player=? color1 color2)
(Game
(Board
(replace-at
(- q 1) (OccupiedPoint color2 (+ count2 1)) pts-2)
b-bar w-bar b-off w-off) turn moves-2)
(if (player=? color2 'Black)
(Game
(Board
(replace-at (- q 1) (OccupiedPoint 'White 1) pts-2)
(+ b-bar 1) w-bar b-off w-off) turn moves-2)
(Game
(Board
(replace-at (- q 1) (OccupiedPoint 'Black 1) pts-2)
b-bar (+ w-bar 1) b-off w-off) turn moves-2))))]))]
[((PointNum p) 'BlackOff)
(local
{(define ppt : Point (list-ref pts (- p 1)))}
(match ppt
[(OccupiedPoint 'Black count)
(local
{(define pts-2 : (Listof Point)
(if (= (- count 1) 0)
(replace-at (- p 1) 'EmptyPoint pts)
(replace-at (- p 1)
(OccupiedPoint 'Black (- count 1)) pts)))
(define moves-2 : (Listof Integer)
(remove-int
(abs (distance (PointNum p) 'BlackOff)) moves))}
(Game (Board pts-2 b-bar w-bar (+ b-off 1) w-off)
turn moves-2))]))]
[((PointNum p) 'WhiteOff)
(local
{(define ppt : Point (list-ref pts (- p 1)))}
(match ppt
[(OccupiedPoint 'White count)
(local
{(define pts-2 : (Listof Point)
(if (= (- count 1) 0)
(replace-at (- p 1) 'EmptyPoint pts)
(replace-at (- p 1)
(OccupiedPoint 'White (- count 1)) pts)))
(define moves-2 : (Listof Integer)
(remove-int
(abs (distance (PointNum p) 'WhiteOff)) moves))}
(Game (Board pts-2 b-bar w-bar b-off (+ w-off 1))
turn moves-2))]))]
[('BlackBar (PointNum p))
(local
{(define ppt : Point (list-ref pts (- p 1)))
(define moves-2 : (Listof Integer)
(remove-int (abs (distance 'BlackBar (PointNum p))) moves))}
(match ppt
['EmptyPoint
(Game (Board (replace-at (- p 1) (OccupiedPoint 'Black 1) pts)
(- b-bar 1) w-bar b-off w-off) turn moves-2)]
[(OccupiedPoint 'Black count)
(Game
(Board
(replace-at (- p 1) (OccupiedPoint 'Black (+ count 1)) pts)
(- b-bar 1) w-bar b-off w-off) turn moves-2)]
[(OccupiedPoint 'White count)
(Game
(Board (replace-at (- p 1) (OccupiedPoint 'Black 1) pts)
(- b-bar 1) (+ w-bar 1) b-off w-off) turn moves-2)]))]
[('WhiteBar (PointNum p))
(local
{(define ppt : Point (list-ref pts (- p 1)))
(define moves-2 : (Listof Integer)
(remove-int (abs (distance 'WhiteBar (PointNum p))) moves))}
(match ppt
['EmptyPoint
(Game (Board (replace-at (- p 1) (OccupiedPoint 'White 1) pts)
b-bar (- w-bar 1) b-off w-off) turn moves-2)]
[(OccupiedPoint 'White count)
(Game
(Board
(replace-at (- p 1) (OccupiedPoint 'White (+ count 1)) pts)
b-bar (- w-bar 1) b-off w-off) turn moves-2)]
[(OccupiedPoint 'Black count)
(Game
(Board (replace-at (- p 1) (OccupiedPoint 'White 1) pts)
(+ b-bar 1) (- w-bar 1) b-off w-off)
turn moves-2)]))])])
(error "apply-move: illegal move")))
(: react-to-mouse : World Integer Integer Mouse-Event -> World)
;; react-to-mouse: manifest appropriate reactions in the backgammon world,
;; according to given click location(s)
;; parameter "w": the World struct
;; parameter "x": the x-coordinate of the click
;; parameter "y": the y-coordinate of the click
;; parameter "e": the click event type
;; output: the updated World struct, given the effect of the user click
(define (react-to-mouse w x y e)
(match w
[(World (Game board turn moves) style w1 w2 b1 b2 cl)
(if (game-over? (Game board turn moves)) w
(match board
[(Board pts b-bar w-bar b-off w-off)
(match e
["button-down"
(local
{(define clickloc : ClickLoc (click-where style x y))}
(match turn
['Black
(match* (cl clickloc)
[('Nowhere 'WhiteDice)
(if (available-moves? (Game board turn moves))
w
(local
{(define roll1 : Integer (roll 6))
(define roll2 : Integer (roll 6))
(define moves-2 : (Listof Integer)
(if (= roll1 roll2)
(make-list 4 roll1) (list roll1 roll2)))}
(World (Game board 'White moves-2)
style roll1 roll2 b1 b2 'Nowhere)))]
[('Nowhere 'BlackDice) w]
[('Nowhere 'WhiteOff) w]
[('Nowhere 'BlackOff) w]
[('Nowhere 'Nowhere) w]
[('Nowhere (PointNum p))
(local
{(define ppt : Point (list-ref pts (- p 1)))}
(match ppt
['EmptyPoint w]
[(OccupiedPoint color count)
(cond
[(player=? 'Black color)
(World (Game board turn moves)
style w1 w2 b1 b2 (PointNum p))]
[(= count 1)
(World (Game board turn moves)
style w1 w2 b1 b2 (PointNum p))]
[else w])]))]
[('Nowhere 'BlackBar)
(if (> b-bar 0)
(World (Game board turn moves)
style w1 w2 b1 b2 'BlackBar)
w)]
[('Nowhere 'WhiteBar) w]
[('BlackBar 'Nowhere) w]
[('BlackBar 'WhiteBar) w]
[('BlackBar 'BlackBar)
(World
(Game board turn moves) style w1 w2 b1 b2 'Nowhere)]
[('BlackBar 'BlackOff) w]
[('BlackBar 'WhiteOff) w]
[('BlackBar 'WhiteDice) w]
[('BlackBar 'BlackDice) w]
[('BlackBar (PointNum p))
(if (legal-move?
(Game board turn moves) 'BlackBar (PointNum p))
(local
{(define ppt : Point (list-ref pts (- p 1)))}
(match ppt
['EmptyPoint
(World
(apply-move (Game board turn moves)
'BlackBar (PointNum p))
style w1 w2 b1 b2 'Nowhere)]
[(OccupiedPoint color count)
(cond
[(player=? 'Black color)
(World
(apply-move (Game board turn moves)
'BlackBar (PointNum p))
style w1 w2 b1 b2 'Nowhere)]
[(= count 1)
(World
(apply-move (Game board turn moves)
'BlackBar (PointNum p))
style w1 w2 b1 b2 'Nowhere)]
[else w])]))
w)]
[((PointNum p) 'Nowhere) w]
[((PointNum p) 'WhiteBar) w]
[((PointNum p) 'BlackBar) w]
[((PointNum p) 'WhiteOff) w]
[((PointNum p) 'BlackOff)
(if (legal-move?
(Game board turn moves) (PointNum p) 'BlackOff)
(World
(apply-move (Game board turn moves) (PointNum p)
'BlackOff) style w1 w2 b1 b2 'Nowhere)
w)]
[((PointNum p) 'WhiteDice) w]
[((PointNum p) 'BlackDice) w]
[((PointNum p) (PointNum p))
(World
(Game board turn moves) style w1 w2 b1 b2 'Nowhere)]
[((PointNum p) (PointNum q))
(if (legal-move?
(Game board turn moves) (PointNum p) (PointNum q))
(local
{(define ppt : Point (list-ref pts (- p 1)))
(define qpt : Point (list-ref pts (- q 1)))}
(match qpt
['EmptyPoint
(World
(apply-move
(Game board turn moves)
(PointNum p) (PointNum q))
style w1 w2 b1 b2 'Nowhere)]
[(OccupiedPoint color count)
(cond
[(player=? 'Black color)
(World
(apply-move
(Game board turn moves)
(PointNum p) (PointNum q))
style w1 w2 b1 b2 'Nowhere)]
[(= count 1)
(World
(apply-move
(Game board turn moves)
(PointNum p) (PointNum q))
style w1 w2 b1 b2 'Nowhere)]
[else w])]))
w)])]
[_
(match* (cl clickloc)
[('Nowhere 'WhiteDice) w]
[('Nowhere 'BlackDice)
(if (available-moves? (Game board turn moves))
w
(local
{(define roll1 : Integer (roll 6))
(define roll2 : Integer (roll 6))
(define moves-2 : (Listof Integer)
(if (= roll1 roll2)
(make-list 4 roll1) (list roll1 roll2)))}
(World (Game board 'Black moves-2)
style w1 w2 roll1 roll2 'Nowhere)))]
[('Nowhere 'WhiteOff) w]
[('Nowhere 'BlackOff) w]
[('Nowhere 'Nowhere) w]
[('Nowhere (PointNum p))
(local
{(define ppt : Point (list-ref pts (- p 1)))}
(match ppt
['EmptyPoint w]
[(OccupiedPoint color count)
(cond
[(player=? 'White color)
(World
(Game board turn moves)
style w1 w2 b1 b2 (PointNum p))]
[(= count 1)
(World
(Game board turn moves)
style w1 w2 b1 b2 (PointNum p))]
[else w])]))]
[('Nowhere 'WhiteBar)
(if (> w-bar 0)
(World (Game board turn moves)
style w1 w2 b1 b2 'WhiteBar)
w)]
[('Nowhere 'BlackBar) w]
[('WhiteBar 'Nowhere) w]
[('WhiteBar 'WhiteBar)
(World
(Game board turn moves) style w1 w2 b1 b2 'Nowhere)]
[('WhiteBar 'BlackBar) w]
[('WhiteBar 'BlackOff) w]
[('WhiteBar 'WhiteOff) w]
[('WhiteBar 'WhiteDice) w]
[('WhiteBar 'BlackDice) w]
[('WhiteBar (PointNum p))
(if (legal-move?
(Game board turn moves) 'WhiteBar (PointNum p))
(local
{(define ppt : Point (list-ref pts (- p 1)))}
(match ppt
['EmptyPoint
(World
(apply-move
(Game board turn moves)
'WhiteBar (PointNum p))
style w1 w2 b1 b2 'Nowhere)]
[(OccupiedPoint color count)
(cond
[(player=? 'White color)
(World
(apply-move (Game board turn moves)
'WhiteBar (PointNum p))
style w1 w2 b1 b2 'Nowhere)]
[(= count 1)
(World
(apply-move (Game board turn moves)
'WhiteBar (PointNum p))
style w1 w2 b1 b2 'Nowhere)]
[else w])]))
w)]
[((PointNum p) 'Nowhere) w]
[((PointNum p) 'WhiteBar) w]
[((PointNum p) 'BlackBar) w]
[((PointNum p) 'BlackOff) w]
[((PointNum p) 'WhiteOff)
(if (legal-move?
(Game board turn moves) 'WhiteBar (PointNum p))
(World
(apply-move (Game board turn moves) (PointNum p)
'WhiteOff) style w1 w2 b1 b2 'Nowhere)
w)]
[((PointNum p) 'WhiteDice) w]
[((PointNum p) 'BlackDice) w]
[((PointNum p) (PointNum p))
(World
(Game board turn moves) style w1 w2 b1 b2 'Nowhere)]
[((PointNum p) (PointNum q))
(if (legal-move?
(Game board turn moves) (PointNum p) (PointNum q))
(local
{(define ppt : Point (list-ref pts (- p 1)))
(define qpt : Point (list-ref pts (- q 1)))}
(match qpt
['EmptyPoint
(World
(apply-move (Game board turn moves)
(PointNum p) (PointNum q))
style w1 w2 b1 b2 'Nowhere)]
[(OccupiedPoint color count)
(cond
[(player=? 'White color)
(World
(apply-move (Game board turn moves)
(PointNum p) (PointNum q))
style w1 w2 b1 b2 'Nowhere)]
[(= count 1)
(World
(apply-move (Game board turn moves)
(PointNum p) (PointNum q))
style w1 w2 b1 b2 'Nowhere)]
[else w])]))
w)])]))]
[_ w])]))]))
(: draw : World -> Image)
;; draw: draw the backgammon World
;; parameter "w": the World struct
;; output: an image of the backgammon World
(define (draw w)
(match w
[(World (Game board turn moves) style w1 w2 b1 b2 cl)
(match style
[(Style r s _ _ _ _ _ _ _ _)
(local
{(define fin : Image
(if (game-over? (Game board turn moves))
(text
(string-append
(symbol->string
(winner (Game board turn moves))) "wins!") 20 'white)
empty-image))
(define clear : Image-Color (color 255 255 255 0))
(define die-w : Image (beside (white-die r w1)
(square (/ r 2) "solid" clear)
(white-die r w2)))
(define die-b : Image (beside (black-die r b1)
(square (/ r 2) "solid" clear)
(black-die r b2)))
(define bg : Image (draw-board style board))
(define highlight : Image
(rectangle (* 2 r) (* 10 r) "outline" 'yellow))
(define x : Integer
(match cl
[(PointNum p)
(cond
[(< p 7) (+ (* (- 13 p) 2 r) (* (- 13 p) s) (* 2 r) s)]
[(< p 13) (+ (* (- 13 p) 2 r) (* (- 13 p) s))]
[(< p 19) (+ (* (- p 12) 2 r) (* (- p 12) s))]
[else (+ (* (- p 12) 2 r) (* (- p 12) s) (* 2 r) s)])]
['BlackBar (+ (* 7 s) (* 14 r))]
['WhiteBar (+ (* 7 s) (* 14 r))]
[_ 0]))
(define y : Integer
(match cl
[(PointNum p) (if (< p 13) (* 21 r) (* 6 r))]
['BlackBar (* 21 r)]
['WhiteBar (* 6 r)]
[_ 0]))
(define img : Image
(overlay
fin
(place-image
die-w
(+ (/ (+ (* 7 s) (* 12 r)) 2) r) (/ (image-height bg) 2)
(place-image
die-b
(+ (/ (+ (* 7 s) (* 12 r)) 2) (* 15 r) (* 7 s))
(/ (image-height bg) 2)
bg))))}
(if (and (> x 0) (> y 0)) (place-image highlight x y img) img))])]))
(: key : World String -> World)
;; key: manifest appropriate reactions in the backgammon world,
;; according to given key press
;; parameter "w": the World struct
;; parameter "k": the key pressed
;; output: the updated World struct, given the effect of the user key press
(define (key w k)
(match k
["u" (error "undo")]
["s" (begin (save-game! w) w)]
["l" (load-game (World-style w))]
[_ w]))
(: run : Style -> World)
;; run: run the backgammon game
;; parameter "style": board style as specified by a Style struct
;; output: the interactive World program
(define (run style)
(local
{(: initial-roll : Integer -> (Listof Integer))
(define (initial-roll max)
(local
{(define first-roll : (Listof Integer) (list (roll max) (roll max)))}
(if (= (list-ref first-roll 0) (list-ref first-roll 1))
(initial-roll max)
first-roll)))
(define i-roll : (Listof Integer) (initial-roll 6))
(define w1 : Integer (list-ref i-roll 0))
(define b1 : Integer (list-ref i-roll 1))
(define turn : Player
(if (> w1 b1) 'White 'Black))}
(big-bang (World (Game initial-board turn i-roll) style w1 0 b1 0 'Nowhere)
: World
[to-draw draw]
[on-mouse react-to-mouse]
[on-key key])))
;; === saving a game
;; convert a text representation of an Integer to an Integer
;; raise an error if the string is not a number
;; return the integer part of the resulting number only
;; (this is intended only to be used with integers)
(: string->integer : String -> Integer)
(define (string->integer s)
(local
{(define conv : (U Complex False) (string->number s))}
(if (complex? conv) (exact-round (real-part conv))
(error "string->integer: invalid integer"))))
(: points->string : (Listof Point) -> String)
;; points->string: convert a list of Point into its string representation
;; parameter "points": the list of points
;; output: the string representation of the list of points
(define (points->string points)
(local
{(: helper : (Listof Point) -> String)
(define (helper pts)
(match pts
['() ""]
[(cons hd tl)
(match hd
['EmptyPoint
(string-append "_ " (points->string tl))]
[(OccupiedPoint 'Black count)
(string-append "B" (number->string count) " " (points->string tl))]
[(OccupiedPoint 'White count)
(string-append
"W" (number->string count) " " (points->string tl))])]))}
(string-trim (helper points))))
(check-expect (points->string (Board-points initial-board))
"B2 _ _ _ _ W5 _ W3 _ _ _ B5 W5 _ _ _ B3 _ B5 _ _ _ _ W2")
(: string->points : String -> (Listof Point))
;; string->points: convert a string representation of a list of Point back into
;; a list of Point
;; parameter "str": the string representation of the list of Point
;; output: the list of points represented by the string
(define (string->points str)
(local
{(define l : (Listof String) (string-split str " "))
(: helper : (Listof String) -> (Listof Point))
(define (helper xs)
(match xs
['() '()]
[(cons hd tl)
(cond
[(char=? #\B (string-ref hd 0))
(cons (OccupiedPoint 'Black (string->integer (substring hd 1)))
(helper tl))]
[(char=? #\W (string-ref hd 0))
(cons (OccupiedPoint 'White (string->integer (substring hd 1)))
(helper tl))]
[else (cons 'EmptyPoint (helper tl))])]))}
(helper l)))
(check-expect
(string->points "B2 _ _ _ _ W5 _ W3 _ _ _ B5 W5 _ _ _ B3 _ B5 _ _ _ _ W2")
(Board-points initial-board))
(: board->string : Board -> String)
;; board->string: convert a Board struct into its string representation
;; parameter "board": the Board struct
;; output: the string representation of the Board struct
(define (board->string board)
(match board
[(Board pts b-bar w-bar b-off w-off)
(string-append (points->string pts) "|" (number->string b-bar) "|"
(number->string w-bar) "|" (number->string b-off) "|"
(number->string w-off))]))
(check-expect (board->string initial-board)
"B2 _ _ _ _ W5 _ W3 _ _ _ B5 W5 _ _ _ B3 _ B5 _ _ _ _ W2|0|0|0|0")
(: string->board : String -> Board)
;; string->board: convert a string representation of a Board struct back into a
;; Board struct
;; parameter "str": the string representation of the Board struct
;; output: the Board struct represented by the string
(define (string->board str)
(local
{(define l : (Listof String) (string-split str "|"))
(define pts : String (list-ref l 0))}
(Board (string->points pts) (string->integer (list-ref l 1))
(string->integer (list-ref l 2)) (string->integer (list-ref l 3))
(string->integer (list-ref l 4)))))
(check-expect
(string->board
"B2 _ _ _ _ W5 _ W3 _ _ _ B5 W5 _ _ _ B3 _ B5 _ _ _ _ W2|0|0|0|0")
initial-board)
(: game->string : Game -> String)
;; game->string: convert a Game struct into its string representation
;; parameter "game": the Game struct
;; output: the string representation of the Game struct
(define (game->string game)
(match game
[(Game board turn moves)
(local
{(define player : String (if (player=? turn 'Black) "B" "W"))
(: helper : (Listof Integer) -> String)
(define (helper is)
(match is
['() ""]
[(cons hd tl)
(string-append (number->string hd) " " (helper tl))]))}
(string-append
(board->string board) "@" player "@" (string-trim (helper moves))))]))
(check-expect
(game->string (Game initial-board 'White (list 2 6)))
"B2 _ _ _ _ W5 _ W3 _ _ _ B5 W5 _ _ _ B3 _ B5 _ _ _ _ W2|0|0|0|0@W@2 6")
(: string->game : String -> Game)
;; string->game: convert a string representation of a Game struct back into a
;; Game struct
;; parameter "str": the string representation of the Game struct
;; output: the Game struct represented by the string
(define (string->game str)
(local
{(define l : (Listof String) (string-split str "@"))
(define board : Board (string->board (list-ref l 0)))
(define turn : Player (if (string=? (list-ref l 1) "B") 'Black 'White))
(define moves : (Listof Integer)
(map string->integer (string-split (list-ref l 2) " ")))}
(Game board turn moves)))
(check-expect
(string->game
"B2 _ _ _ _ W5 _ W3 _ _ _ B5 W5 _ _ _ B3 _ B5 _ _ _ _ W2|0|0|0|0@W@2 6")
(Game initial-board 'White (list 2 6)))
(: world->string : World -> String)
;; world->string: convert a World struct into its string representation
;; parameter "w": the World struct
;; output: the string representation of the World struct
(define (world->string w)
(match w
[(World game _ w1 w2 b1 b2 _)
(string-append (game->string game) "%" (number->string w1) "%"
(number->string w2) "%" (number->string b1) "%"
(number->string b2))]))
(check-expect
(world->string
(World (Game initial-board 'Black (list 2 4)) test-style 1 6 2 4 'Nowhere))
"B2 _ _ _ _ W5 _ W3 _ _ _ B5 W5 _ _ _ B3 _ B5 _ _ _ _ W2|0|0|0|0@B@2 4%1%6%2%4")
(: string->world : Style String -> World)
;; string->world: convert a string representation of a World struct back into a
;; World struct
;; parameter "style": the Style struct to use when reconstructing the World
;; parameter "str": the string representation of the World struct
;; output: the World struct represented by the string
(define (string->world style str)
(local
{(define l : (Listof String) (string-split str "%"))
(define game : Game (string->game (list-ref l 0)))
(define w1 : Integer (string->integer (list-ref l 1)))
(define w2 : Integer (string->integer (list-ref l 2)))
(define b1 : Integer (string->integer (list-ref l 3)))
(define b2 : Integer (string->integer (list-ref l 4)))}
(World game style w1 w2 b1 b2 'Nowhere)))
;; prompt the user for an output file location
;; then, save the game to that file
;; do nothing if the user cancels
(: save-game! : World -> Void)
(define (save-game! w)
(local
{(define path : (U Path False) (put-file))}
(if (path? path)
(begin
(write-string (world->string w)
(open-output-file path))
(void))
(void))))
;; ask the user to choose a file
;; then load an in-progress game from that file
;; use the provided Style to make a new World
;; raise an error if the user cancels or if something goes wrong
(: load-game : Style -> World)
(define (load-game s)
(local
{(define path : (U Path False) (get-file))}
(if (path? path)
(string->world s (port->string (open-input-file path)))
(error "load-game: user cancelled"))))
(test)
\ No newline at end of file
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or sign in to comment