166 lines
5.1 KiB
Scheme
166 lines
5.1 KiB
Scheme
(load "../common.scm")
|
|
|
|
(define (read-starting-positions filename)
|
|
(call-with-input-file
|
|
filename
|
|
(lambda (file)
|
|
(let* [(player-1 (begin
|
|
(get-string-n file (string-length "Player 1 starting position: "))
|
|
(get-number file)))
|
|
(player-2 (begin
|
|
(get-string-n file (string-length "Player 2 starting position: "))
|
|
(get-number file)))]
|
|
; subtracting one to play with a board numbered 0..9 instead of 1..10, just easier
|
|
(values (- player-1 1) (- player-2 1))))))
|
|
|
|
(define (deterministic-dice)
|
|
(let [(value -1)]
|
|
(lambda ()
|
|
(set! value (mod (+ value 1) 100))
|
|
(+ value 1))))
|
|
|
|
(define (roll! position-score dice)
|
|
(set-car! position-score (mod (+ (car position-score) (dice) (dice) (dice)) 10))
|
|
(set-cdr! position-score (+ (car position-score) (cdr position-score) 1)))
|
|
|
|
(define (play-deterministic position-1 position-2)
|
|
(let [(player-1 (cons position-1 0)) ; each player pair is (position . score)
|
|
(player-2 (cons position-2 0))
|
|
(dice (deterministic-dice))
|
|
(rolls 0)]
|
|
(let loop ()
|
|
(roll! player-1 dice)
|
|
(set! rolls (+ rolls 3))
|
|
(if (>= (cdr player-1) 1000)
|
|
(* (cdr player-2) rolls)
|
|
(begin
|
|
(roll! player-2 dice)
|
|
(set! rolls (+ rolls 3))
|
|
(if (>= (cdr player-1) 1000)
|
|
(* (cdr player-1) rolls)
|
|
(loop)))))))
|
|
|
|
(define (dirac-dice outcome)
|
|
(let [(next outcome)]
|
|
(lambda ()
|
|
(if (null? next)
|
|
#f
|
|
(let [(value (car next))]
|
|
(set! next (cdr next))
|
|
value)))))
|
|
|
|
(define (vector-sum vec start end)
|
|
(vector-fold
|
|
(lambda (i a x)
|
|
(if (and (>= i start)
|
|
(< i end))
|
|
(+ a x)
|
|
a))
|
|
0 vec))
|
|
|
|
(define-record-type state
|
|
(fields
|
|
(mutable position-1)
|
|
(mutable score-1)
|
|
(mutable position-2)
|
|
(mutable score-2)))
|
|
|
|
(define (state-equal? l r)
|
|
(and (equal? (state-position-1 l) (state-position-1 r))
|
|
(equal? (state-position-2 l) (state-position-2 r))
|
|
(equal? (state-score-1 l) (state-score-1 r))
|
|
(equal? (state-score-2 l) (state-score-2 r))))
|
|
|
|
(define (state-hash state)
|
|
(+ (state-position-1 state)
|
|
(* 6700417 (+ (state-position-2 state)
|
|
(* 6700417 (+ (state-score-1 state)
|
|
(* 6700417 (state-score-2 state))))))))
|
|
|
|
(define (make-state-hashtable)
|
|
(make-hashtable state-hash state-equal?))
|
|
|
|
(define (hashtable-for-each proc ht)
|
|
(let-values [((k v) (hashtable-entries ht))]
|
|
(vector-for-each (lambda (i k v) (proc k v)) k v)))
|
|
|
|
(define (hashtable-empty? ht)
|
|
(= (hashtable-size ht) 0))
|
|
|
|
; list of possible values obtained by summing 3 rolls of "3 sided dice"
|
|
; car is summed value of the 3 dice
|
|
; cdr is how many permutations give that sum
|
|
(define 3d3-outcomes
|
|
'((3 . 1) ; (1 1 1)
|
|
(4 . 3) ; (1 1 2) (1 2 1) (2 1 1)
|
|
(5 . 6) ; (1 1 3) (1 2 2) (1 3 1) (2 1 2) (2 2 1) (3 1 1)
|
|
(6 . 7) ; (1 2 3) (1 3 2) (2 1 3) (2 2 2) (2 3 1) (3 1 2) (3 2 1)
|
|
(7 . 6) ; (1 3 3) (2 2 3) (2 3 2) (3 1 3) (3 2 2) (3 3 1)
|
|
(8 . 3) ; (2 3 3) (3 2 3) (3 3 2)
|
|
(9 . 1))) ; (3 3 3)
|
|
|
|
(define (dirac-roll! states get-position get-score new-state)
|
|
(let [(wins 0)
|
|
(new (make-state-hashtable))]
|
|
(for-each
|
|
(lambda (outcome)
|
|
(let [(sum (car outcome))
|
|
(permutations (cdr outcome))]
|
|
(hashtable-for-each
|
|
(lambda (state amount)
|
|
(let* [(new-position (mod (+ (get-position state) sum) 10))
|
|
(new-score (+ (get-score state) new-position 1))
|
|
(universes (* amount permutations))]
|
|
(if (>= new-score 21)
|
|
(set! wins (+ wins universes))
|
|
(hashtable-set! new (new-state new-position new-score state) universes))))
|
|
states)))
|
|
3d3-outcomes)
|
|
(values wins new)))
|
|
|
|
(define (print-states states)
|
|
(hashtable-for-each
|
|
(lambda (state amount)
|
|
(printf "~20a : ~a~%" state amount))
|
|
states))
|
|
|
|
(define (play-dirac position-1 position-2)
|
|
; "states" tracks the amount of universes currently using a given state
|
|
(printf "Player 1 starting at ~a, player 2 at ~a~%" position-1 position-2)
|
|
(let [(states (make-state-hashtable))
|
|
(wins-1 0)
|
|
(wins-2 0)]
|
|
(hashtable-set! states (make-state position-1 0 position-2 0) 1)
|
|
(let loop ()
|
|
(let-values [((wins new-states)
|
|
(dirac-roll! states state-position-1 state-score-1
|
|
(lambda (new-position new-score old-state)
|
|
(make-state
|
|
new-position new-score
|
|
(state-position-2 old-state) (state-score-2 old-state)))))]
|
|
;(printf "P1:~%")
|
|
;(print-states new-states)
|
|
(set! wins-1 (+ wins-1 wins))
|
|
(printf "P1 wins: ~10a => ~a~%" wins wins-1)
|
|
(set! states new-states))
|
|
(let-values [((wins new-states)
|
|
(dirac-roll! states state-position-2 state-score-2
|
|
(lambda (new-position new-score old-state)
|
|
(make-state
|
|
(state-position-1 old-state) (state-score-1 old-state)
|
|
new-position new-score))))]
|
|
;(printf "P2:~%")
|
|
;(print-states new-states)
|
|
(set! wins-2 (+ wins-2 wins))
|
|
(printf "P2 wins: ~10a => ~a~%" wins wins-2)
|
|
(set! states new-states))
|
|
(if (hashtable-empty? states)
|
|
(max wins-1 wins-2)
|
|
(loop)))))
|
|
|
|
(let-values [((position-1 position-2) (read-starting-positions "input"))]
|
|
(printf "part 1:~% Rolls * Opponent Score = ~a~%"
|
|
(play-deterministic position-1 position-2))
|
|
(printf "part 2:~% Max Winning Universes: ~a~%"
|
|
(play-dirac position-1 position-2)))
|