767 lines
31 KiB
Scheme
767 lines
31 KiB
Scheme
#|
|
|
|
|
player characteristics
|
|
- all things being equal, prefer to bop opponents (even if no bonus comes from it)
|
|
- player that prefers to set himself up to bop opponents
|
|
|
|
agressive annie
|
|
balanced bob
|
|
careful charlie
|
|
(random ron)
|
|
|#
|
|
|
|
(module best-players mzscheme
|
|
(require "board.ss"
|
|
"moves.ss"
|
|
"interfaces.ss"
|
|
"test.ss"
|
|
(lib "list.ss")
|
|
(lib "etc.ss")
|
|
(lib "class.ss")
|
|
(lib "pretty.ss"))
|
|
|
|
(provide random-player%
|
|
agressive-player%
|
|
careful-player%
|
|
best-player%
|
|
polite-player%
|
|
reckless-player%
|
|
|
|
search
|
|
(struct state (moves dice board)))
|
|
|
|
(define candidates-record '())
|
|
(provide average-move-count)
|
|
(define (average-move-count)
|
|
(if (null? candidates-record)
|
|
'no-games-played
|
|
(list (/ (apply + candidates-record) (length candidates-record) 1.0)
|
|
(length candidates-record))))
|
|
|
|
;; moves : (listof move) -- what got us here
|
|
;; dice : (listof dice) -- what we have left to use
|
|
;; board : board -- the state of the board after taking the moves
|
|
(define-struct state (moves dice board) (make-inspector))
|
|
|
|
(define base-player%
|
|
(class* object% (player<%>)
|
|
(init-field name)
|
|
(define/public (score board) (error 'score "abstract method"))
|
|
|
|
(field [color #f])
|
|
(define/public (start-game _color)
|
|
(set! color _color)
|
|
name)
|
|
(define/public (doubles-penalty) (void))
|
|
|
|
(define/public (do-move orig-board unsorted-dice)
|
|
(let ([dice (quicksort unsorted-dice <)])
|
|
(let* ([before (current-process-milliseconds)]
|
|
[candidates (search orig-board color dice)]
|
|
[ms (- (current-process-milliseconds) before)])
|
|
(set! candidates-record (cons (length candidates) candidates-record))
|
|
(when (ms . > . 4000)
|
|
(printf "\nmsec ~s\n" ms)
|
|
(printf "candidates ~s (avg moves ~s)\n"
|
|
(length candidates)
|
|
(let ([nums (map (lambda (x) (length (state-moves x))) candidates)])
|
|
(/ (apply + nums)
|
|
(length nums)
|
|
1.0)))
|
|
(print-struct #t)
|
|
(printf "color ~s dice ~s\n" color dice)
|
|
(pretty-print orig-board))
|
|
(find-best candidates))))
|
|
|
|
(define/private (find-best moves)
|
|
(cond
|
|
[(null? moves) '()]
|
|
[else
|
|
(let loop ([states (cdr moves)]
|
|
[best (list (car moves))]
|
|
[best-score (score (state-board (car moves)))])
|
|
(cond
|
|
[(null? states) (state-moves (list-ref best (random (length best))))]
|
|
[else (let* ([state (car states)]
|
|
[this-score (score (state-board state))])
|
|
(cond
|
|
[(= this-score best-score)
|
|
(loop (cdr states)
|
|
(cons state best)
|
|
best-score)]
|
|
[(< this-score best-score)
|
|
(loop (cdr states)
|
|
best
|
|
best-score)]
|
|
[else (loop (cdr states)
|
|
(list state)
|
|
this-score)]))]))]))
|
|
|
|
(super-new)))
|
|
|
|
(define random-player%
|
|
(class base-player%
|
|
(init [name "Random Ron"])
|
|
(define/override (score board) (random 10000))
|
|
(super-new [name name])))
|
|
|
|
(define agressive-player%
|
|
(class base-player%
|
|
(inherit-field color)
|
|
(define/override (score board) (- 500 (find-distance board color)))
|
|
(super-new [name "Agressive Annie"])))
|
|
|
|
(define polite-player%
|
|
(class base-player%
|
|
(inherit-field color)
|
|
(define/override (score board) (find-distance board color))
|
|
(super-new [name "Polite Polly"])))
|
|
|
|
(define best-player%
|
|
(class base-player%
|
|
(inherit-field color)
|
|
(define/override (score board)
|
|
(let ([dist (- 500 (find-distance board color))]
|
|
[bop-chance (- 36 (find-bop-chance board color))])
|
|
(+ (* dist 100) bop-chance)))
|
|
(super-new [name "Amazing Grace"])))
|
|
|
|
(define reckless-player%
|
|
(class base-player%
|
|
(inherit-field color)
|
|
(define/override (score board) (find-bop-chance board color))
|
|
(super-new [name "Reckless Renee"])))
|
|
|
|
(define careful-player%
|
|
(class base-player%
|
|
(inherit-field color)
|
|
(define/override (score board) (- 36 (find-bop-chance board color)))
|
|
(super-new [name "Careful Charlie"])))
|
|
|
|
;; search : board color (listof number) -> (listof state)
|
|
(define (search orig-board color dice)
|
|
(define candidate-ht (make-hash-table 'equal))
|
|
(define (move-candidate candidate)
|
|
(hash-table-put! candidate-ht (state-board candidate) candidate))
|
|
(define (get-candidates) (hash-table-map candidate-ht (lambda (x y) y)))
|
|
|
|
;; main : -> void
|
|
(define (main)
|
|
;; ht : board -o> true
|
|
(let ([ht (make-hash-table 'equal)])
|
|
(let loop ([state (make-state '() dice orig-board)])
|
|
(let* ([board (state-board state)]
|
|
[dice (state-dice state)]
|
|
[key (cons dice board)])
|
|
(cond
|
|
[(hash-table-get ht key (lambda () #f))
|
|
(void)]
|
|
[else
|
|
(hash-table-put! ht key #t)
|
|
(let* ([possible-moves (find-moves board dice)]
|
|
[valid-next-states (find-valid-states state orig-board board possible-moves)])
|
|
(cond
|
|
[(null? valid-next-states) (move-candidate state)]
|
|
[else (for-each loop valid-next-states)]))])))))
|
|
|
|
(define (find-valid-states state orig-board board moves)
|
|
(let loop ([moves moves])
|
|
(cond
|
|
[(null? moves) null]
|
|
[else (let ([move (car moves)])
|
|
(with-handlers ([exn:bad-move? (lambda (x) (loop (cdr moves)))])
|
|
(let-values ([(new-board bonus) (make-one-move board move)])
|
|
(if (blockade-moved? orig-board new-board color)
|
|
(loop (cdr moves))
|
|
(let ([removed-dice (remove-used-rolls move (state-dice state))])
|
|
(if removed-dice
|
|
(cons (make-state (append (state-moves state) (list move))
|
|
(if bonus (insert bonus removed-dice) removed-dice)
|
|
new-board)
|
|
(loop (cdr moves)))
|
|
(loop (cdr moves))))))))])))
|
|
|
|
(define (remove-used-rolls move dice)
|
|
(cond
|
|
[(move-piece-main? move) (mem/rem (move-piece-main-distance move) dice)]
|
|
[(move-piece-home? move) (mem/rem (move-piece-home-distance move) dice)]
|
|
[(enter-piece? move)
|
|
(or (mem/rem 5 dice)
|
|
(and (memq 3 dice)
|
|
(memq 2 dice)
|
|
(remq 3 (remq 2 dice)))
|
|
(and (memq 1 dice)
|
|
(memq 4 dice)
|
|
(remq 1 (remq 4 dice))))]))
|
|
|
|
(define (mem/rem x ls) (and (memq x ls) (remq x ls)))
|
|
|
|
(define (find-moves board dice)
|
|
(let ([moves '()])
|
|
(for-each-pawn/loc
|
|
board
|
|
(lambda (pawn loc)
|
|
(when (eq? (pawn-color pawn) color)
|
|
(cond
|
|
[(eq? loc 'start) (set! moves (cons (make-enter-piece pawn) moves))]
|
|
[(number? loc)
|
|
(set! moves (append (map (lambda (die) (make-move-piece-main pawn loc die))
|
|
dice)
|
|
moves))]
|
|
[(home-row-loc? loc)
|
|
(set! moves (append (map (lambda (die) (make-move-piece-home pawn (home-row-loc-num loc) die))
|
|
dice)
|
|
moves))]
|
|
[(eq? loc 'home) (void)]))))
|
|
moves))
|
|
|
|
(define (extend vec i make-move-piece dice)
|
|
(let ([ent (vector-ref vec i)])
|
|
(cond
|
|
[(and (pair? ent)
|
|
(eq? (pawn-color (car ent)) color))
|
|
(all-moves make-move-piece ent i dice)]
|
|
[else '()])))
|
|
|
|
(define (all-moves make-move-piece ent i dice)
|
|
(let d-loop ([dice dice])
|
|
(cond
|
|
[(null? dice) '()]
|
|
[else
|
|
(append
|
|
(let loop ([ent ent])
|
|
(cond
|
|
[(null? ent) null]
|
|
[else (cons (make-move-piece (car ent) i (car dice))
|
|
(loop (cdr ent)))]))
|
|
(d-loop (cdr dice)))])))
|
|
|
|
(main)
|
|
(get-candidates))
|
|
|
|
;; find-bop-chance : board color -> number[0-36]
|
|
(define (find-bop-chance board color)
|
|
|
|
;; add-chances : number[distance] -> void
|
|
(define (add-chances i)
|
|
(case i
|
|
[(1)
|
|
(add-single-roll-chances 1)]
|
|
[(2)
|
|
(add-single-roll-chances 1)
|
|
(add-chance 1 1)]
|
|
[(3)
|
|
(add-single-roll-chances 1)
|
|
(add-chance 1 2)]
|
|
[(4)
|
|
(add-single-roll-chances 1)
|
|
(add-chance 1 3)
|
|
(add-chance 2 2)]
|
|
[(5)
|
|
(add-single-roll-chances 1)
|
|
(add-chance 1 4)
|
|
(add-chance 2 3)]
|
|
[(6)
|
|
(add-single-roll-chances 1)
|
|
(add-chance 1 5)
|
|
(add-chance 2 4)
|
|
(add-chance 3 3)]
|
|
[(7)
|
|
(add-chance 1 6)
|
|
(add-chance 2 5)
|
|
(add-chance 3 4)]
|
|
[(8)
|
|
(add-chance 2 6)
|
|
(add-chance 3 5)
|
|
(add-chance 4 4)]
|
|
[(9)
|
|
(add-chance 3 6)
|
|
(add-chance 4 5)]
|
|
[(10)
|
|
(add-chance 4 6)
|
|
(add-chance 5 5)]
|
|
[(11)
|
|
(add-chance 5 6)]
|
|
[(12)
|
|
(add-chance 6 6)]
|
|
[else (void)]))
|
|
|
|
(define (add-single-roll-chances i)
|
|
(add-chance i 1)
|
|
(add-chance i 2)
|
|
(add-chance i 3)
|
|
(add-chance i 4)
|
|
(add-chance i 5)
|
|
(add-chance i 6))
|
|
|
|
(define chances (build-vector
|
|
6
|
|
(lambda (i) (make-vector 6 #f))))
|
|
(define (add-chance d1 d2)
|
|
(vector-set! (vector-ref chances (- d1 1)) (- d2 1) #t)
|
|
(vector-set! (vector-ref chances (- d2 1)) (- d1 1) #t))
|
|
|
|
(let ([my-blockades (map blockade-loc (find-blockades/color board color))])
|
|
(for-each-pawn/loc
|
|
board
|
|
(lambda (pawn my-loc)
|
|
(when (and (eq? (pawn-color pawn) color)
|
|
(number? my-loc))
|
|
(unless (member my-loc my-blockades)
|
|
(for-each-pawn/loc
|
|
board
|
|
(lambda (pawn their-loc)
|
|
(unless (eq? (pawn-color pawn) color)
|
|
(cond
|
|
[(eq? their-loc 'start)
|
|
(let ([their-enter-spot (get-enter-pos (pawn-color pawn))])
|
|
;; this code assumes that the enter-pos's are not within 6 of
|
|
;; where the board indicies wrap around.
|
|
(cond
|
|
[(= my-loc their-enter-spot)
|
|
(add-single-roll-chances 5)
|
|
(add-chance 2 3)
|
|
(add-chance 1 4)]
|
|
[(= my-loc (+ their-enter-spot 1))
|
|
(add-chance 5 1)]
|
|
[(= my-loc (+ their-enter-spot 2))
|
|
(add-chance 5 2)]
|
|
[(= my-loc (+ their-enter-spot 3))
|
|
(add-chance 5 3)]
|
|
[(= my-loc (+ their-enter-spot 4))
|
|
(add-chance 5 4)]
|
|
[(= my-loc (+ their-enter-spot 5))
|
|
(add-chance 5 5)]
|
|
[(= my-loc (+ their-enter-spot 6))
|
|
(add-chance 5 6)]))]
|
|
[(number? their-loc)
|
|
(unless (safety? my-loc)
|
|
(unless (find-blockade/between board their-loc my-loc)
|
|
(add-chances (dist-from their-loc my-loc))))])))))))))
|
|
|
|
(length (filter values (apply append (map vector->list (vector->list chances))))))
|
|
|
|
(define (dist-from them me)
|
|
(cond
|
|
[(< them me) (- me them)]
|
|
[else (- (+ me board-main-size) them)]))
|
|
|
|
;; find-distance : board color -> number
|
|
;; finds the cumulative distance that the pawns have
|
|
;; to travel before they can make it home.
|
|
(define (find-distance board color)
|
|
(define distance 0)
|
|
|
|
(for-each-pawn/loc
|
|
board
|
|
(lambda (pawn loc)
|
|
(when (eq? (pawn-color pawn) color)
|
|
(set! distance (+ (find-loc-distance loc color) distance)))))
|
|
distance)
|
|
|
|
;; find-loc-distance : loc color -> number
|
|
(define (find-loc-distance loc color)
|
|
(cond
|
|
[(eq? loc 'start) 100]
|
|
[(eq? loc 'home) 0]
|
|
[(number? loc)
|
|
(let* ([entry (get-enter-pos color)]
|
|
[exit (get-exit-pos color)]
|
|
[sub-from 73]
|
|
[dist-to-entry
|
|
(cond
|
|
[(<= entry loc) (- loc entry)]
|
|
[else (- (+ loc board-main-size) entry)])])
|
|
(- sub-from dist-to-entry))]
|
|
[else (- board-home-row-size (home-row-loc-num loc))]))
|
|
|
|
(define (insert x l)
|
|
(cond
|
|
[(empty? l) (list x)]
|
|
[(<= x (first l)) (cons x l)]
|
|
[else (cons (first l) (insert x (rest l)))]))
|
|
|
|
(define everywhere-board
|
|
(make-board (list (make-pawn 'red 2)
|
|
(make-pawn 'blue 0)
|
|
(make-pawn 'green 1)
|
|
(make-pawn 'yellow 3))
|
|
`#68(() () () () () (,(make-pawn 'green 0)) () ()
|
|
() () () () () () () ()
|
|
()
|
|
() () () () () (,(make-pawn 'red 1)) () ()
|
|
() () () () () () () ()
|
|
()
|
|
() () () () () (,(make-pawn 'blue 3)) () ()
|
|
() () () () () () () ()
|
|
()
|
|
() () () () () (,(make-pawn 'yellow 2)) () ()
|
|
() () () () () () () ())
|
|
(list (cons 'green `#7((,(make-pawn 'green 2)) ()))
|
|
(cons 'red `#7(() (,(make-pawn 'red 3)) ()))
|
|
(cons 'blue `#7(() () (,(make-pawn 'blue 1)) ()))
|
|
(cons 'yellow `#7(() () () (,(make-pawn 'yellow 0)) ())))
|
|
(list (make-pawn 'red 0)
|
|
(make-pawn 'blue 2)
|
|
(make-pawn 'green 3)
|
|
(make-pawn 'yellow 1))))
|
|
|
|
(define (run-test)
|
|
(define (build-state moves dice board)
|
|
(make-state moves
|
|
dice
|
|
(let loop ([moves moves]
|
|
[board board])
|
|
(cond
|
|
[(null? moves) board]
|
|
[else
|
|
(let-values ([(new-board bonus) (make-one-move board (car moves))])
|
|
(loop (cdr moves) new-board))]))))
|
|
|
|
(test-list (search (new-board) 'green (list 2 3))
|
|
(list (build-state (list (make-enter-piece (make-pawn 'green 0)))
|
|
'()
|
|
(new-board))
|
|
(build-state (list (make-enter-piece (make-pawn 'green 1)))
|
|
'()
|
|
(new-board))
|
|
(build-state (list (make-enter-piece (make-pawn 'green 2)))
|
|
'()
|
|
(new-board))
|
|
(build-state (list (make-enter-piece (make-pawn 'green 3)))
|
|
'()
|
|
(new-board))))
|
|
|
|
(test-list (search (new-board) 'green (list 5 2))
|
|
(list (build-state (list (make-enter-piece (make-pawn 'green 0))
|
|
(make-move-piece-main (make-pawn 'green 0) 5 2))
|
|
'()
|
|
(new-board))
|
|
(build-state (list (make-enter-piece (make-pawn 'green 1))
|
|
(make-move-piece-main (make-pawn 'green 1) 5 2))
|
|
'()
|
|
(new-board))
|
|
(build-state (list (make-enter-piece (make-pawn 'green 2))
|
|
(make-move-piece-main (make-pawn 'green 2) 5 2))
|
|
'()
|
|
(new-board))
|
|
(build-state (list (make-enter-piece (make-pawn 'green 3))
|
|
(make-move-piece-main (make-pawn 'green 3) 5 2))
|
|
'()
|
|
(new-board))))
|
|
|
|
(test (find-loc-distance 'start 'red) 100)
|
|
(test (find-loc-distance 'home 'red) 0)
|
|
(test (find-loc-distance (make-home-row-loc 1 'red) 'red) 6)
|
|
(test (find-loc-distance (get-enter-pos 'red) 'red) 73)
|
|
(test (find-loc-distance (get-exit-pos 'red) 'red) (- 73
|
|
board-main-size
|
|
(- (get-exit-pos 'red)
|
|
(get-enter-pos 'red))))
|
|
|
|
(test (find-distance (new-board) 'green)
|
|
(* 4 100))
|
|
(test (let-values ([(board bonus) (board-enter-piece (new-board) (make-pawn 'green 0))])
|
|
(find-distance board 'green))
|
|
(+ (* 3 100) 73))
|
|
(test (let-values ([(board bonus) (board-enter-piece (new-board) (make-pawn 'red 0))])
|
|
(find-distance board 'red))
|
|
(+ (* 3 100) 73))
|
|
(test (let-values ([(board bonus) (board-enter-piece (new-board) (make-pawn 'yellow 0))])
|
|
(find-distance board 'yellow))
|
|
(+ (* 3 100) 73))
|
|
(test (let-values ([(board bonus) (board-enter-piece (new-board) (make-pawn 'blue 0))])
|
|
(find-distance board 'blue))
|
|
(+ (* 3 100) 73))
|
|
(test (let-values ([(board bonus) (board-enter-piece (new-board) (make-pawn 'yellow 0))])
|
|
(let-values ([(board bonus) (board-move-piece-main board (make-pawn 'yellow 0) 56 60)])
|
|
(let-values ([(board bonus) (board-move-piece-main board (make-pawn 'yellow 0) 48 3)])
|
|
(find-distance board 'yellow))))
|
|
(+ (* 3 100) 10))
|
|
(test (let-values ([(board bonus) (board-enter-piece (new-board) (make-pawn 'yellow 0))])
|
|
(let-values ([(board bonus) (board-move-piece-main board (make-pawn 'yellow 0) 56 60)])
|
|
(let-values ([(board bonus) (board-move-piece-main board (make-pawn 'yellow 0) 48 4)])
|
|
(find-distance board 'yellow))))
|
|
(+ (* 3 100) 7))
|
|
(test (let-values ([(board bonus) (board-enter-piece (new-board) (make-pawn 'yellow 0))])
|
|
(let-values ([(board bonus) (board-move-piece-main board (make-pawn 'yellow 0) 56 60)])
|
|
(let-values ([(board bonus) (board-move-piece-main board (make-pawn 'yellow 0) 48 11)])
|
|
(find-distance board 'yellow))))
|
|
300)
|
|
(test (let-values ([(board bonus) (board-enter-piece (new-board) (make-pawn 'yellow 0))])
|
|
(let-values ([(board bonus) (board-move-piece-main board (make-pawn 'yellow 0) 56 60)])
|
|
(let-values ([(board bonus) (board-move-piece-main board (make-pawn 'yellow 0) 48 10)])
|
|
(find-distance board 'yellow))))
|
|
301)
|
|
(test (let-values ([(board bonus) (board-enter-piece (new-board) (make-pawn 'yellow 0))])
|
|
(let-values ([(board bonus) (board-move-piece-main board (make-pawn 'yellow 0) 56 40)])
|
|
(find-distance board 'yellow)))
|
|
333)
|
|
|
|
(test (let-values ([(board bonus) (board-enter-piece (new-board) (make-pawn 'blue 0))])
|
|
(let-values ([(board bonus) (board-enter-piece board (make-pawn 'blue 1))])
|
|
(let-values ([(board bonus) (board-move-piece-main board (make-pawn 'blue 0) 39 1)])
|
|
(let-values ([(board bonus) (board-move-piece-main board (make-pawn 'blue 1) 39 1)])
|
|
(let-values ([(board bonus) (board-enter-piece board (make-pawn 'blue 2))])
|
|
(let-values ([(board bonus) (board-enter-piece board (make-pawn 'blue 3))])
|
|
(find-distance board 'blue)))))))
|
|
(+ 73 73 72 72))
|
|
|
|
(test (find-bop-chance (mb) 'green) 0)
|
|
(test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
|
|
(make-enter-piece (make-pawn 'red 0))
|
|
(make-move-piece-main (make-pawn 'green 0) 5 16))
|
|
'green)
|
|
0)
|
|
(test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
|
|
(make-enter-piece (make-pawn 'green 1))
|
|
(make-move-piece-main (make-pawn 'green 0) 5 1))
|
|
'green)
|
|
0)
|
|
(test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
|
|
(make-move-piece-main (make-pawn 'green 0)
|
|
5
|
|
17))
|
|
'green)
|
|
15)
|
|
(test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
|
|
(make-move-piece-main (make-pawn 'green 0)
|
|
5
|
|
18))
|
|
'green)
|
|
2)
|
|
(test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
|
|
(make-move-piece-main (make-pawn 'green 0)
|
|
5
|
|
19))
|
|
'green)
|
|
2)
|
|
(test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
|
|
(make-move-piece-main (make-pawn 'green 0)
|
|
5
|
|
20))
|
|
'green)
|
|
2)
|
|
(test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
|
|
(make-move-piece-main (make-pawn 'green 0)
|
|
5
|
|
21))
|
|
'green)
|
|
2)
|
|
(test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
|
|
(make-move-piece-main (make-pawn 'green 0)
|
|
5
|
|
22))
|
|
'green)
|
|
1)
|
|
(test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
|
|
(make-move-piece-main (make-pawn 'green 0)
|
|
5
|
|
23))
|
|
'green)
|
|
2)
|
|
(test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
|
|
(make-move-piece-main (make-pawn 'green 0)
|
|
5
|
|
27))
|
|
'green)
|
|
0)
|
|
(test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
|
|
(make-enter-piece (make-pawn 'red 0))
|
|
(make-move-piece-main (make-pawn 'green 0) 5 16))
|
|
'red)
|
|
0)
|
|
(test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
|
|
(make-enter-piece (make-pawn 'red 0))
|
|
(make-move-piece-main (make-pawn 'green 0) 5 16)
|
|
(make-move-piece-main (make-pawn 'red 0) 22 1))
|
|
'red)
|
|
11)
|
|
|
|
(test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
|
|
(make-enter-piece (make-pawn 'red 0))
|
|
(make-enter-piece (make-pawn 'red 1))
|
|
(make-move-piece-main (make-pawn 'green 0) 5 16)
|
|
(make-move-piece-main (make-pawn 'red 0) 22 1))
|
|
'red)
|
|
11)
|
|
|
|
(test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
|
|
(make-enter-piece (make-pawn 'red 0))
|
|
(make-enter-piece (make-pawn 'red 1))
|
|
(make-move-piece-main (make-pawn 'green 0) 5 16)
|
|
(make-move-piece-main (make-pawn 'red 0) 22 1)
|
|
(make-move-piece-main (make-pawn 'red 1) 22 1))
|
|
'red)
|
|
0)
|
|
|
|
(test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
|
|
(make-enter-piece (make-pawn 'red 0))
|
|
(make-enter-piece (make-pawn 'red 1))
|
|
(make-move-piece-main (make-pawn 'green 0) 5 16)
|
|
(make-move-piece-main (make-pawn 'red 0) 22 1)
|
|
(make-move-piece-main (make-pawn 'red 1) 22 1)
|
|
(make-enter-piece (make-pawn 'red 2)))
|
|
'red)
|
|
0)
|
|
|
|
(test (find-bop-chance (mb (make-enter-piece (make-pawn 'green 0))
|
|
(make-enter-piece (make-pawn 'red 0))
|
|
(make-enter-piece (make-pawn 'red 1))
|
|
(make-move-piece-main (make-pawn 'green 0) 5 16)
|
|
(make-move-piece-main (make-pawn 'red 0) 22 1)
|
|
(make-move-piece-main (make-pawn 'red 1) 22 2)
|
|
(make-enter-piece (make-pawn 'red 2))
|
|
(make-move-piece-main (make-pawn 'red 2) 22 1))
|
|
'red)
|
|
0)
|
|
|
|
(test-results))
|
|
|
|
(define (mb . moves)
|
|
(let-values ([(board bonus) (make-moves (new-board) moves)])
|
|
board))
|
|
|
|
#;
|
|
(begin
|
|
(define problem-board
|
|
(make-board (list (make-pawn 'yellow 0)
|
|
(make-pawn 'blue 2)
|
|
(make-pawn 'blue 3)
|
|
(make-pawn 'red 3)
|
|
(make-pawn 'yellow 3))
|
|
`#68(() () () () () () () () () () () ()
|
|
(,(make-pawn 'green 2)) () () () () ()
|
|
(,(make-pawn 'blue 1)) ()
|
|
(,(make-pawn 'green 1)) () () () () ()
|
|
(,(make-pawn 'red 2)) () () () () ()
|
|
(,(make-pawn 'green 0)) () () () () ()
|
|
(,(make-pawn 'green 3)) () () () () () ()
|
|
(,(make-pawn 'blue 0)) () () () () ()
|
|
(,(make-pawn 'yellow 1)) ()
|
|
(,(make-pawn 'red 0)) () () () ()
|
|
(,(make-pawn 'red 1))
|
|
(,(make-pawn 'yellow 2)) ())
|
|
'((blue . #7(())) (green . #7(())) (red . #7(())) (yellow . #7(())))
|
|
'()))
|
|
|
|
#|
|
|
first cut in new board representation
|
|
cpu time: 42710 real time: 47086 gc time: 1400
|
|
1353 candidates
|
|
|
|
blockade move checking optimized:
|
|
cpu time: 5580 real time: 5828 gc time: 0
|
|
1353 candidates
|
|
|
|
use move-piece instead of removing and adding:
|
|
cpu time: 4700 real time: 4939 gc time: 0
|
|
1353 candidates
|
|
|
|
optimize blockade-in-the-way checking and macro-inline matching-pawns
|
|
cpu time: 2600 real time: 2779 gc time: 0
|
|
1353 candidates
|
|
|
|
another new board representation (vector of loc's)
|
|
cpu time: 1710 real time: 1799 gc time: 0
|
|
1353 candidates
|
|
|#
|
|
|
|
(let ([candidates (time (search problem-board 'green (list 1 1 6 6)))])
|
|
(printf "~s candidates\n" (length candidates))))
|
|
|
|
|
|
;color green dice (2 2 5 5)
|
|
;candidates 2893 (avg moves 6.952298651918424)
|
|
#;
|
|
(begin
|
|
(define problem-board2
|
|
(let loop ([board (new-board)]
|
|
[ents (list
|
|
(list (make-pawn 'blue 1) 'start)
|
|
(list (make-pawn 'red 2) 'start)
|
|
(list (make-pawn 'yellow 0) 'start)
|
|
(list (make-pawn 'yellow 1) 'start)
|
|
(list (make-pawn 'yellow 3) 'start)
|
|
(list (make-pawn 'green 1) 5)
|
|
(list (make-pawn 'green 3) 5)
|
|
(list (make-pawn 'blue 0) 17)
|
|
(list (make-pawn 'green 0) 21)
|
|
(list (make-pawn 'red 1) 23)
|
|
(list (make-pawn 'red 0) 25)
|
|
(list (make-pawn 'red 3) 26)
|
|
(list (make-pawn 'green 2) 27)
|
|
(list (make-pawn 'blue 3) 45)
|
|
(list (make-pawn 'blue 2) 47)
|
|
(list (make-pawn 'yellow 2) 63))])
|
|
(cond
|
|
[(null? ents) board]
|
|
[else (loop (move-piece board (car (car ents)) (cadr (car ents)))
|
|
(cdr ents))])))
|
|
|
|
#;
|
|
(require (lib "xml.ss" "xml")
|
|
"parse.ss")
|
|
#;
|
|
(define (dump-out-candidates candidates)
|
|
(let loop ([i 0]
|
|
[candidates candidates])
|
|
(unless (null? candidates)
|
|
(let ([candidate (car candidates)])
|
|
(call-with-output-file (build-path "problem-board-nexts"
|
|
(format "board~a.xml" i))
|
|
(lambda (port)
|
|
(write-xml/content (xexpr->xml (unparse-board (state-board candidate))) port))
|
|
'truncate
|
|
'text))
|
|
(loop (+ i 1) (cdr candidates)))))
|
|
|
|
(define candidates2 (time (search problem-board2 'green (list 2 2 5 5))))
|
|
;(dump-out-candidates candidates2)
|
|
(printf "~s candidates\n" (length candidates2)))
|
|
|
|
|
|
;(require "gui.ss") (show-board problem-board)
|
|
#|
|
|
cpu time: 12680 real time: 13855 gc time: 380
|
|
candidates 2797 (avg moves 6.9878441186986056)
|
|
board #5(struct:board (#3(struct:pawn yellow 0) #3(struct:pawn blue 2) #3(struct:pawn blue 3) #3(struct:pawn red 3) #3(struct:pawn yellow 3)) #68(() () () () () () () () () () () () (#3(struct:pawn green 2)) () () () () () (#3(struct:pawn blue 1)) () (#3(struct:pawn green 1)) () () () () () (#3(struct:pawn red 2)) () () () () () (#3(struct:pawn green 0)) () () () () () (#3(struct:pawn green 3)) () () () () () () (#3(struct:pawn blue 0)) () () () () () (#3(struct:pawn yellow 1)) () (#3(struct:pawn red 0)) () () () () (#3(struct:pawn red 1)) (#3(struct:pawn yellow 2)) ()) ((blue . #7(())) (green . #7(())) (red . #7(())) (yellow . #7(()))) ())
|
|
|#
|
|
|
|
#| more problem boards:
|
|
|
|
msec 5280
|
|
candidates 2441 (avg moves 6.699303564113069)
|
|
color blue dice (1 1 6 6)
|
|
#(struct:board
|
|
#16(54 63 39 54 start start start 40 start start 14 start 60 15 6 0))
|
|
|
|
msec 4750
|
|
candidates 2709 (avg moves 6.959025470653378)
|
|
color blue dice (1 1 6 6)
|
|
#(struct:board
|
|
#16(42 39 53 41 11 25 27 35 start start 40 start start 61 59 60))
|
|
|
|
msec 4100
|
|
candidates 1492 (avg moves 7.138739946380697)
|
|
color red dice (3 3 4 4)
|
|
#(struct:board
|
|
#16(39
|
|
61
|
|
start
|
|
58
|
|
20
|
|
0
|
|
62
|
|
start
|
|
37
|
|
37
|
|
42
|
|
#(struct:home-row-loc 4 red)
|
|
57
|
|
start
|
|
start
|
|
41))
|
|
|#
|
|
)
|
|
|