#lang typed/scheme
(provide (all-defined-out))
(require (planet cce/scheme:7/planet))
(require (this-package-in private/list)
(this-package-in private/image)
(this-package-in private/typed-scheme))
(define-type-alias Checker (U 'black 'white))
(define B 'black)
(define W 'white)
(: white? (Checker -> Boolean))
(: black? (Checker -> Boolean))
(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 : Integer]
[degree : Integer])
#: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)]
[prev : (Option moment)])
#:transparent)
(define-type-alias Moment moment)
(provide (struct-out board))
(define-struct: act
([moment : Moment]
[x : (Option Integer)]
[y : (Option Integer)]))
(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 Integer 'TOP 'BOT 'BAR))
(provide (struct-out source))
(define-struct: source ([dest : Dest] [i : Integer]) #:transparent)
(: board-count ((Checker -> Boolean) Board -> Integer))
(define (board-count p? b)
(+ (foldl (λ: ([p : [Listof Checker]] [s : Integer])
(+ (count p? p) s))
0
(board-points b))
(count p? (board-bar b))
(count p? (off-top (board-off b)))
(count p? (off-bot (board-off b)))))
(: points-add ([Listof [Listof Checker]] Checker Integer -> [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 Integer Integer))
(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))
#f))
(: 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 20)
(define CDIAM (* 2 CRADIUS))
(define DIE-SIZE (* 2 CRADIUS))
(define BRADIUS 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))]
[else
(circle CRADIUS 'solid c)]))
(: 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 : Integer])
(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 Integer -> [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 Integer Integer -> 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 Integer -> (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))))
(define (board-ref b s)
(list-ref
((cond [(eq? (source-dest s) 'BAR) board-bar]
[(eq? (source-dest s) 'TOP) (λ: ([b : Board]) (off-top (board-off b)))]
[(eq? (source-dest s) 'BOT) (λ: ([b : Board]) (off-bot (board-off b)))]
[else (λ: ([b : Board])
(list-ref (board-points b)
(source-dest s)))])
b)
(source-i s)))
(: 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)))))
(provide packed-up-board)
(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
#f))
(: moment-no-dice (Moment -> Moment))
(define (moment-no-dice m)
(make-moment (moment-board m)
empty
(moment-selected m)
m))
(: moment-flip (Moment -> Moment))
(define (moment-flip m)
(make-moment (board-flip (moment-board m))
(moment-dice m)
(moment-selected m)
(moment-prev 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)
m))
(: moment-undo (Moment -> Moment))
(define (moment-undo m)
(or (moment-prev m) m))
(: top? (Integer -> Boolean))
(define (top? y)
(<= 0 y QUAD-HEIGHT))
(: click-dest (Integer Boolean -> (Option Dest)))
(define (click-dest col top?)
(cond [(<= 1 col 6)
(if top?
(+ 11 col)
(+ 6 (- 6 col)))]
[(= 7 col) 'BAR]
[(<= 8 col 13)
(if top?
(+ 10 col)
(+ 6 (- 7 col)))]
[(<= 14 col) (if top? 'TOP 'BOT)]
[else #f]))
(: y->points-index (Integer -> Integer))
(define (y->points-index y)
(let ((a (quotient y CDIAM)))
(if (< a 7)
a
(- 13 a))))
(: y->bar-index (Integer Boolean -> Integer))
(define (y->bar-index y odd?)
(integer-ceiling (/ (- y QUAD-HEIGHT (if odd? CRADIUS 0)) CDIAM)))
(: maybe-dest (Integer Integer -> (Option Dest)))
(define (maybe-dest x y)
(click-dest (quotient x CDIAM)
(top? y)))
(: maybe-select-bar (Board Integer Integer -> (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 (- (quotient (sub1 n) 2) (- bi))))
(and (<= (- (sub1 (quotient n 2)))
bi
(quotient n 2))
(board-bar-fetch b (sub1 (- (quotient n 2) (- bi))))))))))
(: maybe-select (Board Integer Integer -> (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 Integer Integer -> Moment))
(define (moment-maybe-move w x y)
(let ((d (maybe-dest x y)))
(if d
(let ((s (moment-selected w)))
(if s
(make-moment (board-add (moment-board w)
s (moment-selected w)
d)
(moment-dice w)
#f
w)
(error "barf")))
w)))
(: moment-maybe-select (Moment Integer Integer -> 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)
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 Integer Integer 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]))
(: peck (World Key -> (U World Package)))
(define (peck w k)
(cond [(act? w)
(cond [(and (key=? (cast key-event? "D") k)
(not (moment-selected (act-moment w))))
(make-package (make-pas (moment-no-dice (act-moment w)))
'(passive))]
[(key=? (cast key-event? "R") k)
(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)]))