(module board mzscheme (require mzlib/contract mzlib/list mzlib/etc) ;; color = (symbols 'blue 'green 'red 'yellow) ;; color : color ;; id : (union 0 1 2 3) (define-struct pawn (color id index) (make-inspector)) ;; v : (vectorof loc) length is always 16 (define-struct board (v) (make-inspector)) ;; loc = (union 'start 'home number[main-loc] home-row-loc) (define-struct home-row-loc (num color) (make-inspector)) (define color (symbols 'red 'green 'blue 'yellow)) (provide/contract (get-enter-pos (color . -> . number?)) (get-exit-pos (color . -> . number?)) (pawn-id (pawn? . -> . (integer-in 0 4))) (pawn-color (pawn? . -> . color))) (provide (rename build-pawn make-pawn) pawn? new-board for-each-pawn/loc (rename make-old-style-board make-board) board-start board-main-i board-main-size board-home-row-i board-home-row-size board-home move-piece move-piece2 safety? find-blockades/color make-blockade blockade-loc blockade-p1 blockade-p2 find-blockade/between make-home-row-loc home-row-loc-num home-row-loc-color home-row-loc?) ;; inline with a macro? (define (for-each-pawn/loc/proc board f) (let ([v (board-v board)]) (let loop ([i 16]) (unless (zero? i) (f (vector-ref all-pawns (- i 1)) (vector-ref v (- i 1))) (loop (- i 1)))))) (define-syntax (for-each-pawn/loc stx) (syntax-case stx () [(_ board (lambda (pawn loc) lam-body)) (let loop ([i 0] [lst '()]) (cond [(= i 16) (with-syntax ([(bodies ...) lst]) (syntax (let ([v (board-v board)]) bodies ... (void))))] [else (loop (+ i 1) (cons (with-syntax ([i i]) (syntax (let ([loc (vector-ref v i)] [pawn (vector-ref all-pawns i)]) lam-body))) lst))]))] [(_ board f) (syntax (for-each-pawn/loc/proc board f))])) (define (make-old-style-board start main home-rows home) (let* ([board (new-board)] [v (board-v board)]) ;; can ignore start pawns ;; main pawns (let loop ([i 0]) (cond [(= i (vector-length main)) '()] [else (for-each (lambda (pawn) (vector-set! v (pawn-index pawn) i)) (vector-ref main i)) (loop (+ i 1))])) ;; home row pawns (for-each (lambda (hr) (let ([vec (cdr hr)]) (let loop ([i 0]) (cond [(= i (vector-length vec)) (void)] [else (for-each (lambda (pawn) (vector-set! v (pawn-index pawn) (make-home-row-loc i (pawn-color pawn)))) (vector-ref vec i)) (loop (+ i 1))])))) home-rows) ;; home pawns (for-each (lambda (home-pawn) (vector-set! v (pawn-index home-pawn) 'home)) home) board)) (define (new-board) (make-board (make-vector 16 'start))) (define board-home-row-size 7) (define board-main-size 68) ; (matching-pawns ) (define-syntax (matching-pawns stx) (syntax-case stx () [(_ board pawn loc test) (and (identifier? (syntax pawn)) (identifier? (syntax loc))) (let loop ([i 16] [sofar '()]) (cond [(zero? i) (with-syntax ([(body ...) sofar]) (syntax (let ([result '()] [v (board-v board)]) body ... result)))] [else (loop (- i 1) (cons (with-syntax ([i (- i 1)]) (syntax (let ([loc (vector-ref v i)] [pawn (vector-ref all-pawns i)]) (when test (set! result (cons pawn result)))))) sofar))]))])) (define (board-main-i board i) (matching-pawns board pawn loc (equal? i loc))) (define (board-home-row-i board color i) (matching-pawns board pawn loc (and (home-row-loc? loc) (= (home-row-loc-num loc) i) (eq? (home-row-loc-color loc) color)))) (define (board-start board) (matching-pawns board pawn loc (eq? loc 'start))) (define (board-home board) (matching-pawns board pawn loc (eq? loc 'home))) ;; move-piece : board pawn loc -> board (define (move-piece board pawn to) (let ([new-board (copy-board board)]) (vector-set! (board-v new-board) (pawn-index pawn) to) new-board)) ;; move-piece2 : board pawn loc pawn loc -> board (define (move-piece2 board pawn to pawn2 to2) (let ([new-board (copy-board board)]) (vector-set! (board-v new-board) (pawn-index pawn) to) (vector-set! (board-v new-board) (pawn-index pawn2) to2) new-board)) ;; copy-board : board -> board (define (copy-board board) (let ([v (board-v board)]) (make-board (build-vector 16 (lambda (i) (vector-ref v i)))))) ;; entry points for the four colors (define enters '((green . 5) (red . 22) (blue . 39) (yellow . 56))) (define (get-enter-pos color) (cdr (assq color enters))) ;; the points where the four colors go off into their ;; own sections of the board. (define exits '((green . 0) (red . 17) (blue . 34) (yellow . 51))) (define (get-exit-pos color) (cdr (assq color exits))) (define safeties (append (map cdr enters) (map cdr exits) (list 12 (+ 12 17) (+ 12 17 17) (+ 12 17 17 17)))) (define (safety? i) (memq i safeties)) ;; find-blockade/between : board loc loc -> (union loc #f) (define (find-blockade/between board start end) (find-blockade/cases (find-blockades board) start end)) ;; find-blockades : board -> (listof loc) (define (find-blockades board) (let ([ht (make-hash-table 'equal)] [blockades '()]) (for-each-pawn/loc board (lambda (pawn loc) (when (hash-table-get ht loc (lambda () (hash-table-put! ht loc #t) #f)) (set! blockades (cons loc blockades))))) blockades)) ;; find-blockade/cases : (listof loc) loc loc -> (union loc #f) (define (find-blockade/cases blockades start end) (cond [(and (number? start) (number? end)) (if (<= start end) (find-blockade/between-main blockades start end) (or (find-blockade/between-main blockades start (- board-main-size 1)) (find-blockade/between-main blockades 0 end)))] [(and (number? start) (home-row-loc? end)) (or (find-blockade/cases blockades start (get-exit-pos (home-row-loc-color end))) (find-blockade/between-home-row blockades (home-row-loc-color end) 0 (home-row-loc-num end)))] [(and (home-row-loc? start) (home-row-loc? end)) (find-blockade/between-home-row blockades (home-row-loc-color start) (home-row-loc-num start) (home-row-loc-num end))] [(not (loc<=? start end)) (error 'find-blockade/between "expected locs in order, got ~e and ~e" start end)] [(or (eq? start 'home) (eq? end 'home)) (error 'find-blockade/between "cannot accept 'home as argument, got ~e and ~e" start end)] [(or (eq? start 'start) (eq? end 'start)) (error 'find-blockade/between "cannot accept 'start as argument, got ~e and ~e" start end)] [else (error 'find-blockade/between "unknown arguments ~e and ~e" start end)])) (define (find-blockade/between-main blockades start end) (ormap (lambda (blockade) (and (number? blockade) (<= start blockade end) blockade)) blockades)) (define (find-blockade/between-home-row blockades color start end) (ormap (lambda (blockade) (and (home-row-loc? blockade) (eq? color (home-row-loc-color blockade)) (<= start (home-row-loc-num blockade) end) blockade)) blockades)) ;; loc : loc ;; p1 : pawn ;; p2 : pawn ;; (pawn<=? p1 p2) is true (define-struct blockade (loc p1 p2) (make-inspector)) ;; find-blockades/color : board color -> (listof blockade) (define (find-blockades/color board color) (let ([ht (make-hash-table 'equal)] [v (board-v board)] [offset (find-pawn-index color 0)]) (let loop ([i 0] [blockades null]) (cond [(= i 4) blockades] [else (let ([loc (vector-ref v (+ offset i))]) (cond [(eq? loc 'start) (loop (+ i 1) blockades)] [(eq? loc 'home) (loop (+ i 1) blockades)] [(hash-table-get ht loc (lambda () (hash-table-put! ht loc i) #f)) => (lambda (old-i) (loop (+ i 1) (cons (make-blockade loc (vector-ref all-pawns (+ offset old-i)) (vector-ref all-pawns (+ offset i))) blockades)))] [else (loop (+ i 1) blockades)]))])))) (define (loc<=? l1 l2) (<= (loc->id l1) (loc->id l2))) (define (loc->id loc) (cond [(eq? loc 'start) 0] [(number? loc) (+ loc 1)] [(eq? loc 'home) 1000] [(home-row-loc? loc) (+ 100 (* (color->int (home-row-loc-color loc)) 100) (home-row-loc-num loc))] [else (error 'loc->id "expected a loc, got ~e" loc)])) (define (build-pawn color id) (make-pawn color id (find-pawn-index color id))) (define (find-pawn-index color id) (+ (* (color->int color) 4) id)) (define (pawn<=? p1 p2) (if (eq? (pawn-color p1) (pawn-color p2)) (<= (pawn-id p1) (pawn-id p2)) (color<= (pawn-color p1) (pawn-color p2)))) (define (color<= c1 c2) (<= (color->int c1) (color->int c2))) (define (color->int c) (case c [(blue) 0] [(green) 1] [(red) 2] [(yellow) 3] [else (error 'color->int "unknown color ~e" c)])) (define all-pawns (vector (build-pawn 'blue 0) (build-pawn 'blue 1) (build-pawn 'blue 2) (build-pawn 'blue 3) (build-pawn 'green 0) (build-pawn 'green 1) (build-pawn 'green 2) (build-pawn 'green 3) (build-pawn 'red 0) (build-pawn 'red 1) (build-pawn 'red 2) (build-pawn 'red 3) (build-pawn 'yellow 0) (build-pawn 'yellow 1) (build-pawn 'yellow 2) (build-pawn 'yellow 3))) (let loop ([i 0]) (unless (= i 16) (unless (= i (pawn-index (vector-ref all-pawns i))) (error 'mismatch "~s ~s" i (vector-ref all-pawns i))) (loop (+ i 1)))))