313 lines
16 KiB
Scheme
313 lines
16 KiB
Scheme
(module robot mzscheme
|
|
(require "counter.ss"
|
|
"board.ss"
|
|
"utils.ss"
|
|
(lib "unitsig.ss"))
|
|
|
|
(provide robot)
|
|
|
|
(define robot
|
|
(lambda (n history-in)
|
|
|
|
;; Setup ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define start-time (current-seconds))
|
|
|
|
(define RUN-TIME 25) ; 5 seconds less, just to be on the safe side
|
|
|
|
(define US-PIECE-WEIGHT 10)
|
|
(define US-MIDDLE-PIECE-WEIGHT 1)
|
|
(define US-LINE-PIECE-WEIGHT 1)
|
|
(define US-CONNECT-PIECE-WEIGHT 2)
|
|
|
|
(define THEM-PIECE-WEIGHT (- US-PIECE-WEIGHT))
|
|
(define THEM-MIDDLE-PIECE-WEIGHT (- US-MIDDLE-PIECE-WEIGHT))
|
|
(define THEM-LINE-PIECE-WEIGHT (- US-LINE-PIECE-WEIGHT))
|
|
(define THEM-CONNECT-PIECE-WEIGHT (- US-CONNECT-PIECE-WEIGHT))
|
|
|
|
(define THREAD-LIMIT 4)
|
|
(define thread-count 0)
|
|
|
|
;; Read in the board state and history,
|
|
;; converting history to our format
|
|
(define-values (board history as-player turn-number)
|
|
(let loop ([history-in history-in][b (new-board n)][h (new-history)][x? #t][t 0])
|
|
(let ([h (extend-history! b h)])
|
|
(if (null? history-in)
|
|
(values b h (if x? x o) t)
|
|
(begin
|
|
(let* ([d (caar history-in)]
|
|
[p (cadar history-in)])
|
|
(loop (cdr history-in)
|
|
(push b
|
|
(case d
|
|
[(t) 'top]
|
|
[(b) 'bottom]
|
|
[(l) 'left]
|
|
[(r) 'right])
|
|
(sub1 p)
|
|
(if x? x o))
|
|
h
|
|
(not x?)
|
|
(add1 t))))))))
|
|
|
|
(define RECURSION-DEPTH
|
|
(if (< turn-number 2)
|
|
1
|
|
#f))
|
|
|
|
(define WINNER-GOODNESS +inf.0)
|
|
(define LOSER-GOODNESS -inf.0)
|
|
(define MEDIUM-GOODNESS 0)
|
|
|
|
(define IMMEDIATE-WINNER-GOODNESS (cons WINNER-GOODNESS 1))
|
|
(define IMMEDIATE-LOSER-GOODNESS (cons LOSER-GOODNESS 1))
|
|
|
|
(define get-goodness
|
|
(invoke-unit/sig counter@ (n) params^))
|
|
|
|
;; Pick a move ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (make-get-best-move depth)
|
|
(lambda (board history as-player min-needed skip-right?)
|
|
(let* ([futures (n-map (if skip-right? (sub1 n) n)
|
|
(lambda (i) (cons (push board 'top i as-player) i)))]
|
|
[winners (map (lambda (f) (cons (find-winner (car f)) (cdr f))) futures)])
|
|
;; Can we win??
|
|
(let ([winning-move (ormap (lambda (w) (and (eq? (car w) as-player) (cdr w))) winners)])
|
|
(if winning-move
|
|
;; Yea!!
|
|
(cons IMMEDIATE-WINNER-GOODNESS winning-move)
|
|
|
|
;; Drop moves where we lose by the other player winning, or we've been
|
|
;; there before
|
|
(let ([futures
|
|
(let loop ([fs futures][ws winners])
|
|
(cond
|
|
[(null? fs) null]
|
|
[(or (caar ws) ; if there's a winner, it's not me!
|
|
(find-board-in-history (caar fs) history))
|
|
(loop (cdr fs) (cdr ws))]
|
|
[else (cons (car fs) (loop (cdr fs) (cdr ws)))]))])
|
|
|
|
(if (null? futures)
|
|
;; No non-losing moves? Pick a default with a very low goodness
|
|
(cons IMMEDIATE-LOSER-GOODNESS 0)
|
|
|
|
;; Now for the hard part.
|
|
(let* (;; First, estimate the goodness of the possible moves
|
|
[goodnesses (map (lambda (f)
|
|
(get-goodness (car f) board as-player depth))
|
|
futures)]
|
|
|
|
[good-futures (map cons goodnesses futures)]
|
|
; Now we have a list of (cons <goodness> (cons <board> <move>))
|
|
|
|
;; Filter the set of futures to choose a plausible set under the lookahead
|
|
;; threshold:
|
|
[local-good-futures good-futures]
|
|
|
|
[good-so-far LOSER-GOODNESS]
|
|
|
|
;; If we're not at depth 0, do a recursive lookahead
|
|
[good-futures
|
|
(if (positive? depth)
|
|
(map (lambda (gf)
|
|
(cons (if (>= good-so-far min-needed)
|
|
;; We've got something good enough, so just return LOSER
|
|
IMMEDIATE-LOSER-GOODNESS
|
|
|
|
(let ([move (search-space (cadr gf)
|
|
(extend-history (cadr gf) history)
|
|
(make-get-best-move (sub1 depth))
|
|
(other-player as-player)
|
|
;; Need something better than what we have...
|
|
(- (car gf) good-so-far))])
|
|
|
|
'(when (and (= depth RECURSION-DEPTH))
|
|
(fprintf (current-error-port) "Returned goodness: ~a~n" (car move))
|
|
(print-board (cadr gf) (current-error-port)))
|
|
|
|
(let ([g (car move)])
|
|
(let* ([new-goodness
|
|
(if (number? g)
|
|
; normal future
|
|
(- (car gf) g)
|
|
|
|
; win/lose - try to delay a loss
|
|
(cons (- (car g)) (+ 10000 (car gf) (cdr g))))]
|
|
[new-goodness-val (if (pair? new-goodness)
|
|
(car new-goodness)
|
|
new-goodness)])
|
|
|
|
;; New best goodness?
|
|
(when (> new-goodness-val good-so-far)
|
|
(set! good-so-far new-goodness-val))
|
|
|
|
new-goodness))))
|
|
(cdr gf)))
|
|
local-good-futures)
|
|
|
|
; Use what we have
|
|
local-good-futures)])
|
|
|
|
'(when (and (= depth RECURSION-DEPTH))
|
|
(for-each (lambda (gf)
|
|
(fprintf (current-error-port) "Goodness: ~a~n" (car gf))
|
|
(print-board (cadr gf) (current-error-port)))
|
|
good-futures))
|
|
|
|
|
|
(let ([r (if (andmap (lambda (x) (and (pair? (car x)) (= (caar x) LOSER-GOODNESS))) good-futures)
|
|
;; All losers; pick to delay the inevitable
|
|
(let ([m (pick-best (map (lambda (x) (cons (cdar x) (cdr x))) good-futures))])
|
|
(cons (cons LOSER-GOODNESS (car m)) (cdr m)))
|
|
|
|
;; Weighted non-losses. Pick one now:
|
|
(pick-best good-futures))])
|
|
|
|
;; Strip the board out, getting just the index
|
|
(cons (car r) (cddr r)))))))))))
|
|
|
|
|
|
;; Symmetry ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; search-space is a symmetry helper. Lets you write a move chooser,
|
|
;; get-best-move, that only needs to consider top pushes; the results
|
|
;; from calling get-best-move four times are filtered down to a single
|
|
;; choice. Also uses threads in the hope of exploiting extra
|
|
;; processors.
|
|
|
|
(define (search-space board history get-best-move as-player min-needed)
|
|
;; get-best-move is called with:
|
|
;; board history as-player skip-right?
|
|
;; It is actually called four times, once for each rotation of the board, so
|
|
;; get-best-move should only contemplate the space derived from pushing
|
|
;; at the top on the next move. If skip-right is #t, it shouldn't
|
|
;; contemplate pushing into the leftmost column because nothing's there;
|
|
;; a different rotation will catch the possibility.
|
|
;; The return value of get-best-move should be
|
|
;; (cons <goodness-rating> <push-position>)
|
|
;; where <goodness-rating> is a number or
|
|
;; (box <aux-goodness>)
|
|
;; the box means loser; if all moves lose, the best <aux-godness>
|
|
;; is picked.
|
|
;; The return values of `search-space' is
|
|
;; (cons <goodness-rating> (cons <side> <push-position>))
|
|
;; where <side> is in '(#\T #\B #\R #\L)
|
|
|
|
(let* ([top-board board]
|
|
[right-board (rotate-cw top-board 1)]
|
|
[bottom-board (rotate-cw right-board 1)]
|
|
[left-board (rotate-cw bottom-board 1)]
|
|
[moves (make-vector 4)]
|
|
[win-move #f]
|
|
[s (make-semaphore 0)]
|
|
[go (lambda (parallel? board pos transform)
|
|
(let ([f (lambda ()
|
|
(let ([v (transform
|
|
(get-best-move board history as-player
|
|
min-needed
|
|
(eq? none (board-cell board (sub1 n) 0))))])
|
|
(vector-set! moves pos v)
|
|
(let ([value (if (pair? (car v))
|
|
(caar v)
|
|
(car v))])
|
|
(when (>= value min-needed)
|
|
; Exceeded minimum necessary weight - short-circuit the rest
|
|
(set! win-move v)
|
|
(semaphore-post s)
|
|
(semaphore-post s)
|
|
(semaphore-post s))
|
|
(semaphore-post s))))])
|
|
(unless win-move
|
|
(if (and parallel? (< thread-count THREAD-LIMIT))
|
|
(thread (lambda ()
|
|
;; No locking on thread-count. It will be a little
|
|
;; inaccurate, but who cares?
|
|
(set! thread-count (add1 thread-count))
|
|
(f)
|
|
(set! thread-count (sub1 thread-count))))
|
|
(f)))))])
|
|
(go #t top-board 0 (lambda (x) (cons (car x) (cons #\T (cdr x)))))
|
|
(go #t bottom-board 1 (lambda (x) (cons (car x) (cons #\B (- n 1 (cdr x))))))
|
|
(go #t left-board 2 (lambda (x) (cons (car x) (cons #\R (cdr x)))))
|
|
(go #f right-board 3 (lambda (x) (cons (car x) (cons #\L (- n 1 (cdr x))))))
|
|
(semaphore-wait s)
|
|
(semaphore-wait s)
|
|
(semaphore-wait s)
|
|
(semaphore-wait s)
|
|
(if win-move
|
|
win-move
|
|
(let ([l (vector->list moves)])
|
|
(if (andmap (lambda (x) (and (pair? (car x)) (= (caar x) LOSER-GOODNESS))) l)
|
|
;; All losers; pick to delay the inevitable
|
|
(let ([m (pick-best (map (lambda (x) (cons (cdar x) (cdr x))) l))])
|
|
(cons (cons LOSER-GOODNESS (car m)) (cdr m)))
|
|
|
|
;; Pick a non-losing move
|
|
(pick-best l))))))
|
|
|
|
;; Using up our time ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Loop, choosing a deeper level of dept-first searching
|
|
;; each time. Kill everything an use the most-recently
|
|
;; computed value if we run out of time. The goodness
|
|
;; cache is reset each time; presumably, each iteration
|
|
;; calculates more precise values, overriding the old ones.
|
|
|
|
(define (use-up-time f)
|
|
(let ([result (cons (list-ref '(#\T #\B #\L #\R) (random 4)) (random n))] ; worst-case default
|
|
[c (make-custodian)])
|
|
(parameterize ([current-custodian c])
|
|
(thread
|
|
(lambda ()
|
|
(let loop ([iteration 0])
|
|
; (fprintf (current-error-port) "Starting iteration ~a~n" iteration)
|
|
(set! result (f iteration))
|
|
'(fprintf (current-error-port) " [finished iteration depth ~a: ~a~a]~n"
|
|
iteration (cadr result) (add1 (cddr result)))
|
|
(unless (or (pair? (car result)))
|
|
(loop (add1 iteration)))))))
|
|
(let loop ()
|
|
(let ([sleep-time (- RUN-TIME (- (current-seconds) start-time))])
|
|
(when (> sleep-time 1)
|
|
(sleep 1)
|
|
(unless (pair? (car result)) ; pair indicates win/lose
|
|
(loop)))))
|
|
result))
|
|
|
|
|
|
;; Result ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (go)
|
|
'(begin
|
|
(fprintf (current-error-port) "Start:~n")
|
|
(print-board board (current-error-port)))
|
|
(let* ([go (lambda (i)
|
|
(set! RECURSION-DEPTH i)
|
|
(search-space board history (make-get-best-move i) as-player WINNER-GOODNESS))]
|
|
[depth RECURSION-DEPTH]
|
|
[result (if depth
|
|
(go depth)
|
|
(use-up-time go))])
|
|
'(when (pair? (car result))
|
|
(fprintf (current-error-port) "we ~a~n"
|
|
(if (= (caar result) LOSER-GOODNESS)
|
|
"lose"
|
|
"win")))
|
|
(output-move (cdr result))))
|
|
|
|
;; Given (cons <side> <index>), returns the move
|
|
;; <side> is in '(#\T #\B #\R #\L)
|
|
(define (output-move move)
|
|
(list (case (car move)
|
|
[(#\T) 't]
|
|
[(#\B) 'b]
|
|
[(#\R) 'r]
|
|
[(#\L) 'l])
|
|
(add1 (cdr move))))
|
|
|
|
(go))))
|
|
|
|
|