413 lines
15 KiB
Scheme
413 lines
15 KiB
Scheme
|
|
;; Some tests for the model
|
|
|
|
(module test-model mzscheme
|
|
(require (lib "unitsig.ss")
|
|
(lib "etc.ss")
|
|
(lib "list.ss")
|
|
"sig.ss"
|
|
"model.ss"
|
|
"test.ss")
|
|
|
|
;; Test basic procs:
|
|
(define (test-folding n)
|
|
(begin-with-definitions
|
|
(define BOARD-SIZE n)
|
|
(define-values/invoke-unit/sig model^
|
|
model-unit #f config^)
|
|
(test 'red (other 'yellow))
|
|
(test 'yellow (other 'red))
|
|
(test (if (= n 3)
|
|
'(0 1 2)
|
|
'(0 1 2 3))
|
|
(mergesort (fold-rowcol (lambda (i v) (cons i v)) null)
|
|
<))
|
|
(test (if (= n 3)
|
|
'((0 . 0) (0 . 1) (0 . 2)
|
|
(1 . 0) (1 . 1) (1 . 2)
|
|
(2 . 0) (2 . 1) (2 . 2))
|
|
'((0 . 0) (0 . 1) (0 . 2) (0 . 3)
|
|
(1 . 0) (1 . 1) (1 . 2) (1 . 3)
|
|
(2 . 0) (2 . 1) (2 . 2) (2 . 3)
|
|
(3 . 0) (3 . 1) (3 . 2) (3 . 3)))
|
|
(mergesort (fold-board (lambda (i j v) (cons (cons i j) v)) null)
|
|
(lambda (a b)
|
|
(if (= (car a) (car b))
|
|
(< (cdr a) (cdr b))
|
|
(< (car a) (car b))))))))
|
|
(test-folding 3)
|
|
(test-folding 4)
|
|
|
|
;; Test available-off-board for 3x3:
|
|
(let ()
|
|
(begin-with-definitions
|
|
(define BOARD-SIZE 3)
|
|
(define-values/invoke-unit/sig model^
|
|
model-unit #f config^)
|
|
(test '((2 2) (1 1) (0 0)) (available-off-board empty-board 'red))
|
|
(test '((2 2) (1 1) (0)) (available-off-board
|
|
(move empty-board (list-ref red-pieces 0) #f #f 1 1 values void)
|
|
'red))
|
|
(let ([b2 (move empty-board (list-ref red-pieces 2) #f #f 1 1 values void)])
|
|
(test '((2) (1 1) (0 0)) (available-off-board b2 'red))
|
|
(let ([b3 (move b2 (list-ref yellow-pieces 1) #f #f 2 2 values void)])
|
|
(test '((2) (1 1) (0 0)) (available-off-board b3 'red))
|
|
(test '((2 2) (1) (0 0)) (available-off-board b3 'yellow))
|
|
(let ([b4 (move b3 (list-ref red-pieces 2) #f #f 0 1 values void)])
|
|
(test '((1 1) (0 0)) (available-off-board b4 'red))
|
|
(test '((2 2) (1) (0 0)) (available-off-board b4 'yellow)))))))
|
|
|
|
;; Test available-off-board for 4x4:
|
|
(let ()
|
|
(begin-with-definitions
|
|
(define BOARD-SIZE 4)
|
|
(define-values/invoke-unit/sig model^
|
|
model-unit #f config^)
|
|
(test '((3 2 1 0) (3 2 1 0) (3 2 1 0)) (available-off-board empty-board 'red))
|
|
(let ([b2 (move empty-board (list-ref red-pieces 3) #f #f 1 1 values void)])
|
|
(test '((3 2 1 0) (3 2 1 0) (2 1 0)) (available-off-board b2 'red))
|
|
(let ([b3 (move b2 (list-ref yellow-pieces 3) #f #f 2 2 values void)])
|
|
(test '((3 2 1 0) (3 2 1 0) (2 1 0)) (available-off-board b3 'red))
|
|
(test '((3 2 1 0) (3 2 1 0) (2 1 0)) (available-off-board b3 'yellow))
|
|
(let ([b4 (move b3 (list-ref red-pieces 3) #f #f 0 1 values void)])
|
|
(test '((3 2 1 0) (2 1 0) (2 1 0)) (available-off-board b4 'red))
|
|
(let ([b5 (move b4 (list-ref red-pieces 2) #f #f 0 3 values void)])
|
|
(test '((3 2 1 0) (2 1 0) (1 0)) (available-off-board b5 'red)))
|
|
(let ([b5 (move b4 (list-ref red-pieces 3) #f #f 0 3 values void)])
|
|
(test '((2 1 0) (2 1 0) (2 1 0)) (available-off-board b5 'red))))
|
|
(let ([b4 (move b3 (list-ref red-pieces 2) #f #f 0 1 values void)])
|
|
(test '((3 2 1 0) (3 2 1 0) (1 0)) (available-off-board b4 'red))
|
|
(let ([b5 (move b4 (list-ref red-pieces 3) #f #f 0 3 values void)])
|
|
(test '((3 2 1 0) (2 1 0) (1 0)) (available-off-board b5 'red))
|
|
(let ([b6 (move b5 (list-ref red-pieces 2) #f #f 3 3 values void)])
|
|
(test '((3 2 1 0) (1 0) (1 0)) (available-off-board b6 'red)))))))))
|
|
|
|
(define x-table (make-hash-table 'equal))
|
|
(define (testx id board)
|
|
(test id (hash-table-get x-table board
|
|
(lambda ()
|
|
(when (hash-table-get x-table id (lambda () #f))
|
|
(error 'testx "id already mapped\n"))
|
|
(hash-table-put! x-table id #t)
|
|
(hash-table-put! x-table board id)
|
|
id))))
|
|
|
|
;; Given a canonicalize function, a board, the current player,
|
|
;; and the model exports, check that the canonicalizer works
|
|
;; on the board.
|
|
(define (canon-test BOARD-SIZE canonicalize board who
|
|
fold-board board-ref move empty-board
|
|
yellow-pieces red-pieces piece-color piece-size other
|
|
apply-xform unapply-xform)
|
|
(define (flip-stack stack)
|
|
(map (lambda (p)
|
|
(if (eq? (piece-color p) 'red)
|
|
(list-ref yellow-pieces (piece-size p))
|
|
(list-ref red-pieces (piece-size p))))
|
|
stack))
|
|
(define (board-xform board ijx flip-stack)
|
|
(fold-board
|
|
(lambda (i j b)
|
|
(let ([stack (board-ref board i j)])
|
|
(let loop ([stack (flip-stack stack)])
|
|
(if (null? stack)
|
|
b
|
|
(let-values ([(i j) (ijx i j)])
|
|
(move (loop (cdr stack))
|
|
(car stack)
|
|
#f #f
|
|
i j
|
|
values void))))))
|
|
empty-board))
|
|
(let* ([key+xform (canonicalize board who)]
|
|
;; flip vert
|
|
[board2 (board-xform board (lambda (i j)
|
|
(values i (- BOARD-SIZE 1 j)))
|
|
values)]
|
|
[key2+xform2 (canonicalize board2 who)]
|
|
;; flip horiz
|
|
[board3 (board-xform board (lambda (i j)
|
|
(values (- BOARD-SIZE 1 i) j))
|
|
values)]
|
|
[key3+xform3 (canonicalize board3 who)]
|
|
;; flip colors
|
|
[board4 (board-xform board (lambda (i j) (values i j))
|
|
flip-stack)]
|
|
[key4+xform4 (canonicalize board4 (other who))])
|
|
;; Canoncal key should be the same for all boards:
|
|
(test (car key+xform) (car key2+xform2))
|
|
(test (car key+xform) (car key3+xform3))
|
|
(test (car key+xform) (car key4+xform4))
|
|
;; Xforming coordinates should produce the same thing for each board:
|
|
(fold-board (lambda (i j v)
|
|
(let ([pos (apply-xform (cdr key+xform) i j)]
|
|
[s (board-ref board i j)])
|
|
(let-values ([(i j) (unapply-xform (cdr key2+xform2) pos)])
|
|
(test s (board-ref board2 i j))
|
|
(test pos (apply-xform (cdr key2+xform2) i j)))
|
|
(let-values ([(i j) (unapply-xform (cdr key3+xform3) pos)])
|
|
(test s (board-ref board3 i j))
|
|
(test pos (apply-xform (cdr key3+xform3) i j)))
|
|
(let-values ([(i j) (unapply-xform (cdr key4+xform4) pos)])
|
|
(test (flip-stack s) (board-ref board4 i j))
|
|
(test pos (apply-xform (cdr key4+xform4) i j)))))
|
|
(void))
|
|
(car key+xform)))
|
|
|
|
;; Test canonicalization, 3x3
|
|
(begin-with-definitions
|
|
(define BOARD-SIZE 3)
|
|
(define-values/invoke-unit/sig model^
|
|
model-unit #f config^)
|
|
(let ([c (let ([canonicalize (make-canonicalize)])
|
|
(lambda (b who)
|
|
(canon-test 3 canonicalize b who
|
|
fold-board board-ref move empty-board
|
|
yellow-pieces red-pieces piece-color piece-size other
|
|
apply-xform unapply-xform)))])
|
|
(testx 0 (c empty-board 'red))
|
|
(testx 0 (c empty-board 'yellow))
|
|
(let ([b1 (move empty-board (list-ref red-pieces 2) #f #f 1 1 values void)])
|
|
(testx 1 (c b1 'red))
|
|
(testx 2 (c b1 'yellow))
|
|
(testx 1 (c b1 'red))
|
|
(let ([b2 (move b1 (list-ref red-pieces 2) #f #f 2 2 values void)])
|
|
(testx 3 (c b2 'red))
|
|
(testx 7 (c b2 'yellow)))
|
|
(let ([b2 (move b1 (list-ref red-pieces 2) #f #f 0 0 values void)])
|
|
(testx 3 (c b2 'red))
|
|
(testx 7 (c b2 'yellow))
|
|
(let ([b3 (move b2 (list-ref yellow-pieces 1) #f #f 1 0 values void)])
|
|
(testx 11 (c b3 'red))
|
|
(testx 19 (c b3 'yellow))
|
|
(let ([b4 (move b3 (list-ref red-pieces 2) #f #f 1 0 values void)])
|
|
(testx 27 (c b4 'red))
|
|
(testx 35 (c b4 'yellow))
|
|
(let ([b5 (move b4 (list-ref red-pieces 2) 0 0 2 0 values void)])
|
|
(testx 27 (c b5 'red))
|
|
(testx 35 (c b5 'yellow)))))))))
|
|
|
|
(set! x-table (make-hash-table 'equal))
|
|
|
|
;; Test canonicalization, 4x4
|
|
(begin-with-definitions
|
|
(define BOARD-SIZE 4)
|
|
(define-values/invoke-unit/sig model^
|
|
model-unit #f config^)
|
|
(let ([c (let ([canonicalize (make-canonicalize)])
|
|
(lambda (b who)
|
|
(canon-test 4 canonicalize b who
|
|
fold-board board-ref move empty-board
|
|
yellow-pieces red-pieces piece-color piece-size other
|
|
apply-xform unapply-xform)))])
|
|
(testx 0 (c empty-board 'red))
|
|
(testx 0 (c empty-board 'yellow))
|
|
(let ([b1 (move empty-board (list-ref red-pieces 0) #f #f 1 1 values void)])
|
|
(testx 1 (c b1 'red))
|
|
(testx 5 (c b1 'yellow))
|
|
(testx 1 (c b1 'red))
|
|
(let ([b1.1 (move b1 (list-ref red-pieces 0) #f #f 2 2 values void)])
|
|
(let ([b2 (move b1.1 (list-ref red-pieces 2) #f #f 3 3 values void)])
|
|
(testx 9 (c b2 'red))
|
|
(testx 13 (c b2 'yellow)))
|
|
(let ([b2 (move b1.1 (list-ref red-pieces 2) #f #f 0 0 values void)])
|
|
(testx 9 (c b2 'red))
|
|
(testx 13 (c b2 'yellow))
|
|
(let ([b3 (move b2 (list-ref yellow-pieces 1) #f #f 1 0 values void)])
|
|
(testx 17 (c b3 'red))
|
|
(testx 25 (c b3 'yellow))))))))
|
|
|
|
(define (basic-tests size xform 4x4-finish-pos)
|
|
;; When xform is the identity, then we build toward
|
|
;; _ _ Y - _ = empty
|
|
;; _ Y _ - - = optional (3x3 vs 4x4)
|
|
;; y R R -
|
|
;; - - - -
|
|
;; The xform changes the cooridnate system so that we
|
|
;; test rows and columns in addition to this diagonal.
|
|
(begin-with-definitions
|
|
(define BOARD-SIZE size)
|
|
|
|
(define-values (i00 j00) (xform 0 0))
|
|
(define-values (i11 j11) (xform 1 1))
|
|
(define-values (i22 j22) (xform 2 2))
|
|
(define-values (i12 j12) (xform 1 2))
|
|
(define-values (i02 j02) (xform 0 2))
|
|
(define-values (i20 j20) (xform 2 0))
|
|
|
|
(define-values/invoke-unit/sig model^
|
|
model-unit #f config^)
|
|
|
|
;; Empty board --------------------
|
|
(define b empty-board)
|
|
|
|
(test null (board-ref b i00 j00))
|
|
(test null (board-ref b i22 j22))
|
|
|
|
(test #f (winner? b 'red))
|
|
(test #f (winner? b 'yellow))
|
|
|
|
(define big-red (list-ref red-pieces 2))
|
|
(define big-yellow (list-ref yellow-pieces 2))
|
|
(define med-red (list-ref red-pieces 1))
|
|
(define med-yellow (list-ref yellow-pieces 1))
|
|
(define small-yellow (list-ref yellow-pieces 0))
|
|
|
|
;; Big red --------------------
|
|
|
|
(define b1 (move b big-red #f #f i00 j00 values void))
|
|
(test (list big-red) (board-ref b1 i00 j00))
|
|
(test (void) (move b1 big-yellow #f #f i00 j00 values void))
|
|
|
|
(test #f (winner? b1 'red))
|
|
(test #f (winner? b1 'yellow))
|
|
|
|
;; Big red, big yellow --------------------
|
|
|
|
(define b2 (move b1 big-yellow #f #f i11 j11 values void))
|
|
(test (list big-red) (board-ref b2 i00 j00))
|
|
(test (list big-yellow) (board-ref b2 i11 j11))
|
|
|
|
(test #f (winner? b2 'red))
|
|
(test #f (winner? b2 'yellow))
|
|
|
|
(test (void) (move b2 big-red #f #f i11 j11 values void))
|
|
(test (void) (move b2 big-red i00 j00 i11 j11 values void))
|
|
|
|
;; Big red moved, big yellow --------------------
|
|
|
|
(define b3 (move b2 big-red i00 j00 i22 j22 values void))
|
|
(test null (board-ref b3 i00 j00))
|
|
(test (list big-yellow) (board-ref b3 i11 j11))
|
|
(test (list big-red) (board-ref b3 i22 j22))
|
|
|
|
(test #f (winner? b3 'red))
|
|
(test #f (winner? b3 'yellow))
|
|
|
|
;; Big red, big yellow, med yellow --------------------
|
|
|
|
(define b4 (move b3 med-yellow #f #f i02 j02 values void))
|
|
(test (list big-yellow) (board-ref b4 i11 j11))
|
|
(test (list big-red) (board-ref b4 i22 j22))
|
|
(test (list med-yellow) (board-ref b4 i02 j02))
|
|
|
|
(test #f (winner? b4 'red))
|
|
(test #f (winner? b4 'yellow))
|
|
|
|
(test (void) (move b4 med-red #f #f i02 j02 values void))
|
|
|
|
;; Big red gobble med yellow, big yellow --------------------
|
|
;; --- Add big red
|
|
(define b5.1 (move b4 big-red #f #f i02 j02 values void))
|
|
(when (= size 4)
|
|
;; can't gobble yellow, since it's not in a 3-in-arow
|
|
(test (void) b5.1)
|
|
;; Generate board by cheating, giving red two turns...
|
|
(set! b5.1 (move (move b4 big-red i22 j22 i02 j02 values void)
|
|
big-red #f #f i22 j22 values void)))
|
|
(test (list big-yellow) (board-ref b5.1 i11 j11))
|
|
(test (list big-red) (board-ref b5.1 i22 j22))
|
|
(test (list big-red med-yellow) (board-ref b5.1 i02 j02))
|
|
|
|
;; --- Move big red
|
|
(define b5.2 (move b4 big-red i22 j22 i02 j02 values void))
|
|
(test (list big-yellow) (board-ref b5.2 i11 j11))
|
|
(test null (board-ref b5.2 i22 j22))
|
|
(test (list big-red med-yellow) (board-ref b5.2 i02 j02))
|
|
|
|
;; Add small yellow ------------------------------
|
|
;; --- with 2 big red
|
|
(define b6.1 (move b5.1 small-yellow #f #f i20 j20 values void))
|
|
(test (list big-yellow) (board-ref b6.1 i11 j11))
|
|
(test (list big-red) (board-ref b6.1 i22 j22))
|
|
(test (list big-red med-yellow) (board-ref b6.1 i02 j02))
|
|
(test (list small-yellow) (board-ref b6.1 i20 j20))
|
|
|
|
(test #f (winner? b6.1 'red))
|
|
(test #f (winner? b6.1 'yellow))
|
|
|
|
;; --- with 1 big red
|
|
(define b6.2 (move b5.2 small-yellow #f #f i20 j20 values void))
|
|
(test (list big-yellow) (board-ref b6.2 i11 j11))
|
|
(test null (board-ref b6.2 i22 j22))
|
|
(test (list big-red med-yellow) (board-ref b6.2 i02 j02))
|
|
(test (list small-yellow) (board-ref b6.2 i20 j20))
|
|
|
|
(test #f (winner? b6.2 'red))
|
|
(test #f (winner? b6.2 'yellow))
|
|
|
|
;; Expose med yellow for 3-in-row ----------
|
|
(define b7.1 (move b6.1 big-red i02 j02 i12 j12 values void))
|
|
(test (list big-yellow) (board-ref b7.1 i11 j11))
|
|
(test (list big-red) (board-ref b7.1 i22 j22))
|
|
(test (list med-yellow) (board-ref b7.1 i02 j02))
|
|
(test (list small-yellow) (board-ref b7.1 i20 j20))
|
|
(test (list big-red) (board-ref b7.1 i12 j12))
|
|
|
|
(test #f (winner? b7.1 'red))
|
|
(test (= size 3) (winner? b7.1 'yellow))
|
|
|
|
(define b7.2 (move b6.2 big-red i02 j02 i12 j12 values void))
|
|
(test (list big-yellow) (board-ref b7.2 i11 j11))
|
|
(test null (board-ref b7.2 i22 j22))
|
|
(test (list med-yellow) (board-ref b7.2 i02 j02))
|
|
(test (list small-yellow) (board-ref b7.2 i20 j20))
|
|
(test (list big-red) (board-ref b7.2 i12 j12))
|
|
|
|
(test #f (winner? b7.2 'red))
|
|
(test (= size 3) (winner? b7.2 'yellow))
|
|
|
|
(when (and (= size 4)
|
|
4x4-finish-pos)
|
|
;; 4 x 4 game: now red can cover small yellow, because it's
|
|
;; part of 3 in a row
|
|
(begin-with-definitions
|
|
(test #t (3-in-a-row? b7.2 i20 j20 'yellow))
|
|
(test #f (3-in-a-row? b7.2 i20 j20 'red))
|
|
|
|
(define b8.2 (move b7.2 med-red #f #f i20 j20 values void))
|
|
(test (list big-yellow) (board-ref b8.2 i11 j11))
|
|
(test null (board-ref b8.2 i22 j22))
|
|
(test (list med-yellow) (board-ref b8.2 i02 j02))
|
|
(test (list med-red small-yellow) (board-ref b8.2 i20 j20))
|
|
(test (list big-red) (board-ref b8.2 i12 j12))
|
|
|
|
(test #f (winner? b8.2 'red))
|
|
(test #f (winner? b8.2 'yellow))
|
|
|
|
(define b8.2x (move b7.2 med-yellow #f #f (car 4x4-finish-pos) (cdr 4x4-finish-pos) values void))
|
|
(test #f (winner? b8.2x 'red))
|
|
(test #t (winner? b8.2x 'yellow))))))
|
|
|
|
(define (rotate i j)
|
|
(case i
|
|
[(0) (case j
|
|
[(0) (values 1 0)]
|
|
[(1) (values 0 0)]
|
|
[(2) (values 0 1)])]
|
|
[(1) (case j
|
|
[(0) (values 2 0)]
|
|
[(1) (values 1 1)]
|
|
[(2) (values 0 2)])]
|
|
[(2) (case j
|
|
[(0) (values 2 1)]
|
|
[(1) (values 2 2)]
|
|
[(2) (values 1 2)])]
|
|
[else (values i j)]))
|
|
|
|
(map (lambda (xform+?)
|
|
(basic-tests 3 ((cdr xform+?) 3) (car xform+?))
|
|
(basic-tests 4 ((cdr xform+?) 4) (car xform+?)))
|
|
(list (cons #f (lambda (sz) (lambda (i j) (values i j))))
|
|
(cons #f (lambda (sz) (lambda (i j) (values j i))))
|
|
(cons #f (lambda (sz) (lambda (i j) (values i (- sz 1 j)))))
|
|
(cons '(3 . 1) (lambda (sz) (lambda (i j) (rotate i j))))
|
|
(cons '(1 . 3) (lambda (sz) (lambda (i j) (rotate i (- 3 1 j)))))))
|
|
|
|
;; Extra tests for 4 x 4 to get yellow 3-in-a-row on diagonals:
|
|
(basic-tests 4 (lambda (i j) (values i (+ j 1))) '(3 . 0))
|
|
(basic-tests 4 (lambda (i j) (values i (- 3 (+ j 1)))) '(3 . 3))
|
|
|
|
(report-test-results))
|
|
|
|
|