day17.scm (9400B)
1 ; Copyright (c) 2023, Natacha Porté 2 ; 3 ; Permission to use, copy, modify, and distribute this software for any 4 ; purpose with or without fee is hereby granted, provided that the above 5 ; copyright notice and this permission notice appear in all copies. 6 ; 7 ; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 ; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 ; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 ; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 ; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 ; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 ; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 15 (import (chicken io) (chicken string) 16 srfi-1 17 srfi-69 18 srfi-128 19 srfi-146) 20 21 (define verbose #t) 22 23 (define data-list (string-split (read-string))) 24 25 (define data-height (length data-list)) 26 (define data-width (string-length (car data-list))) 27 28 (for-each 29 (lambda (line) (assert (= (string-length line) data-width))) 30 data-list) 31 32 (define data-vec 33 (list->vector 34 (map (lambda (c) (- (char->integer c) 48)) 35 (apply append (map string->list data-list))))) 36 (assert (= (vector-length data-vec) (* data-width data-height))) 37 38 ;;;;;;;;;;;;;;;;; 39 ;; First Puzzle 40 41 (define (score x y) 42 (vector-ref data-vec (+ (* data-width y) x))) 43 44 ;; State transition function 45 46 (define (turn-left dir) 47 (cond ((eqv? dir 'right) 'up) 48 ((eqv? dir 'left) 'down) 49 ((eqv? dir 'down) 'right) 50 ((eqv? dir 'up) 'left) 51 (else (assert #f "Invalid direction " dir)))) 52 53 (define (turn-right dir) 54 (cond ((eqv? dir 'right) 'down) 55 ((eqv? dir 'left) 'up) 56 ((eqv? dir 'down) 'left) 57 ((eqv? dir 'up) 'right) 58 (else (assert #f "Invalid direction " dir)))) 59 60 (define (state->score state) 61 (score (car state) (cadr state))) 62 63 (define (unchecked-next-state state) 64 (let ((x (car state)) 65 (y (cadr state)) 66 (steps (caddr state)) 67 (dir (cadddr state))) 68 (cond ((eqv? dir 'right) `(,(add1 x) ,y ,(add1 steps) ,dir)) 69 ((eqv? dir 'left) `(,(sub1 x) ,y ,(add1 steps) ,dir)) 70 ((eqv? dir 'down) `(,x ,(add1 y) ,(add1 steps) ,dir)) 71 ((eqv? dir 'up) `(,x ,(sub1 y) ,(add1 steps) ,dir)) 72 (else (assert #f "Invalid direction " dir))))) 73 74 (define (state-valid-1? state) 75 (let ((x (car state)) 76 (y (cadr state)) 77 (steps (caddr state)) 78 (dir (cadddr state))) 79 (and (< -1 x data-width) 80 (< -1 y data-height) 81 (<= steps 3)))) 82 83 (define (next-states-1 state) 84 (let ((x (car state)) 85 (y (cadr state)) 86 (steps (caddr state)) 87 (dir (cadddr state))) 88 (filter! state-valid-1? 89 (map! unchecked-next-state 90 `((,x ,y ,steps, dir) 91 (,x ,y 0 ,(turn-left dir)) 92 (,x ,y 0 ,(turn-right dir))))))) 93 94 (define (final-1? state) 95 (and (= (car state) (sub1 data-width)) 96 (= (cadr state) (sub1 data-height)))) 97 98 (define (write-scores scores) 99 (let loop ((suffixes '((1 left) (1 right) (1 up) (1 down) 100 (2 left) (2 right) (2 up) (2 down) 101 (3 left) (3 right) (3 up) (3 down)))) 102 (unless (null? suffixes) 103 (write-line (conc (car suffixes) ":")) 104 (let yloop ((y 0)) 105 (when (< y data-height) 106 (write-line (apply conc 107 (let xloop ((x (sub1 data-width)) (acc '())) 108 (if (< x 0) 109 (cons " " acc) 110 (xloop (sub1 x) (cons " " (cons (hash-table-ref/default scores (cons x (cons y (car suffixes))) "???") acc))))))) 111 (yloop (add1 y)))) 112 (loop (cdr suffixes))))) 113 114 (define (state-part->number x) 115 (cond ((number? x) x) 116 ((eqv? x 'right) 0) 117 ((eqv? x 'left) 1) 118 ((eqv? x 'down) 2) 119 ((eqv? x 'up) 3) 120 (else (assert #f)))) 121 122 (define (state-index state) 123 (let ((x (car state)) 124 (y (cadr state)) 125 (steps (caddr state)) 126 (dir (cadddr state))) 127 (+ x (* data-width 128 (+ y (* data-height 129 (+ (state-part->number dir) (* 4 steps)))))))) 130 131 (define max-state-index (* data-width data-height 50)) 132 133 ;; Queue management 134 135 (define (recursive-less a b) 136 (let ((aa (state-part->number (car a))) (bb (state-part->number (car b)))) 137 (or (< aa bb) 138 (and (= aa bb) 139 (recursive-less (cdr a) (cdr b)))))) 140 141 (define (scored-state? s) 142 (and (pair? s) 143 (number? (car s)) ; score 144 (number? (cadr s)) ; x 145 (number? (caddr s)) ; y 146 (number? (cadddr s)) ; steps 147 (symbol? (car (cddddr s))) ; direction 148 (null? (cdr (cddddr s))))) 149 150 (define scored-state-comparator 151 (make-comparator scored-state? equal? recursive-less default-hash)) 152 153 (define (queue-add queue state score) 154 (mapping-set! queue (cons score state) #t)) 155 156 (define (queue-update queue state old-score new-score) 157 (mapping-set! 158 (mapping-delete! queue (cons old-score state)) 159 (cons new-score state))) 160 161 (define (make-queue scores states) 162 (let loop ((todo states) 163 (result (mapping scored-state-comparator))) 164 (if (null? todo) 165 result 166 (loop (cdr todo) 167 (queue-add result 168 (car todo) 169 (vector-ref scores (state-index (car todo)))))))) 170 171 (define (queue-pop queue) 172 (let ((result (mapping-min-key queue))) 173 (cons (cdr result) (mapping-delete! queue result)))) 174 175 ;; Good old Djikstra 176 177 (define (answer a b next-states final?) 178 (let ((scores (make-vector max-state-index 0)) 179 (visited (make-vector max-state-index 0)) 180 (start '((1 0 1 right) (0 1 1 down))) 181 (total (* data-width data-height a))) 182 (for-each 183 (lambda (state) 184 (vector-set! visited (state-index state) 1) 185 (vector-set! scores (state-index state) (state->score state))) 186 start) 187 (let loop ((unvisited (make-queue scores start)) (result '()) (count 1)) 188 (if (or (null? unvisited) (= (length result) b)) 189 (apply min result) 190 (let* ((reordered (queue-pop unvisited)) 191 (state (car reordered)) 192 (score (vector-ref scores (state-index state))) 193 (queue (cdr reordered)) 194 (next (next-states state)) 195 (new-next (filter 196 (lambda (s) (= (vector-ref visited (state-index s)) 0)) 197 next))) 198 (assert (= (vector-ref visited (state-index state)) 1)) 199 ;(when (final? state) 200 ; (write-line (conc "final score " score)) 201 ; (let local-loop ((s state)) 202 ; (write-line (conc " from " s " at " (hash-table-ref scores s))) 203 ; (when (hash-table-exists? sources s) 204 ; (local-loop (hash-table-ref sources s))))) 205 ;(write-line (conc "State " state " " score)) 206 ;(write-line (conc " next: " next)) 207 ;(write-line (conc " new: " new-next)) 208 (write-string (conc (quotient (* 100 count) total) "%\r")) 209 (for-each 210 (lambda (s) 211 (let ((new-score (+ score (state->score s))) 212 (index (state-index s))) 213 (vector-set! visited index 1) 214 (vector-set! scores index new-score) 215 (set! queue (queue-add queue s new-score)))) 216 new-next) 217 (for-each 218 (lambda (s) 219 (let* ((new-score (+ score (state->score s))) 220 (index (state-index s)) 221 (old-score (vector-ref scores index))) 222 (when (< new-score old-score) 223 (assert (= (vector-ref visited index) 1)) 224 (set! queue (queue-update queue s old-score new-score)) 225 (vector-set! scores index new-score)))) 226 next) 227 (vector-set! visited (state-index state) 2) 228 (loop queue 229 (if (final? state) 230 (begin 231 (when verbose 232 (write-line "") 233 (write-line (conc "Final state " state " " score))) 234 (cons score result)) 235 result) 236 (add1 count))))))) 237 238 (write-line (conc "First puzzle: " (answer 12 6 next-states-1 final-1?))) 239 240 ;;;;;;;;;;;;;;;;; 241 ;; Second Puzzle 242 243 ;; New state transitions 244 245 (define (state-valid-2? state) 246 (let ((x (car state)) 247 (y (cadr state)) 248 (steps (caddr state)) 249 (dir (cadddr state))) 250 (and (< -1 x data-width) 251 (< -1 y data-height) 252 (<= steps 10)))) 253 254 (define (next-states-2 state) 255 (let ((x (car state)) 256 (y (cadr state)) 257 (steps (caddr state)) 258 (dir (cadddr state))) 259 (filter! state-valid-2? 260 (cons (unchecked-next-state state) 261 (if (>= steps 4) 262 (map! unchecked-next-state 263 `((,x ,y 0 ,(turn-left dir)) 264 (,x ,y 0 ,(turn-right dir)))) 265 '()))))) 266 267 (define (final-2? state) 268 (and (final-1? state) 269 (>= (caddr state) 4))) 270 271 (write-line (conc "Second puzzle: " (answer 40 14 next-states-2 final-2?)))