#lang typed/racket
(provide (all-defined-out))
(require (planet dvanhorn/typed/util)
(planet dvanhorn/typed/list)
(planet dvanhorn/typed/2htdp/image))
(define-type-alias Checker (U 'black 'white))
(: checker? (Any -> Boolean : Checker))
(define (checker? x)
(or (eq? x 'black) (eq? x 'white))
(cond [(eq? x 'black) true]
[(eq? x 'white) true]
[else false]))
(define B 'black)
(define W 'white)
(: white? (Checker -> Boolean : 'white))
(: black? (Checker -> Boolean : 'black))
(define (white? c) (symbol=? c W))
(define (black? c) (symbol=? c B))
(provide (struct-out board))
(define-struct: board
([points : [Listof [Listof Checker]]]
[bar : [Listof Checker]]
[off : off])
#:transparent)
(define-type-alias Board board)
(provide (struct-out off))
(define-struct: off
([top : [Listof Checker]]
[bot : [Listof Checker]])
#:transparent)
(provide (struct-out die))
(define-struct: die
([val : Nat]
[degree : Nat])
#:transparent)
(define-type-alias Die die)
(define-type-alias Dice [Listof Die])
(provide (struct-out moment))
(define-struct: moment
([board : Board]
[dice : Dice]
[selected : (Option Checker)])
#:transparent)
(define-type-alias Moment moment)
(provide (struct-out board))
(define-struct: act
([moment : Moment]
[x : (Option Nat)]
[y : (Option Nat)]))
(provide (struct-out pas))
(define-struct: pas ([moment : Moment]))
(define-type-alias World (U act pas))
(: lift-wrapped (case-lambda ((Moment -> Moment) -> (act -> act))
((Moment -> Moment) -> (pas -> pas))))
(define (lift-wrapped s2s)
(λ (w)
(cond [(act? w)
(make-act (s2s (act-moment w))
(act-x w)
(act-y w))]
[(pas? w)
(make-pas (s2s (pas-moment w)))])))
(define-type-alias Dest (U Nat 'TOP 'BOT 'BAR))
(provide (struct-out source))
(define-struct: source ([dest : Dest] [i : Nat]) #:transparent)
(: board-count ((Checker -> Boolean) Board -> Nat))
(define (board-count p? b)
(+ (foldl (λ: ([p : [Listof Checker]] [s : Nat])
(+ (count p? p)
s))
0
(board-points b))
(cast exact-nonnegative-integer? (count p? (board-bar b)))
(cast exact-nonnegative-integer? (count p? (off-top (board-off b))))
(cast exact-nonnegative-integer? (count p? (off-bot (board-off b))))))
(: points-add ([Listof [Listof Checker]] Checker Nat -> [Listof [Listof Checker]]))
(define (points-add pts c i)
(replace-at pts (append (list-ref pts i) (list c)) i))
(define-type-alias Checker-SExp Checker)
(define-type-alias Die-SExp (List Nat Nat))
(define-type-alias Dice-SExp [Listof Die-SExp])
(define-type-alias Board-SExp
(List (Listof (Listof Checker-SExp))
(Listof Checker-SExp)
(Listof Checker-SExp)
(Listof Checker-SExp)))
(define-type-alias Moment-SExp
(List Board-SExp Dice-SExp (Option Checker-SExp)))
(: moment->sexp (Moment -> Moment-SExp))
(define (moment->sexp m)
(list (board->sexp (moment-board m))
(dice->sexp (moment-dice m))
(maybe-checker->sexp (moment-selected m))))
(: sexp->moment (Moment-SExp -> Moment))
(define (sexp->moment s)
(make-moment (sexp->board (first s))
(sexp->dice (second s))
(sexp->maybe-checker (third s))))
(: board->sexp (Board -> Board-SExp))
(define (board->sexp b)
(list (map (λ: ([p : [Listof Checker]])
(map checker->sexp p))
(board-points b))
(map checker->sexp (board-bar b))
(map checker->sexp (off-top (board-off b)))
(map checker->sexp (off-bot (board-off b)))))
(: sexp->board (Board-SExp -> Board))
(define (sexp->board s)
(make-board (map (λ: ([p : [Listof Checker-SExp]])
(map sexp->checker p))
(first s))
(map sexp->checker (second s))
(make-off (map sexp->checker (third s))
(map sexp->checker (third (rest s))))))
(: checker->sexp (Checker -> Checker-SExp))
(define (checker->sexp c) c)
(: dice->sexp (Dice -> Dice-SExp))
(define (dice->sexp ds)
(map (λ: ([d : Die])
(list (die-val d) (die-degree d)))
ds))
(: sexp->checker (Checker-SExp -> Checker))
(define (sexp->checker s) s)
(: sexp->dice (Dice-SExp -> Dice))
(define (sexp->dice s)
(map (λ: ([s : Die-SExp])
(make-die (first s) (second s)))
s))
(: sexp->maybe-checker ((Option Checker-SExp) -> (Option Checker)))
(define (sexp->maybe-checker s)
(and s (sexp->checker s)))
(: maybe-checker->sexp ((Option Checker) -> (Option Checker-SExp)))
(define (maybe-checker->sexp c)
(and c (checker->sexp c)))
(define: CRADIUS : Integer 20)
(define CDIAM (* 2 CRADIUS))
(define DIE-SIZE (* 2 CRADIUS))
(define: BRADIUS : Integer 5)
(define BORDER-CLR 'darkslateblue)
(define FLOOR-CLR 'slateblue)
(define QUAD-HEIGHT (* 7 CDIAM))
(define BOARD-HEIGHT (* 2 QUAD-HEIGHT))
(: checker->img (Checker -> Image))
(define (checker->img c)
(cond [(white? c)
(overlay (circle CRADIUS 'outline 'black)
(circle CRADIUS 'solid 'white))]
[(black? c)
(overlay (circle CRADIUS 'outline 'white)
(circle CRADIUS 'solid 'black))]))
(: point->img ([Listof Checker] -> Image))
(define (point->img p)
(above (hspace CDIAM)
(apply above0 (reverse (map checker->img p)))))
(: raw-points->img ([Listof [Listof Checker]] -> Image))
(define (raw-points->img ps)
(apply beside/align0 (ann "bottom" Y-Place)
(map point->img (reverse ps))))
(: fancy-point->img ([Listof Checker] -> Image))
(define (fancy-point->img p)
(cond [(> (length p) 6)
(overlay/align 'center
'bottom
(above (point->img (drop p 6))
(vspace CRADIUS))
(point->img (take p 6)))]
[else
(point->img p)]))
(: point-img (Checker -> Image))
(define (point-img c)
(let ((theta (* 2 (cast real? (atan 1/10)))))
(isosceles-triangle (/ CRADIUS (cast real? (sin (* 1/2 theta))))
(* theta (/ 180 pi))
'solid
c)))
(define die-sq-img
(square DIE-SIZE 'outline 'black))
(define bullet (circle BRADIUS 'solid 'black))
(define die-face-one
(overlay bullet die-sq-img))
(define die-face-two
(overlay/xy bullet
(- (* 5/8 DIE-SIZE))
(- (* 5/8 DIE-SIZE))
(overlay/xy bullet
(- (* 1/8 DIE-SIZE))
(- (* 1/8 DIE-SIZE))
die-sq-img)))
(define die-face-three
(overlay bullet die-face-two))
(define die-face-four
(overlay (rotate 90 die-face-two) die-face-two))
(define die-face-five
(overlay bullet die-face-four))
(define black-point-img (point-img 'black))
(define white-point-img (point-img 'white))
(define quadrant-background-img
(rectangle (* 6 CDIAM)
QUAD-HEIGHT
'solid
FLOOR-CLR))
(define quadrant-img
(overlay/align
'center 'bottom
(apply beside0
(build-list 6
(λ: ([i : Nat])
(if (even? i)
black-point-img
white-point-img)))) quadrant-background-img))
(define bar-img
(rectangle CDIAM QUAD-HEIGHT 'solid BORDER-CLR))
(: quadrant->img ([Listof [Listof Checker]] -> Image))
(define (quadrant->img ps)
(overlay/align 'center 'bottom
(raw-points->img ps)
quadrant-img))
(: checker-off->img (Checker -> Image))
(define (checker-off->img c)
(overlay (rectangle CDIAM
(* 1/2 CRADIUS)
'outline
(if (white? c) 'black 'white))
(rectangle CDIAM
(* 1/2 CRADIUS)
'solid
(if (white? c) 'white 'black))))
(: off->img ([Listof Checker] -> Image))
(define (off->img o)
(apply above0 (map checker-off->img o)))
(: board-quadrant (Board Nat -> [Listof [Listof Checker]]))
(define (board-quadrant b q)
(take (drop (board-points b) (* q 6)) 6))
(: top-board->img (Board -> Image))
(define (top-board->img b)
(rotate 180
(beside (overlay/align 'center 'bottom
(off->img (off-top (board-off b)))
bar-img)
(quadrant->img (board-quadrant b 3))
bar-img
(quadrant->img (board-quadrant b 2))
bar-img)))
(: bot-board->img (Board -> Image))
(define (bot-board->img b)
(beside bar-img
(quadrant->img (board-quadrant b 1))
bar-img
(quadrant->img (board-quadrant b 0))
(overlay/align 'center 'bottom
(off->img (off-bot (board-off b)))
bar-img)))
(: board->img (Board -> Image))
(define (board->img b)
(overlay (apply above0 (map checker->img (board-bar b)))
(above (top-board->img b)
(bot-board->img b))))
(: act-moment->img (Moment -> Image))
(define (act-moment->img w)
(overlay (beside (hspace (* 7 CDIAM))
(dice->img (moment-dice w)))
(board->img (moment-board w))))
(: pas-moment->img (Moment -> Image))
(define (pas-moment->img w)
(overlay (beside (rotate 180 (dice->img (moment-dice w)))
(hspace (* 7 CDIAM)))
(board->img (moment-board w))))
(: world->img (World -> Image))
(define (world->img w)
(cond [(act? w)
(let ((s (moment-selected (act-moment w))))
(if (and (act-x w) s)
(place-image (checker->img s)
(or (act-x w) 0)
(or (act-y w) 0)
(act-moment->img (act-moment w)))
(act-moment->img (act-moment w))))]
[(pas? w)
(overlay (text "Passive" 40 'red)
(pas-moment->img (pas-moment w)))]))
(define die-half-six
(overlay/align 'left 'center
(beside (hspace (* 1/2 BRADIUS))
(apply above0 (interleave (vspace (* 1/2 BRADIUS))
(make-list 3 bullet))))
die-sq-img))
(define die-face-six
(overlay die-half-six (rotate 180 die-half-six)))
(: die->img (Die -> Image))
(define (die->img d)
(rotate (die-degree d)
(overlay (list-ref (list die-face-one
die-face-two
die-face-three
die-face-four
die-face-five
die-face-six)
(die-val d))
(square DIE-SIZE 'solid 'white))))
(: dice->img (Dice -> Image))
(define (dice->img ds)
(apply beside0 (interleave (hspace DIE-SIZE)
(map die->img ds))))
(: board-remove-points (Board Nat Nat -> Board))
(define (board-remove-points b i j)
(make-board (replace-at (board-points b)
(remove-at (list-ref (board-points b)
i)
j)
i)
(board-bar b)
(board-off b)))
(: board-bar-fetch (Board Nat -> (List Checker Board)))
(define (board-bar-fetch b i)
(list (list-ref (board-bar b) i)
(make-board (board-points b)
(remove-at (board-bar b) i)
(board-off b))))
(: board-add (Board Checker Dest -> Board))
(define (board-add b c d)
(cond [(eq? 'TOP d)
(make-board (board-points b)
(board-bar b)
(make-off (cons c (off-top (board-off b)))
(off-bot (board-off b))))]
[(eq? 'BOT d)
(make-board (board-points b)
(board-bar b)
(make-off (off-top (board-off b))
(cons c (off-bot (board-off b)))))]
[(eq? 'BAR d)
(make-board (board-points b)
(cons c (board-bar b))
(board-off b))]
[else
(make-board (points-add (board-points b) c d)
(board-bar b)
(board-off b))]))
(: board-flip (Board -> Board))
(define (board-flip b)
(make-board (reverse (board-points b))
(reverse (board-bar b))
(make-off (off-bot (board-off b))
(off-top (board-off b)))))
(define packed-up-board
(make-board (make-list 24 empty)
empty
(make-off (make-list 15 B)
(make-list 15 W))))
(define initial-board
(make-board (list (list W W)
empty
empty
empty
empty
(list B B B B B)
empty
(list B B B)
empty
empty
empty
(list W W W W W)
(list B B B B B)
empty
empty
empty
(list W W W)
empty
(list W W W W W)
empty
empty
empty
empty
(list B B))
empty
(make-off empty empty)))
(define some-board0
(make-board (list (list W W)
empty
empty
empty
empty
(list B B B B B)
empty
(list B B B)
empty
empty
empty
(list W W W W W)
(list B B B B B)
empty
empty
empty
(list W W W)
empty
(list W W W W)
empty
empty
empty
(list W)
empty)
(list B B)
(make-off empty empty)))
(define some-board1
(make-board (list empty
empty
empty
empty
empty
(list B B B B B)
empty
(list B B B)
empty
empty
empty
empty
(list B B B B B)
empty
empty
empty
empty
empty
(list W W W W)
empty
empty
(list W)
(list W W W)
empty)
(list B B)
(make-off (list W W W W W W W)
empty)))
(define some-board2
(make-board (list empty
(list B B B)
empty
empty
(list B)
(list B B B)
empty
empty
empty
empty
empty
empty
empty
empty
empty
empty
empty
empty
(list W W W W)
empty
empty
(list W)
(list W W W)
empty)
empty
(make-off (list W W W W W W W)
(list B B B B B B B B))))
(define moment0
(make-moment initial-board
empty
#f))
(: moment-no-dice (Moment -> Moment))
(define (moment-no-dice m)
(make-moment (moment-board m)
empty
(moment-selected m)))
(: moment-flip (Moment -> Moment))
(define (moment-flip m)
(make-moment (board-flip (moment-board m))
(moment-dice m)
(moment-selected m)))
(: roll-dice (Moment -> Moment))
(define (roll-dice m)
(make-moment (moment-board m)
(list (make-die (random 6) (random 360))
(make-die (random 6) (random 360)))
(moment-selected m)))
(: top? (Nat -> Boolean))
(define (top? y)
(<= 0 y QUAD-HEIGHT))
(: click-dest (Nat Boolean -> (Option Dest)))
(define (click-dest col top?)
(cond [(<= 1 col 6)
(if top?
(+ 11 col)
(cast exact-nonnegative-integer?
(+ 6 (- 6 col))))]
[(= 7 col) 'BAR]
[(<= 8 col 13)
(if top?
(+ 10 col)
(cast exact-nonnegative-integer?
(+ 6 (- 7 col))))]
[(<= 14 col) (if top? 'TOP 'BOT)]
[else #f]))
(: y->points-index (Nat -> Nat))
(define (y->points-index y)
(let ((a (quotient y CDIAM)))
(cast exact-nonnegative-integer?
(if (< a 7)
a
(- 13 a)))))
(: y->bar-index (Nat Boolean -> Integer))
(define (y->bar-index y odd?)
(exact-ceiling (/ (- y QUAD-HEIGHT (if odd? CRADIUS 0)) CDIAM)))
(: maybe-dest (Nat Nat -> (Option Dest)))
(define (maybe-dest x y)
(click-dest (cast exact-nonnegative-integer? (quotient x CDIAM))
(top? y)))
(: maybe-select-bar (Board Nat Nat -> (Option (List Checker Board))))
(define (maybe-select-bar b x y)
(let ((n (length (board-bar b))))
(let ((o? (odd? n)))
(let ((bi (y->bar-index y o?)))
(if o?
(and (<= (- (quotient (sub1 n) 2))
bi
(quotient (sub1 n) 2))
(board-bar-fetch b
(cast exact-nonnegative-integer?
(+ (quotient (sub1 n) 2) bi))))
(and (<= (- (sub1 (quotient n 2)))
bi
(quotient n 2))
(board-bar-fetch b
(cast exact-nonnegative-integer?
(sub1 (+ (quotient n 2) bi))))))))))
(: maybe-select (Board Nat Nat -> (Option (List Checker Board))))
(define (maybe-select b x y)
(let ((d (maybe-dest x y)))
(and d
(cond [(eq? 'BAR d)
(maybe-select-bar b x y)]
[(eq? 'TOP d)
(and (cons? (off-top (board-off b)))
(list (first (off-top (board-off b)))
(make-board (board-points b)
(board-bar b)
(make-off (rest (off-top (board-off b)))
(off-bot (board-off b))))))]
[(eq? 'BOT d)
(and (cons? (off-bot (board-off b)))
(list (first (off-bot (board-off b)))
(make-board (board-points b)
(board-bar b)
(make-off (off-top (board-off b))
(rest (off-bot (board-off b)))))))]
[else
(let ((pt (list-ref (board-points b) d)))
(and (< (y->points-index y)
(length pt))
(list (list-ref pt (y->points-index y))
(board-remove-points b d (y->points-index y)))))]))))
(: moment-maybe-move (Moment Nat Nat -> Moment))
(define (moment-maybe-move w x y)
(let ((d (maybe-dest x y)))
(if d
(make-moment (board-add (moment-board w)
(cast checker? (moment-selected w))
d)
(moment-dice w)
#f)
w)))
(: moment-maybe-select (Moment Nat Nat -> Moment))
(define (moment-maybe-select w x y)
(let ((ms (maybe-select (moment-board w) x y)))
(if ms
(make-moment (second ms)
(moment-dice w)
(first ms))
w)))
(define-type-alias Message
(U (List 'initial)
(List 'active)
(List 'passive)
(List 'moment Moment-SExp)))
(require/typed 2htdp/universe
[opaque Package package?]
[opaque Mouse mouse-event?]
[opaque Key key-event?]
[make-package (World Message -> Package)]
[mouse=? (Mouse Mouse -> Boolean)]
[key=? (Key Key -> Boolean)])
(: squeek (World Nat Nat Mouse -> (U World Package)))
(define (squeek w x y m)
(cond [(act? w)
(let* ((s (act-moment w))
(s* (cond [(mouse=? m (cast mouse-event? "button-down"))
(cond [(moment-selected s)
(moment-maybe-move s x y)]
[else
(moment-maybe-select s x y)])]
[else s])))
(if (eq? s s*)
(make-act s x y)
(make-package
(make-act s* x y)
`(moment ,(moment->sexp s*)))))]
[else w]))
(: clean-squeek (World Integer Integer Mouse -> (U World Package)))
(define (clean-squeek w x y m)
(if (and (exact-nonnegative-integer? x)
(exact-nonnegative-integer? y))
(squeek w x y m)
w))
(: peck (World Key -> (U World Package)))
(define (peck w k)
(cond [(act? w)
(cond [(and (key=? k (cast key-event? "D"))
(not (moment-selected (act-moment w))))
(make-package (make-pas (moment-no-dice (act-moment w)))
'(passive))]
[(key=? k (cast key-event? "R"))
(let ((w* ((lift-wrapped roll-dice) w)))
(make-package
w*
`(moment ,(moment->sexp (act-moment w*)))))]
[else w])]
[else w]))
(: slurp (World Message -> World))
(define (slurp w msg)
(cond [(eq? (first msg) 'initial)
(make-act (moment-flip moment0) #f #f)]
[(eq? (first msg) 'active)
(make-act (moment-no-dice (pas-moment (cast pas? w))) #f #f)]
[(eq? msg 'passive)
(make-pas (act-moment (cast act? w)))]
[(and (eq? (first msg) 'moment)
(not (empty? (rest msg))))
(make-pas (moment-flip (sexp->moment (second msg))))]
[else
(error "Unkown message" msg)]))