594 lines
22 KiB
Racket
594 lines
22 KiB
Racket
(module gui mzscheme
|
|
(require "board.rkt"
|
|
"moves.rkt"
|
|
mred
|
|
mzlib/class
|
|
mzlib/list
|
|
mzlib/etc)
|
|
|
|
(provide show-board
|
|
board-canvas%
|
|
draw-board
|
|
for-each-piece/position
|
|
find-main-coordinates
|
|
find-home-row-coordinates
|
|
get-cell-size
|
|
get-piece-size
|
|
pawn-drawn-color
|
|
|
|
(struct home-row-c (count color))
|
|
(struct main-c (count))
|
|
(struct start-c (color))
|
|
(struct home-c (color)))
|
|
|
|
;; a coordinate is either
|
|
;; - (make-home-row-c number color)
|
|
;; - (make-main-c number)
|
|
;; - (make-start-c color)
|
|
;; - (make-home-c color)
|
|
;; inspectors are to allow comparison with equal?
|
|
(define-struct home-row-c (count color) (make-inspector))
|
|
(define-struct main-c (count) (make-inspector))
|
|
(define-struct start-c (color) (make-inspector))
|
|
(define-struct home-c (color) (make-inspector))
|
|
|
|
(define (get-cell-size horizontal? w h)
|
|
(if horizontal?
|
|
(values (* w 1/9) (* h 1/24))
|
|
(values (* w 1/24) (* h 1/9))))
|
|
|
|
(define colors
|
|
'((green . "limegreen")
|
|
(red . "red")
|
|
(yellow . "gold")
|
|
(blue . "blue")
|
|
(black . "black")
|
|
(safety . "purple")
|
|
(track-background . "light blue")))
|
|
|
|
(define (pawn-drawn-color c)
|
|
(let* ([clr-str (assq c colors)]
|
|
[color-obj (make-object color% (cdr clr-str))]
|
|
[move-up (lambda (x) (+ x (quotient (- 255 x) 3)))]
|
|
[red (move-up (send color-obj red))]
|
|
[green (move-up (send color-obj green))]
|
|
[blue (move-up (send color-obj blue))])
|
|
(send color-obj set red green blue)
|
|
color-obj))
|
|
|
|
(define circle-gap 1/20)
|
|
|
|
(define (set-color dc color)
|
|
(send dc set-pen (send the-pen-list find-or-create-pen (cdr (assq color colors)) 1 'solid))
|
|
(send dc set-brush (send the-brush-list find-or-create-brush (cdr (assq color colors)) 'solid)))
|
|
|
|
(define draw-board
|
|
(opt-lambda (board dc w h dx dy draw-pieces?)
|
|
(let ([smoothing (send dc get-smoothing)])
|
|
(send dc set-smoothing 'aligned)
|
|
(set-color dc 'track-background)
|
|
(send dc draw-rectangle (+ dx 0) (+ dy (* h 1/3)) w (* h 1/3))
|
|
(send dc draw-rectangle (+ dx (* w 1/3)) (+ dy 0) (* w 1/3) h)
|
|
|
|
(set-color dc 'blue)
|
|
(send dc draw-ellipse
|
|
(+ dx (* w circle-gap)) (+ dy (* h circle-gap 1/2))
|
|
(- (/ w 3) (* w circle-gap)) (- (/ h 3) (* h circle-gap)))
|
|
(send dc draw-rectangle (+ dx (* w (- 1/2 1/18))) (+ dy 0) (* w 1/9) (/ h 3))
|
|
(send dc draw-polygon
|
|
(list (make-object point% (* w 1/3) (* h 1/3))
|
|
(make-object point% (* w 2/3) (* h 1/3))
|
|
(make-object point% (* w 1/2) (* h 1/2)))
|
|
dx
|
|
dy)
|
|
|
|
(set-color dc 'red)
|
|
(send dc draw-ellipse
|
|
(+ dx (* w 2/3) (* h circle-gap 1/2))
|
|
(+ dy (* h circle-gap))
|
|
(- (/ w 3) (* w circle-gap))
|
|
(- (/ h 3) (* h circle-gap)))
|
|
(send dc draw-rectangle (+ dx (* w 2/3)) (+ dy (* h (- 1/2 1/18))) (/ w 3) (* h 1/9))
|
|
(send dc draw-polygon
|
|
(list (make-object point% (* w 2/3) (* h 1/3))
|
|
(make-object point% (* w 2/3) (* h 2/3))
|
|
(make-object point% (* w 1/2) (* h 1/2)))
|
|
dx
|
|
dy)
|
|
|
|
(set-color dc 'yellow)
|
|
(send dc draw-ellipse
|
|
(+ dx (* w circle-gap 1/2)) (+ dy (* h 2/3))
|
|
(- (/ w 3) (* w circle-gap)) (- (/ h 3) (* h circle-gap)))
|
|
(send dc draw-rectangle (+ dx 0) (+ dy (* h (- 1/2 1/18))) (/ w 3) (* h 1/9))
|
|
(send dc draw-polygon
|
|
(list (make-object point% (* w 1/3) (* h 1/3))
|
|
(make-object point% (* w 1/3) (* h 2/3))
|
|
(make-object point% (* w 1/2) (* h 1/2)))
|
|
dx
|
|
dy)
|
|
|
|
(set-color dc 'green)
|
|
(send dc draw-ellipse
|
|
(+ dx (* w 2/3)) (+ dy (* h 2/3) (* h circle-gap 1/2))
|
|
(- (/ w 3) (* w circle-gap)) (- (/ h 3) (* h circle-gap)))
|
|
(send dc draw-rectangle (+ dx (* w (- 1/2 1/18))) (+ dy (* h 2/3)) (* w 1/9) (/ h 3))
|
|
(send dc draw-polygon
|
|
(list (make-object point% (* w 1/3) (* h 2/3))
|
|
(make-object point% (* w 2/3) (* h 2/3))
|
|
(make-object point% (* w 1/2) (* h 1/2)))
|
|
dx
|
|
dy)
|
|
|
|
(set-color dc 'safety)
|
|
|
|
(send dc draw-rectangle
|
|
(+ dx (* w 4/9))
|
|
(+ dy 0)
|
|
(* w 1/9)
|
|
(* h 1/3 1/8))
|
|
(send dc draw-rectangle
|
|
(+ dx (* w 4/9))
|
|
(+ dy (* h (- 1 (* 1/3 1/8))))
|
|
(* w 1/9)
|
|
(* h 1/3 1/8))
|
|
(send dc draw-rectangle
|
|
(+ dx (* w 5/9))
|
|
(+ dy (* h 1/3 4/8))
|
|
(* w 1/9)
|
|
(* h 1/3 1/8))
|
|
(send dc draw-rectangle
|
|
(+ dx (* w 3/9))
|
|
(+ dy (* h 19/24))
|
|
(* w 1/9)
|
|
(* h 1/3 1/8))
|
|
|
|
(send dc draw-rectangle
|
|
(+ dx (* w (- 1 (* 1/3 1/8))))
|
|
(+ dy (* h 4/9))
|
|
(* w 1/3 1/8)
|
|
(* h 1/9))
|
|
(send dc draw-rectangle
|
|
(+ dx 0)
|
|
(+ dy (* h 4/9))
|
|
(* w 1/3 1/8)
|
|
(* h 1/9))
|
|
(send dc draw-rectangle
|
|
(+ dx (* w 4/24))
|
|
(+ dy (* h 1/3))
|
|
(* w 1/3 1/8)
|
|
(* h 1/3 1/3))
|
|
(send dc draw-rectangle
|
|
(+ dx (* w 19/24))
|
|
(+ dy (* h 5/9))
|
|
(* w 1/3 1/8)
|
|
(* h 1/3 1/3))
|
|
|
|
;; blue entry
|
|
(send dc draw-rectangle
|
|
(+ dx (* w 3/9))
|
|
(+ dy (* h 1/3 4/8))
|
|
(* w 1/9)
|
|
(* h 1/3 1/8))
|
|
|
|
;; green entry
|
|
(send dc draw-rectangle
|
|
(+ dx (* w 5/9))
|
|
(+ dy (* h 19/24))
|
|
(* w 1/9)
|
|
(* h 1/24))
|
|
|
|
;; yellow entry
|
|
(send dc draw-rectangle
|
|
(+ dx (* w 4/24))
|
|
(+ dy (* h 5/9))
|
|
(* w 1/24)
|
|
(* h 1/9))
|
|
|
|
;; red entry
|
|
(send dc draw-rectangle
|
|
(+ dx (* w 19/24))
|
|
(+ dy (* h 1/3))
|
|
(* w 1/24)
|
|
(* h 1/9))
|
|
|
|
(set-color dc 'blue)
|
|
(send dc draw-polygon
|
|
(list (make-object point% (* w 3/9) (* h 4/24))
|
|
(make-object point% (* w 2/9) (* h 5/24))
|
|
(make-object point% (* w 4/9) (* h 5/24)))
|
|
dx
|
|
dy)
|
|
|
|
(set-color dc 'green)
|
|
(send dc draw-polygon
|
|
(list (make-object point% (* w 5/9) (* h 19/24))
|
|
(make-object point% (* w 6/9) (* h 20/24))
|
|
(make-object point% (* w 7/9) (* h 19/24)))
|
|
dx
|
|
dy)
|
|
|
|
|
|
(set-color dc 'yellow)
|
|
(send dc draw-polygon
|
|
(list (make-object point% (* w 4/24) (* h 6/9))
|
|
(make-object point% (* w 5/24) (* h 5/9))
|
|
(make-object point% (* w 5/24) (* h 7/9)))
|
|
dx
|
|
dy)
|
|
|
|
|
|
(set-color dc 'red)
|
|
(send dc draw-polygon
|
|
(list (make-object point% (* w 20/24) (* h 3/9))
|
|
(make-object point% (* w 19/24) (* h 4/9))
|
|
(make-object point% (* w 19/24) (* h 2/9)))
|
|
dx
|
|
dy)
|
|
|
|
(set-color dc 'black)
|
|
|
|
(let loop ([i 7])
|
|
(unless (zero? i)
|
|
(send dc draw-line
|
|
(+ dx (* w 1/3))
|
|
(+ dy (+ (* h 2/3) (* (* h 1/3) (/ i 8))))
|
|
(+ dx (* w 2/3))
|
|
(+ dy (+ (* h 2/3) (* (* h 1/3) (/ i 8)))))
|
|
(send dc draw-line
|
|
(+ dx (* w 1/3))
|
|
(+ dy (* (* h 1/3) (/ i 8)))
|
|
(+ dx (* w 2/3))
|
|
(+ dy (* (* h 1/3) (/ i 8))))
|
|
(send dc draw-line
|
|
(+ dx (+ (* w 2/3) (* (* w 1/3) (/ i 8))))
|
|
(+ dy (* h 1/3))
|
|
(+ dx (+ (* w 2/3) (* (* w 1/3) (/ i 8))))
|
|
(+ dy (* h 2/3)))
|
|
(send dc draw-line
|
|
(+ dx (* (* w 1/3) (/ i 8)))
|
|
(+ dy (* h 1/3))
|
|
(+ dx (* (* w 1/3) (/ i 8)))
|
|
(+ dy (* h 2/3)))
|
|
(loop (- i 1))))
|
|
|
|
(when draw-pieces?
|
|
(draw-pieces board dc w h dx dy))
|
|
|
|
(send dc set-smoothing smoothing))))
|
|
|
|
;; piece : color left top coordinate -> void
|
|
(define (for-each-piece/position board w h piece)
|
|
(let* ([piece-size (get-piece-size w h)]
|
|
[call-out
|
|
(lambda (ent x y horizontal? coordinate)
|
|
(let* ([pawn (car ent)])
|
|
(cond
|
|
[(null? (cdr ent))
|
|
(piece pawn (- x (/ piece-size 2)) (- y (/ piece-size 2)) coordinate)]
|
|
[else
|
|
(let ([pawn2 (cadr ent)])
|
|
(cond
|
|
[horizontal?
|
|
(piece pawn (- x piece-size) (- y (/ piece-size 2)) coordinate)
|
|
(piece pawn2 x (- y (/ piece-size 2)) coordinate)]
|
|
[else
|
|
(piece pawn (- x (/ piece-size 2)) (- y piece-size) coordinate)
|
|
(piece pawn2 (- x (/ piece-size 2)) y coordinate)]))])))])
|
|
|
|
;; main board
|
|
(let loop ([i board-main-size])
|
|
(unless (zero? i)
|
|
(let ([ent (board-main-i board (- i 1))])
|
|
(unless (null? ent)
|
|
(let-values ([(x y horizontal?) (find-main-coordinates (- i 1) w h)])
|
|
(call-out ent x y horizontal? (make-main-c (- i 1)))))
|
|
(loop (- i 1)))))
|
|
|
|
;; home row
|
|
(let ([handle-home-row
|
|
(lambda (color)
|
|
(let loop ([i board-home-row-size])
|
|
(unless (zero? i)
|
|
(let ([ent (board-home-row-i board color (- i 1))])
|
|
(unless (null? ent)
|
|
(let-values ([(x y horizontal?) (find-home-row-coordinates color (- i 1) w h)])
|
|
(call-out ent x y horizontal? (make-home-row-c (- i 1) color)))))
|
|
(loop (- i 1)))))])
|
|
(handle-home-row 'red)
|
|
(handle-home-row 'green)
|
|
(handle-home-row 'blue)
|
|
(handle-home-row 'yellow))
|
|
|
|
;; home and start
|
|
(let ([handle-home/start
|
|
(lambda (color select coordinates coord horiz?)
|
|
(let* ([pawns (filter (lambda (x) (eq? (pawn-color x) color)) (select board))]
|
|
[num (length pawns)])
|
|
(let-values ([(mx my) (apply values (cdr (assoc color (coordinates w h piece-size))))])
|
|
(let ([do (lambda (pawn fx fy)
|
|
(piece pawn
|
|
(+ mx (* piece-size fx))
|
|
(+ my (* piece-size fy))
|
|
coord))])
|
|
(cond
|
|
[(= num 4)
|
|
(do (list-ref pawns 3) 0 0)
|
|
(do (list-ref pawns 2) -1 0)
|
|
(do (list-ref pawns 1) 0 -1)
|
|
(do (list-ref pawns 0) -1 -1)]
|
|
[(and horiz? (= num 3))
|
|
(do (list-ref pawns 2) 0 -1/2)
|
|
(do (list-ref pawns 1) -1 0)
|
|
(do (list-ref pawns 0) -1 -1)]
|
|
[(= num 3)
|
|
(do (list-ref pawns 2) -1/2 0)
|
|
(do (list-ref pawns 1) 0 -1)
|
|
(do (list-ref pawns 0) -1 -1)]
|
|
[(and horiz? (= num 2))
|
|
(do (list-ref pawns 1) -1/2 -1)
|
|
(do (list-ref pawns 0) -1/2 0)]
|
|
[(= num 2)
|
|
(do (list-ref pawns 1) -1 -1/2)
|
|
(do (list-ref pawns 0) 0 -1/2)]
|
|
[(= num 1)
|
|
(do (list-ref pawns 0) -1/2 -1/2)])))))])
|
|
(handle-home/start 'red board-home at-home-coordinates (make-home-c 'red) #t)
|
|
(handle-home/start 'green board-home at-home-coordinates (make-home-c 'green) #f)
|
|
(handle-home/start 'blue board-home at-home-coordinates (make-home-c 'blue) #f)
|
|
(handle-home/start 'yellow board-home at-home-coordinates (make-home-c 'yellow) #t)
|
|
(handle-home/start 'red board-start at-start-coordinates (make-start-c 'red) #t)
|
|
(handle-home/start 'green board-start at-start-coordinates (make-start-c 'green) #t)
|
|
(handle-home/start 'blue board-start at-start-coordinates (make-start-c 'blue) #t)
|
|
(handle-home/start 'yellow board-start at-start-coordinates (make-start-c 'yellow) #t))))
|
|
|
|
(define (draw-pieces board dc w h dx dy)
|
|
(for-each-piece/position
|
|
board w h
|
|
(lambda (pawn x y coord)
|
|
(let ([font (get-number-font (pawn-color pawn) w h)]
|
|
[str (number->string (pawn-id pawn))]
|
|
[old-font (send dc get-font)]
|
|
[old-fore (send dc get-text-foreground)]
|
|
[size (get-piece-size w h)]
|
|
[old-pen (send dc get-pen)]
|
|
[old-brush (send dc get-brush)])
|
|
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
|
(send dc set-brush (send the-brush-list find-or-create-brush (pawn-drawn-color (pawn-color pawn)) 'solid))
|
|
(send dc draw-ellipse (+ dx x) (+ dy y) size size)
|
|
(send dc set-font font)
|
|
(send dc set-text-foreground (get-number-color (pawn-color pawn)))
|
|
(send dc set-pen old-pen)
|
|
(send dc set-brush old-brush)
|
|
(send dc set-font old-font)))))
|
|
|
|
(define home-row-coordinates
|
|
(list (list 'red
|
|
#f
|
|
(vector (cons (+ 22/24 1/48) 1/2)
|
|
(cons (+ 21/24 1/48) 1/2)
|
|
(cons (+ 20/24 1/48) 1/2)
|
|
(cons (+ 19/24 1/48) 1/2)
|
|
(cons (+ 18/24 1/48) 1/2)
|
|
(cons (+ 17/24 1/48) 1/2)
|
|
(cons (+ 16/24 1/48) 1/2)))
|
|
(list 'yellow
|
|
#f
|
|
(vector (cons (+ 1/24 1/48) 1/2)
|
|
(cons (+ 2/24 1/48) 1/2)
|
|
(cons (+ 3/24 1/48) 1/2)
|
|
(cons (+ 4/24 1/48) 1/2)
|
|
(cons (+ 5/24 1/48) 1/2)
|
|
(cons (+ 6/24 1/48) 1/2)
|
|
(cons (+ 7/24 1/48) 1/2)))
|
|
(list 'blue
|
|
#t
|
|
(vector (cons 1/2 (+ 1/24 1/48))
|
|
(cons 1/2 (+ 2/24 1/48))
|
|
(cons 1/2 (+ 3/24 1/48))
|
|
(cons 1/2 (+ 4/24 1/48))
|
|
(cons 1/2 (+ 5/24 1/48))
|
|
(cons 1/2 (+ 6/24 1/48))
|
|
(cons 1/2 (+ 7/24 1/48))))
|
|
(list 'green
|
|
#t
|
|
(vector (cons 1/2 (+ 22/24 1/48))
|
|
(cons 1/2 (+ 21/24 1/48))
|
|
(cons 1/2 (+ 20/24 1/48))
|
|
(cons 1/2 (+ 19/24 1/48))
|
|
(cons 1/2 (+ 18/24 1/48))
|
|
(cons 1/2 (+ 17/24 1/48))
|
|
(cons 1/2 (+ 16/24 1/48))))))
|
|
|
|
(define (find-home-row-coordinates color index w h)
|
|
(let ([ent (assq color home-row-coordinates)])
|
|
(if ent
|
|
(let ([v (caddr ent)])
|
|
(if (< index (vector-length v))
|
|
(let ([crds (vector-ref v index)])
|
|
(values (* w (car crds)) (* h (cdr crds)) (cadr ent)))
|
|
(values 0 0 #f)))
|
|
(values 0 0 #f))))
|
|
|
|
(define main-coordinates
|
|
(vector
|
|
;; safety between yellow and green
|
|
(list 1/2 (+ 23/24 1/48) #t)
|
|
|
|
;; row to the left of green, going up
|
|
(list (+ 5/9 1/18) (+ 23/24 1/48) #t)
|
|
(list (+ 5/9 1/18) (+ 22/24 1/48) #t)
|
|
(list (+ 5/9 1/18) (+ 21/24 1/48) #t)
|
|
(list (+ 5/9 1/18) (+ 20/24 1/48) #t)
|
|
(list (+ 5/9 1/18) (+ 19/24 1/48) #t)
|
|
(list (+ 5/9 1/18) (+ 18/24 1/48) #t)
|
|
(list (+ 5/9 1/18) (+ 17/24 1/48) #t)
|
|
(list (+ 5/9 1/18) (+ 16/24 1/48) #t)
|
|
|
|
;; row above green, going right
|
|
(list (+ 16/24 1/48) (+ 5/9 1/18) #f)
|
|
(list (+ 17/24 1/48) (+ 5/9 1/18) #f)
|
|
(list (+ 18/24 1/48) (+ 5/9 1/18) #f)
|
|
(list (+ 19/24 1/48) (+ 5/9 1/18) #f)
|
|
(list (+ 20/24 1/48) (+ 5/9 1/18) #f)
|
|
(list (+ 21/24 1/48) (+ 5/9 1/18) #f)
|
|
(list (+ 22/24 1/48) (+ 5/9 1/18) #f)
|
|
(list (+ 23/24 1/48) (+ 5/9 1/18) #f)
|
|
|
|
;; safety between green and red
|
|
(list (+ 23/24 1/48) 1/2 #f)
|
|
|
|
;; row below red, going left
|
|
(list (+ 23/24 1/48) (+ 3/9 1/18) #f)
|
|
(list (+ 22/24 1/48) (+ 3/9 1/18) #f)
|
|
(list (+ 21/24 1/48) (+ 3/9 1/18) #f)
|
|
(list (+ 20/24 1/48) (+ 3/9 1/18) #f)
|
|
(list (+ 19/24 1/48) (+ 3/9 1/18) #f)
|
|
(list (+ 18/24 1/48) (+ 3/9 1/18) #f)
|
|
(list (+ 17/24 1/48) (+ 3/9 1/18) #f)
|
|
(list (+ 16/24 1/48) (+ 3/9 1/18) #f)
|
|
|
|
;; row to the left of red, going up
|
|
(list (+ 5/9 1/18) (+ 7/24 1/48) #t)
|
|
(list (+ 5/9 1/18) (+ 6/24 1/48) #t)
|
|
(list (+ 5/9 1/18) (+ 5/24 1/48) #t)
|
|
(list (+ 5/9 1/18) (+ 4/24 1/48) #t)
|
|
(list (+ 5/9 1/18) (+ 3/24 1/48) #t)
|
|
(list (+ 5/9 1/18) (+ 2/24 1/48) #t)
|
|
(list (+ 5/9 1/18) (+ 1/24 1/48) #t)
|
|
(list (+ 5/9 1/18) (+ 0/24 1/48) #t)
|
|
|
|
;; safety between red and blue
|
|
(list 1/2 (+ 0/24 1/48) #t)
|
|
|
|
;; row to the right of blue, going down
|
|
(list (+ 3/9 1/18) (+ 0/24 1/48) #t)
|
|
(list (+ 3/9 1/18) (+ 1/24 1/48) #t)
|
|
(list (+ 3/9 1/18) (+ 2/24 1/48) #t)
|
|
(list (+ 3/9 1/18) (+ 3/24 1/48) #t)
|
|
(list (+ 3/9 1/18) (+ 4/24 1/48) #t)
|
|
(list (+ 3/9 1/18) (+ 5/24 1/48) #t)
|
|
(list (+ 3/9 1/18) (+ 6/24 1/48) #t)
|
|
(list (+ 3/9 1/18) (+ 7/24 1/48) #t)
|
|
|
|
;; row below blue, going left
|
|
(list (+ 7/24 1/48) (+ 3/9 1/18) #f)
|
|
(list (+ 6/24 1/48) (+ 3/9 1/18) #f)
|
|
(list (+ 5/24 1/48) (+ 3/9 1/18) #f)
|
|
(list (+ 4/24 1/48) (+ 3/9 1/18) #f)
|
|
(list (+ 3/24 1/48) (+ 3/9 1/18) #f)
|
|
(list (+ 2/24 1/48) (+ 3/9 1/18) #f)
|
|
(list (+ 1/24 1/48) (+ 3/9 1/18) #f)
|
|
(list (+ 0/24 1/48) (+ 3/9 1/18) #f)
|
|
|
|
;; safety between blue and yellow
|
|
(list (+ 0/24 1/48) 1/2 #f)
|
|
|
|
;; row above yellow to the right
|
|
(list (+ 0/24 1/48) (+ 5/9 1/18) #f)
|
|
(list (+ 1/24 1/48) (+ 5/9 1/18) #f)
|
|
(list (+ 2/24 1/48) (+ 5/9 1/18) #f)
|
|
(list (+ 3/24 1/48) (+ 5/9 1/18) #f)
|
|
(list (+ 4/24 1/48) (+ 5/9 1/18) #f)
|
|
(list (+ 5/24 1/48) (+ 5/9 1/18) #f)
|
|
(list (+ 6/24 1/48) (+ 5/9 1/18) #f)
|
|
(list (+ 7/24 1/48) (+ 5/9 1/18) #f)
|
|
|
|
;; row to the right of yellow, going down
|
|
(list (+ 3/9 1/18) (+ 16/24 1/48) #t)
|
|
(list (+ 3/9 1/18) (+ 17/24 1/48) #t)
|
|
(list (+ 3/9 1/18) (+ 18/24 1/48) #t)
|
|
(list (+ 3/9 1/18) (+ 19/24 1/48) #t)
|
|
(list (+ 3/9 1/18) (+ 20/24 1/48) #t)
|
|
(list (+ 3/9 1/18) (+ 21/24 1/48) #t)
|
|
(list (+ 3/9 1/18) (+ 22/24 1/48) #t)
|
|
(list (+ 3/9 1/18) (+ 23/24 1/48) #t)
|
|
))
|
|
|
|
|
|
(define (find-main-coordinates index w h)
|
|
(let ([e (vector-ref main-coordinates index)])
|
|
(values (* w (car e)) (* h (cadr e)) (caddr e))))
|
|
|
|
(define (at-start-coordinates w h piece-size)
|
|
`((blue ,(* w (+ 1/6 (* circle-gap 1/2))) ,(* h 1/6))
|
|
(red ,(* w 5/6) ,(* h (+ 1/6 (* circle-gap 1/2))))
|
|
(green ,(* w (- 5/6 (* circle-gap 1/2))) ,(* h 5/6))
|
|
(yellow ,(* w 1/6) ,(* h (- 5/6 (* circle-gap 1/2))))))
|
|
|
|
(define (at-home-coordinates w h piece-size)
|
|
`((blue ,(* w 1/2) ,(+ (* h 1/3) piece-size))
|
|
(red ,(- (* w 2/3) piece-size) ,(* h 1/2))
|
|
(green ,(* w 1/2) ,(- (* h 2/3) piece-size))
|
|
(yellow ,(+ (* w 1/3) piece-size) ,(* h 1/2))))
|
|
|
|
(define (get-number-font color w h)
|
|
(send the-font-list find-or-create-font
|
|
(cond
|
|
[(or (<= (* w 1/3 1/8) 10)
|
|
(<= (* h 1/3 1/8) 10))
|
|
8]
|
|
[(or (<= (* w 1/3 1/8) 15)
|
|
(<= (* h 1/3 1/8) 15))
|
|
9]
|
|
[else
|
|
12])
|
|
'default
|
|
'normal
|
|
'normal))
|
|
|
|
(define (get-number-color color)
|
|
(send the-color-database find-color
|
|
(case color
|
|
[(red) "white"]
|
|
[else "black"])))
|
|
|
|
(define (get-piece-size w h)
|
|
(min (* w 1/3 1/8)
|
|
(* h 1/3 1/8)))
|
|
|
|
(define black (make-object color% "black"))
|
|
|
|
(define board-canvas%
|
|
(class canvas%
|
|
(init-field [board (new-board)])
|
|
(inherit get-dc get-client-size)
|
|
(define/public (set-board b)
|
|
(set! board b)
|
|
(unless buffer (resize-bitmap))
|
|
(redraw-bitmap)
|
|
(on-paint))
|
|
|
|
(define buffer #f)
|
|
(define bdc (make-object bitmap-dc%))
|
|
|
|
(define/override (on-paint)
|
|
(unless buffer
|
|
(resize-bitmap))
|
|
(send (get-dc) draw-bitmap buffer 0 0))
|
|
|
|
(define/override (on-size w h)
|
|
(resize-bitmap))
|
|
|
|
(define/private (resize-bitmap)
|
|
(let-values ([(w h) (get-client-size)])
|
|
(set! buffer (make-object bitmap% w h))
|
|
(redraw-bitmap)))
|
|
|
|
(define/private (redraw-bitmap)
|
|
(let-values ([(w h) (get-client-size)])
|
|
(send bdc set-bitmap buffer)
|
|
(draw-board board bdc w h 0 0 #t)
|
|
(send bdc set-bitmap #f)))
|
|
|
|
(super-new)
|
|
|
|
(inherit min-client-width min-client-height)
|
|
(min-client-height 350)
|
|
(min-client-width 350)))
|
|
|
|
(define (show-board board)
|
|
(define f (new frame% (label "") (width 600) (height 600)))
|
|
(define c (new board-canvas% (parent f) (board board)))
|
|
(send f show #t)))
|