485 lines
18 KiB
Scheme
485 lines
18 KiB
Scheme
(module checkers mzscheme
|
|
(require (lib "gl-board.ss" "games" "gl-board-game")
|
|
(lib "class.ss")
|
|
(lib "math.ss")
|
|
(lib "mred.ss" "mred")
|
|
(lib "gl-vectors.ss" "sgl")
|
|
(prefix gl- (lib "sgl.ss" "sgl"))
|
|
(lib "gl.ss" "sgl")
|
|
(lib "array.ss" "srfi" "25")
|
|
(lib "unit.ss")
|
|
"honu-bitmaps.ss")
|
|
|
|
(provide game-unit)
|
|
|
|
(define path (collection-path "games" "checkers"))
|
|
|
|
(define-struct image (width height rgba))
|
|
|
|
(define (argb->rgba argb)
|
|
(let* ((length (bytes-length argb))
|
|
(rgba (make-gl-ubyte-vector length)))
|
|
(let loop ((i 0))
|
|
(when (< i length)
|
|
(gl-vector-set! rgba (+ i 0) (bytes-ref argb (+ i 1)))
|
|
(gl-vector-set! rgba (+ i 1) (bytes-ref argb (+ i 2)))
|
|
(gl-vector-set! rgba (+ i 2) (bytes-ref argb (+ i 3)))
|
|
(gl-vector-set! rgba (+ i 3) (bytes-ref argb (+ i 0)))
|
|
(loop (+ i 4))))
|
|
rgba))
|
|
|
|
(define (bitmap->argb bmp)
|
|
(let* ((width (send bmp get-width))
|
|
(height (send bmp get-height))
|
|
(argb (make-bytes (* 4 width height) 255))
|
|
(dc (make-object bitmap-dc% bmp)))
|
|
(send dc get-argb-pixels 0 0 width height argb #f)
|
|
(when (send bmp get-loaded-mask)
|
|
(send dc set-bitmap (send bmp get-loaded-mask))
|
|
(send dc get-argb-pixels 0 0 width height argb #t))
|
|
(send dc set-bitmap #f)
|
|
argb))
|
|
|
|
(define (bitmap->image bmp)
|
|
(make-image (send bmp get-width) (send bmp get-height)
|
|
(argb->rgba (bitmap->argb bmp))))
|
|
|
|
(define (file->image file)
|
|
(bitmap->image (make-object bitmap% file)))
|
|
|
|
(define light-square-img (file->image (build-path path "light.jpg")))
|
|
(define light-square-color (gl-float-vector .7216 .6471 .5176 1))
|
|
(define dark-square-img (file->image (build-path path "dark.jpg")))
|
|
(define dark-square-color (gl-float-vector .4745 .3569 .2627 1))
|
|
|
|
(define (color-name->vector name darken?)
|
|
(let ([color (send the-color-database find-color name)]
|
|
[adj (if darken? sqr values)])
|
|
(unless color
|
|
(error 'color-name->vector "could not find ~e" name))
|
|
(gl-float-vector (adj (/ (send color red) 255))
|
|
(adj (/ (send color green) 255))
|
|
(adj (/ (send color blue) 255))
|
|
1.0)))
|
|
|
|
(define light-checker-img (bitmap->image honu-down-bitmap))
|
|
(define dark-checker-img (bitmap->image honu-bitmap))
|
|
|
|
(define-struct space-info (x y light?))
|
|
(define-struct piece-info (x y color king?) (make-inspector))
|
|
(define-struct moves (list forced-jump?))
|
|
|
|
(define checkers-view@
|
|
(unit
|
|
(import move)
|
|
(export add-space add-piece remove-piece move-piece set-turn show)
|
|
|
|
(define (get-space-draw-fn space)
|
|
(let* ((list-id (get-square-dl (space-info-light? space)
|
|
(send texture-box get-value)))
|
|
(sx (space-info-x space))
|
|
(sy (space-info-y space)))
|
|
(lambda ()
|
|
(gl-push-matrix)
|
|
(gl-translate sx sy 0)
|
|
(gl-call-list list-id)
|
|
(gl-pop-matrix))))
|
|
|
|
(define (add-space space)
|
|
(send board add-space (get-space-draw-fn space) space))
|
|
|
|
(define (get-piece-draw-fn piece glow?)
|
|
(let ((list-id (get-checker-dl (eq? 'red (piece-info-color piece))
|
|
(piece-info-king? piece)
|
|
(send texture-box get-value))))
|
|
(if glow?
|
|
(lambda (for-shadow?)
|
|
(gl-material-v 'front 'emission (gl-float-vector 0.15 0.15 0.15 1.0))
|
|
(gl-call-list ((if for-shadow? cdr car) list-id))
|
|
(gl-material-v 'front 'emission (gl-float-vector 0.0 0.0 0.0 1.0)))
|
|
(lambda (for-shadow?)
|
|
(gl-call-list ((if for-shadow? cdr car) list-id))))))
|
|
|
|
(define add-piece
|
|
(case-lambda
|
|
((piece) (add-piece piece #f))
|
|
((piece glow?)
|
|
(send board add-piece (+ .5 (piece-info-x piece)) (+ .5 (piece-info-y piece)) 0.0
|
|
(get-piece-draw-fn piece glow?)
|
|
piece))))
|
|
|
|
(define (move-piece from to-x to-y)
|
|
(remove-piece from)
|
|
(add-piece (make-piece-info to-x to-y (piece-info-color from) (piece-info-king? from))))
|
|
|
|
(define (remove-piece p)
|
|
(send board remove-piece p))
|
|
|
|
(define (internal-move old move-to)
|
|
(when (piece-info? old)
|
|
(move old move-to)))
|
|
|
|
(define (set-turn turn moves)
|
|
(let* ([pieces (send board get-pieces)])
|
|
(for-each (lambda (p)
|
|
(send board set-piece-draw p
|
|
(get-piece-draw-fn p #f))
|
|
(send board enable-piece p #f))
|
|
pieces)
|
|
(for-each (lambda (p)
|
|
(send board set-piece-draw p
|
|
(get-piece-draw-fn p #t))
|
|
(send board enable-piece p #t))
|
|
(moves-list moves)))
|
|
(send msg set-label
|
|
(if (null? (moves-list moves))
|
|
(format "~a wins!" (if (eq? turn 'red) "Black" "Red"))
|
|
(format "~a's turn~a"
|
|
(if (eq? turn 'red) "Red" "Black")
|
|
(if (moves-forced-jump? moves)
|
|
" - must take jump"
|
|
"")))))
|
|
|
|
(define f (new frame% (label "Checkers") (width 800) (height 600)))
|
|
(define board
|
|
(new gl-board% (parent f) (who "Checkers")
|
|
(min-x 0.0) (max-x 8.0) (min-y 0.0) (max-y 8.0)
|
|
(lift .35)
|
|
(move internal-move)))
|
|
(define hp (new horizontal-pane% (parent f) (stretchable-height #f)))
|
|
(define msg
|
|
(new message% (label "") (parent hp) (stretchable-width #t)))
|
|
(define texture-box
|
|
(new check-box% (label "Textured") (parent hp)
|
|
(callback
|
|
(lambda (box _)
|
|
(for-each
|
|
(lambda (s)
|
|
(send board set-space-draw s
|
|
(get-space-draw-fn s)))
|
|
(send board get-spaces))
|
|
(for-each
|
|
(lambda (p)
|
|
(send board set-piece-draw p
|
|
(get-piece-draw-fn p (send board enabled? p))))
|
|
(send board get-pieces))
|
|
(send board refresh)))))
|
|
(send texture-box set-value #t)
|
|
|
|
(define q
|
|
(send board with-gl-context
|
|
(lambda () (gl-new-quadric))))
|
|
|
|
(define-values (dark-tex light-tex dark-checker-tex light-checker-tex)
|
|
(send board with-gl-context
|
|
(lambda ()
|
|
(let ((x (glGenTextures 4)))
|
|
(values
|
|
(gl-vector-ref x 0)
|
|
(gl-vector-ref x 1)
|
|
(gl-vector-ref x 2)
|
|
(gl-vector-ref x 3))))))
|
|
|
|
(define (init-tex tex img)
|
|
(send board with-gl-context
|
|
(lambda ()
|
|
(glBindTexture GL_TEXTURE_2D tex)
|
|
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR)
|
|
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR)
|
|
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP)
|
|
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP)
|
|
(glTexImage2D GL_TEXTURE_2D 0 GL_RGBA (image-width img) (image-height img) 0
|
|
GL_RGBA GL_UNSIGNED_BYTE (image-rgba img)))))
|
|
|
|
(init-tex light-tex light-square-img)
|
|
(init-tex dark-tex dark-square-img)
|
|
(init-tex dark-checker-tex dark-checker-img)
|
|
(init-tex light-checker-tex light-checker-img)
|
|
|
|
(define (make-piece-dl color height tex shadow?)
|
|
(send board with-gl-context
|
|
(lambda ()
|
|
(let ((list-id (gl-gen-lists 1)))
|
|
(gl-quadric-draw-style q 'fill)
|
|
(gl-quadric-normals q 'smooth)
|
|
(gl-new-list list-id 'compile)
|
|
|
|
(when shadow?
|
|
(gl-disable 'lighting))
|
|
(gl-material-v 'front 'specular (gl-float-vector 1.0 1.0 1.0 1.0))
|
|
(gl-material 'front 'shininess 120.0)
|
|
|
|
(gl-material-v 'front 'ambient-and-diffuse color)
|
|
(gl-cylinder q .35 .35 height 25 1)
|
|
(gl-push-matrix)
|
|
(gl-translate 0.0 0.0 height)
|
|
|
|
(when (and tex (not shadow?))
|
|
(gl-enable 'texture-2d)
|
|
(glBindTexture GL_TEXTURE_2D tex)
|
|
(glTexEnvf GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE GL_DECAL)
|
|
(gl-quadric-texture q #t))
|
|
|
|
(gl-disk q 0.0 .35 25 1)
|
|
|
|
(when (and tex (not shadow?))
|
|
(gl-quadric-texture q #f)
|
|
(glTexEnvf GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE GL_MODULATE)
|
|
(gl-disable 'texture-2d))
|
|
|
|
(gl-pop-matrix)
|
|
|
|
(when shadow?
|
|
(gl-enable 'lighting))
|
|
(gl-end-list)
|
|
list-id))))
|
|
|
|
(define (make-tex-square-dl tex)
|
|
(send board with-gl-context
|
|
(lambda ()
|
|
(let ((list-id (gl-gen-lists 1)))
|
|
(gl-new-list list-id 'compile)
|
|
(gl-enable 'texture-2d)
|
|
(glBindTexture GL_TEXTURE_2D tex)
|
|
(gl-material-v 'front 'ambient-and-diffuse
|
|
(gl-float-vector 1 1 1 1))
|
|
(gl-begin 'polygon)
|
|
(gl-tex-coord 0.0 0.0)
|
|
(gl-vertex 0.0 0.0 0.0)
|
|
(gl-tex-coord 1.0 0.0)
|
|
(gl-vertex 1.0 0.0 0.0)
|
|
(gl-tex-coord 1.0 1.0)
|
|
(gl-vertex 1.0 1.0 0.0)
|
|
(gl-tex-coord 0.0 1.0)
|
|
(gl-vertex 0.0 1.0 0.0)
|
|
(gl-end)
|
|
(gl-disable 'texture-2d)
|
|
(gl-end-list)
|
|
list-id))))
|
|
|
|
(define (make-square-dl color)
|
|
(send board with-gl-context
|
|
(lambda ()
|
|
(let ((list-id (gl-gen-lists 1)))
|
|
(gl-new-list list-id 'compile)
|
|
(gl-material-v 'front 'ambient-and-diffuse color)
|
|
(gl-begin 'polygon)
|
|
(gl-vertex 0.0 0.0 0.0)
|
|
(gl-vertex 1.0 0.0 0.0)
|
|
(gl-vertex 1.0 1.0 0.0)
|
|
(gl-vertex 0.0 1.0 0.0)
|
|
(gl-end)
|
|
(gl-end-list)
|
|
list-id))))
|
|
|
|
(define checkers
|
|
(map
|
|
(lambda (x)
|
|
(let ((color (if (car x)
|
|
(color-name->vector "firebrick" #t)
|
|
(gl-float-vector 0.15 0.15 0.15 1.0)))
|
|
(height (if (cadr x) .4 .2))
|
|
(tex (if (caddr x) (if (car x) light-checker-tex dark-checker-tex) #f)))
|
|
(cons x (cons (make-piece-dl color height tex #f)
|
|
(make-piece-dl color height tex #t)))))
|
|
'((#f #f #f)
|
|
(#f #f #t)
|
|
(#f #t #f)
|
|
(#f #t #t)
|
|
(#t #f #f)
|
|
(#t #f #t)
|
|
(#t #t #f)
|
|
(#t #t #t))))
|
|
(define (get-checker-dl light? king? tex?)
|
|
(cdr (assoc (list light? king? tex?) checkers)))
|
|
|
|
(define dark-square (cons (make-tex-square-dl dark-tex)
|
|
(make-square-dl dark-square-color)))
|
|
(define light-square (cons (make-tex-square-dl light-tex)
|
|
(make-square-dl light-square-color)))
|
|
(define (get-square-dl light? tex?)
|
|
(let ((getter (if tex? car cdr)))
|
|
(getter (if light? light-square dark-square))))
|
|
|
|
(define (show)
|
|
(send f show #t))))
|
|
|
|
(define checkers-model@
|
|
(unit
|
|
(import add-space add-piece remove-piece move-piece set-turn)
|
|
(export move)
|
|
|
|
(define turn 'red)
|
|
(define board (make-array (shape 0 8 0 8) #f))
|
|
|
|
(let loop ((i 0)
|
|
(j 0))
|
|
(cond
|
|
((and (< j 8) (< i 8))
|
|
(cond
|
|
((even? (+ i j))
|
|
(add-space (make-space-info j i #f))
|
|
(cond
|
|
((< i 3)
|
|
(array-set! board j i (cons 'red #f))
|
|
(add-piece (make-piece-info j i 'red #f)))
|
|
((> i 4)
|
|
(array-set! board j i (cons 'black #f))
|
|
(add-piece (make-piece-info j i 'black #f)))))
|
|
(else
|
|
(add-space (make-space-info j i #t))))
|
|
(loop i (add1 j)))
|
|
((< i 8) (loop (add1 i) 0))))
|
|
|
|
(define (other-color c)
|
|
(cond
|
|
((eq? c 'red) 'black)
|
|
(else 'red)))
|
|
|
|
(define (single-move-ok? direction from-x from-y to-x to-y)
|
|
(and (= to-y (+ direction from-y))
|
|
(= 1 (abs (- from-x to-x)))))
|
|
|
|
(define (can-move? direction from-x from-y)
|
|
(and (<= 0 (+ from-y direction) 7)
|
|
(or (and (<= 0 (+ from-x 1) 7)
|
|
(not (array-ref board (+ from-x 1) (+ from-y direction))))
|
|
(and (<= 0 (+ from-x -1) 7)
|
|
(not (array-ref board (+ from-x -1) (+ from-y direction)))))))
|
|
|
|
(define (get-jumped-piece color direction from-x from-y to-x to-y)
|
|
(and (= to-y (+ direction direction from-y))
|
|
(= 2 (abs (- from-x to-x)))
|
|
(let* ((jumped-x (+ from-x (/ (- to-x from-x) 2)))
|
|
(jumped-y (+ from-y direction))
|
|
(jumped-piece (array-ref board jumped-x jumped-y)))
|
|
(and jumped-piece
|
|
(eq? (other-color color) (car jumped-piece))
|
|
(make-piece-info jumped-x jumped-y (car jumped-piece) (cdr jumped-piece))))))
|
|
|
|
(define (can-jump? direction from-color from-x from-y)
|
|
(let ((to-y (+ direction direction from-y))
|
|
(to-x1 (+ from-x 2))
|
|
(to-x2 (- from-x 2)))
|
|
(and (<= 0 to-y 7)
|
|
(or (and (<= 0 to-x1 7)
|
|
(not (array-ref board to-x1 to-y))
|
|
(get-jumped-piece from-color direction
|
|
from-x from-y
|
|
to-x1 to-y))
|
|
(and (<= 0 to-x2)
|
|
(not (array-ref board to-x2 to-y))
|
|
(get-jumped-piece from-color direction
|
|
from-x from-y
|
|
to-x2 to-y))))))
|
|
|
|
|
|
(define (fold-board f v)
|
|
(let iloop ([i 0][v v])
|
|
(if (= i 8)
|
|
v
|
|
(let jloop ([j 0][v v])
|
|
(if (= j 8)
|
|
(iloop (add1 i) v)
|
|
(jloop (add1 j)
|
|
(if (even? (+ i j))
|
|
(f i j v)
|
|
v)))))))
|
|
|
|
(define (get-jump-moves)
|
|
(let ([direction (if (eq? turn 'red) 1 -1)])
|
|
(fold-board
|
|
(lambda (i j l)
|
|
(let ([p (array-ref board i j)])
|
|
(if (and p
|
|
(eq? (car p) turn)
|
|
(or (can-jump? direction turn i j)
|
|
(and (cdr p)
|
|
(can-jump? (- direction) turn i j))))
|
|
(cons (make-piece-info i j turn (cdr p)) l)
|
|
l)))
|
|
null)))
|
|
|
|
(define (get-moves)
|
|
(let ([jumps (get-jump-moves)])
|
|
(if (pair? jumps)
|
|
(make-moves jumps #t)
|
|
(make-moves
|
|
(let ([direction (if (eq? turn 'red) 1 -1)])
|
|
(fold-board
|
|
(lambda (i j l)
|
|
(let ([p (array-ref board i j)])
|
|
(if (and p
|
|
(eq? (car p) turn)
|
|
(or (can-move? direction i j)
|
|
(and (cdr p)
|
|
(can-move? (- direction) i j))))
|
|
(cons (make-piece-info i j turn (cdr p)) l)
|
|
l)))
|
|
null))
|
|
#f))))
|
|
|
|
(define (move from to)
|
|
(let* ((to-x (inexact->exact (floor (gl-vector-ref to 0))))
|
|
(to-y (inexact->exact (floor (gl-vector-ref to 1))))
|
|
(from-x (piece-info-x from))
|
|
(from-y (piece-info-y from))
|
|
(from-color (piece-info-color from))
|
|
(from-king? (piece-info-king? from))
|
|
(to-king? (or from-king?
|
|
(if (eq? 'red from-color)
|
|
(= to-y 7)
|
|
(= to-y 0))))
|
|
(direction (if (eq? turn 'red) 1 -1)))
|
|
(when (and (eq? turn from-color)
|
|
(<= 0 to-x 7)
|
|
(<= 0 to-y 7)
|
|
(not (array-ref board to-x to-y)))
|
|
(cond
|
|
((and (null? (get-jump-moves))
|
|
(or (single-move-ok? direction from-x from-y to-x to-y)
|
|
(and from-king?
|
|
(single-move-ok? (- direction) from-x from-y to-x to-y))))
|
|
(move-piece from to-x to-y)
|
|
(set! turn (other-color from-color))
|
|
(array-set! board to-x to-y (cons from-color to-king?))
|
|
(array-set! board from-x from-y #f)
|
|
(when (and to-king? (not from-king?))
|
|
(remove-piece (make-piece-info to-x to-y from-color from-king?))
|
|
(add-piece (make-piece-info to-x to-y from-color to-king?)))
|
|
(set-turn turn (get-moves)))
|
|
((or (get-jumped-piece from-color direction from-x from-y to-x to-y)
|
|
(and from-king?
|
|
(get-jumped-piece from-color (- direction) from-x from-y to-x to-y)))
|
|
=>
|
|
(lambda (j)
|
|
(remove-piece j)
|
|
(move-piece from to-x to-y)
|
|
(array-set! board (piece-info-x j) (piece-info-y j) #f)
|
|
(array-set! board from-x from-y #f)
|
|
(array-set! board to-x to-y (cons from-color to-king?))
|
|
(when (and to-king? (not from-king?))
|
|
(remove-piece (make-piece-info to-x to-y from-color from-king?))
|
|
(add-piece (make-piece-info to-x to-y from-color to-king?)))
|
|
(cond
|
|
((or (can-jump? direction from-color to-x to-y)
|
|
(and from-king?
|
|
(can-jump? (- direction) from-color to-x to-y)))
|
|
(set-turn turn (make-moves (list (make-piece-info to-x to-y from-color to-king?)) #t)))
|
|
(else
|
|
(set! turn (other-color from-color))
|
|
(set-turn turn (get-moves))))))))))
|
|
|
|
(set-turn turn (get-moves))
|
|
))
|
|
|
|
(define game-unit
|
|
(compound-unit
|
|
(import)
|
|
(link
|
|
(VIEW (checkers-view@ (MODEL move)))
|
|
(MODEL (checkers-model@ (VIEW add-space add-piece remove-piece move-piece set-turn)))
|
|
(SHOW ((unit (import show) (export) (show)) (VIEW show))))
|
|
(export)))
|
|
)
|