day21.scm (13894B)
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 sort) (chicken string) 16 trace 17 srfi-1 18 srfi-69) 19 20 (define data-list (string-split (read-string))) 21 22 (define data-height (length data-list)) 23 (define data-width (string-length (car data-list))) 24 25 (define verbose (< data-height 21)) 26 27 (for-each 28 (lambda (line) (assert (= (string-length line) data-width))) 29 data-list) 30 31 (define data-vec 32 (list->vector 33 (apply append (map string->list data-list)))) 34 (assert (= (vector-length data-vec) (* data-width data-height))) 35 36 (define (xy->index xy) 37 (assert (and (< -1 (car xy) data-width) (< -1 (cdr xy) data-height))) 38 (+ (* data-width (cdr xy)) (car xy))) 39 40 (define (get-xy xy) 41 (vector-ref data-vec (xy->index xy))) 42 43 (define start-index 44 (let loop ((index 0)) 45 (if (eqv? (vector-ref data-vec index) #\S) 46 index 47 (loop (add1 index))))) 48 49 (define start-xy 50 (cons (remainder start-index data-width) (quotient start-index data-height))) 51 52 ;;;;;;;;;;;;;;;;; 53 ;; First Puzzle 54 55 56 (define (xy-valid? xy) 57 (and (< -1 (car xy) data-width) 58 (< -1 (cdr xy) data-height) 59 (not (eqv? (get-xy xy) #\#)))) 60 61 (define (right xy) (cons (add1 (car xy)) (cdr xy))) 62 (define (left xy) (cons (sub1 (car xy)) (cdr xy))) 63 (define (down xy) (cons (car xy) (add1 (cdr xy)))) 64 (define (up xy) (cons (car xy) (sub1 (cdr xy)))) 65 66 (define (neighbors xy) 67 (filter xy-valid? (list (left xy) (right xy) (up xy) (down xy)))) 68 69 (define min-steps-vec 70 (let ((result (make-vector (vector-length data-vec) -1))) 71 (let loop ((todo `((0 ,start-xy)))) 72 (if (null? todo) 73 result 74 (if (= -1 (vector-ref result (xy->index (cadar todo)))) 75 (begin 76 (vector-set! result (xy->index (cadar todo)) (caar todo)) 77 (loop (append (cdr todo) 78 (map (lambda (xy) (list (add1 (caar todo)) xy)) 79 (neighbors (cadar todo)))))) 80 (loop (cdr todo))))))) 81 82 (define (answer-1 steps) 83 (let loop ((index (sub1 (vector-length min-steps-vec))) 84 (acc 0)) 85 (if (< index 0) 86 acc 87 (loop (sub1 index ) 88 (if (and (<= 0 (vector-ref min-steps-vec index) steps) 89 (= 0 (remainder (+ (vector-ref min-steps-vec index) steps) 2))) 90 (add1 acc) 91 acc))))) 92 93 (when verbose 94 (let y-loop ((y 0)) 95 (unless (>= y data-height) 96 (write-line (apply conc (let x-loop ((x (sub1 data-width)) (acc '())) 97 (if (< x 0) acc 98 (x-loop (sub1 x) 99 (cons " " (cons (vector-ref min-steps-vec (xy->index (cons x y))) acc))))))) 100 (y-loop (add1 y))))) 101 102 (write-line (conc "First puzzle: " (answer-1 64))) 103 104 ;;;;;;;;;;;;;;;;; 105 ;; Second Puzzle 106 107 ; Use the fact that there is no rock on an edge, but assert it first 108 (let loop ((x (sub1 data-width))) 109 (unless (< x 0) 110 (assert (xy-valid? (cons x 0))) 111 (assert (xy-valid? (cons x (sub1 data-height)))) 112 (loop (sub1 x)))) 113 (let loop ((y (sub1 data-height))) 114 (unless (< y 0) 115 (assert (xy-valid? (cons 0 y))) 116 (assert (xy-valid? (cons (sub1 data-width) y))) 117 (loop (sub1 y)))) 118 119 ; Unusued primitives to explore the data 120 (define (steps-xy-< a b) 121 (or (< (car a) (car b)) 122 (and (= (car a) (car b)) 123 (< (caadr a) (caadr b))) 124 (and (= (car a) (car b)) 125 (= (caadr a) (caadr b)) 126 (< (cdadr a) (cdadr b))))) 127 128 (define (add-step-xy steps xy acc) 129 (let loop ((smaller '()) (rest acc)) 130 (if (and (not (null? rest)) (< (caar rest) steps)) 131 (loop (cons (car rest) smaller) (cdr rest)) 132 (append smaller (list (list steps xy)) rest)))) 133 134 (define (add-step-xylist steps xy-list acc) 135 (if (null? xy-list) 136 acc 137 (add-step-xylist steps 138 (cdr xy-list) 139 (add-step-xy steps (car xy-list) acc)))) 140 141 (define (last-line data-vec) 142 (let loop ((x (sub1 data-width)) (acc '())) 143 (if (< x 0) 144 acc 145 (loop (sub1 x) 146 (cons (vector-ref data-vec 147 (xy->index (cons x (sub1 data-height)))) 148 acc))))) 149 150 (define (propagate-down bottom-line) 151 (assert (= (length bottom-line) data-width)) 152 (let ((steps-vec (make-vector (vector-length data-vec) -1))) 153 (let loop ((todo (let init-loop ((x 0) (start-steps bottom-line) (acc '())) 154 (if (null? start-steps) 155 (sort! acc steps-xy-<) 156 (init-loop (add1 x) 157 (cdr start-steps) 158 (cons (list (add1 (car start-steps)) 159 (cons x 0)) 160 acc)))))) 161 (unless (null? todo) 162 (if (= -1 (vector-ref steps-vec (xy->index (cadar todo)))) 163 (begin 164 (vector-set! steps-vec (xy->index (cadar todo)) (caar todo)) 165 (loop (add-step-xylist (add1 (caar todo)) 166 (neighbors (cadar todo)) 167 (cdr todo)))) 168 (begin 169 (assert (<= (vector-ref steps-vec (xy->index (cadar todo))) 170 (caar todo))) 171 (loop (cdr todo)))))) 172 (last-line steps-vec))) 173 174 ;(trace propagate-down) 175 ;(propagate-down (propagate-down (propagate-down (propagate-down (last-line min-steps-vec))))) 176 177 ;(let* ((first-bottom (last-line min-steps-vec)) 178 ; (second-bottom (propagate-down first-bottom)) 179 ; (third-bottom (propagate-down second-bottom))) 180 ; (assert (equal? third-bottom 181 ; (map (lambda (s) (+ s data-height)) second-bottom)))) 182 183 ;; Build 5x5 copies of the original grid and solve it 184 185 (define (fold-xy xy) 186 (cons (remainder (car xy) data-width) 187 (remainder (cdr xy) data-height))) 188 189 (define (xy->index-2 xy) 190 (assert (and (< -1 (car xy) (* 5 data-width)) 191 (< -1 (cdr xy) (* 5 data-height))) 192 "Coordinates " xy " out of bounds") 193 (+ (* 5 data-width (cdr xy)) (car xy))) 194 195 (define (xy-valid-2? xy) 196 (and (< -1 (car xy) (* 5 data-width)) 197 (< -1 (cdr xy) (* 5 data-height)) 198 (not (eqv? (get-xy (cons (remainder (car xy) data-width) 199 (remainder (cdr xy) data-height))) 200 #\#)))) 201 202 (define (neighbors-2 xy) 203 (filter xy-valid-2? (list (left xy) (right xy) (up xy) (down xy)))) 204 205 (define min-steps-vec-2 206 (let ((result (make-vector (* 25 (vector-length data-vec)) -1))) 207 (let loop ((todo `((0 (,(+ (car start-xy) data-width data-width) 208 . ,(+ (cdr start-xy) data-height data-height)))))) 209 (if (null? todo) 210 result 211 (if (= -1 (vector-ref result (xy->index-2 (cadar todo)))) 212 (begin 213 (vector-set! result (xy->index-2 (cadar todo)) (caar todo)) 214 (loop (append (cdr todo) 215 (map (lambda (xy) (list (add1 (caar todo)) xy)) 216 (neighbors-2 (cadar todo)))))) 217 (loop (cdr todo))))))) 218 219 ;; Double check that outer grid is the same as the inner grid 220 221 (define (valid-or-negative? val-1 val-2 dist) 222 (or (= -1 val-2 val-2) 223 (= val-1 (+ val-2 dist)))) 224 225 (define (check-dist vec xy-1 xy-2 dist) 226 (if (valid-or-negative? (vector-ref vec (xy->index-2 xy-1)) 227 (vector-ref vec (xy->index-2 xy-2)) 228 dist) 229 #t 230 (begin 231 (write-line (conc "Check failed between " xy-1 232 " as " (vector-ref vec (xy->index-2 xy-1)) 233 " and " xy-2 234 " as " (vector-ref vec (xy->index-2 xy-2)) 235 ", expected " dist)) 236 #f))) 237 238 (let y-loop ((y (sub1 data-height))) 239 (unless (< y 0) 240 (let x-loop ((x (sub1 (* 5 data-width)))) 241 (unless (< x 0) 242 (assert (check-dist min-steps-vec-2 243 (cons x y) 244 (cons x (+ y data-height)) 245 data-height)) 246 (assert (check-dist min-steps-vec-2 247 (cons x (- (* 5 data-height) y 1)) 248 (cons x (- (* 4 data-height) y 1)) 249 data-height)) 250 (x-loop (sub1 x)))) 251 (y-loop (sub1 y)))) 252 253 (let x-loop ((x (sub1 data-width))) 254 (unless (< x 0) 255 (let y-loop ((y (sub1 (* 5 data-height)))) 256 (unless (< y 0) 257 (assert (check-dist min-steps-vec-2 258 (cons x y) 259 (cons (+ x data-width) y) 260 data-width)) 261 (assert (check-dist min-steps-vec-2 262 (cons (- (* 5 data-width) x 1) y) 263 (cons (- (* 4 data-width) x 1) y) 264 data-width)) 265 (y-loop (sub1 y)))) 266 (x-loop (sub1 x)))) 267 268 ;; Use periodicity to fold space upon itself 269 270 (assert (= data-width data-height)) 271 (assert (= (remainder data-width 2) 1)) 272 (define data-radius 273 (/ (sub1 data-width) 2)) 274 275 (define (count-2 vec start-x start-y end-x end-y steps) 276 (let loop ((x start-x) (y start-y) (acc 0)) 277 (cond ((>= y end-y) acc) 278 ((>= x end-x) (loop start-x (add1 y) acc)) 279 (else 280 (loop (add1 x) y 281 (if (and (= (remainder (+ x y) 2) (remainder steps 2)) 282 (<= 0 (vector-ref vec (xy->index-2 (cons x y))) steps)) 283 (add1 acc) 284 acc)))))) 285 286 (define (count-2* start-x-block start-y-block end-x-block end-y-block steps) 287 (count-2 min-steps-vec-2 288 (* start-x-block data-width) (* start-y-block data-height) 289 (* end-x-block data-width) (* end-y-block data-height) 290 steps)) 291 292 (define (write-count-grid steps) 293 (write-line (conc (count-2* 0 0 1 1 steps) "\t" 294 (count-2* 1 0 2 1 steps) "\t" 295 (count-2* 2 0 3 1 steps) "\t" 296 (count-2* 3 0 4 1 steps) "\t" 297 (count-2* 4 0 5 1 steps))) 298 (write-line (conc (count-2* 0 1 1 2 steps) "\t" 299 (count-2* 1 1 2 2 steps) "\t" 300 (count-2* 2 1 3 2 steps) "\t" 301 (count-2* 3 1 4 2 steps) "\t" 302 (count-2* 4 1 5 2 steps))) 303 (write-line (conc (count-2* 0 2 1 3 steps) "\t" 304 (count-2* 1 2 2 3 steps) "\t" 305 (count-2* 2 2 3 3 steps) "\t" 306 (count-2* 3 2 4 3 steps) "\t" 307 (count-2* 4 2 5 3 steps))) 308 (write-line (conc (count-2* 0 3 1 4 steps) "\t" 309 (count-2* 1 3 2 4 steps) "\t" 310 (count-2* 2 3 3 4 steps) "\t" 311 (count-2* 3 3 4 4 steps) "\t" 312 (count-2* 4 3 5 4 steps))) 313 (write-line (conc (count-2* 0 4 1 5 steps) "\t" 314 (count-2* 1 4 2 5 steps) "\t" 315 (count-2* 2 4 3 5 steps) "\t" 316 (count-2* 3 4 4 5 steps) "\t" 317 (count-2* 4 4 5 5 steps)))) 318 319 (define (answer-2 steps) 320 (let ((reduced-steps (+ data-width data-radius (remainder (- steps data-radius) data-width))) 321 (expansion-count (sub1 (quotient (- steps data-radius) data-width)))) 322 (write-line (conc "Expansions " expansion-count ", steps " reduced-steps)) 323 (write-count-grid reduced-steps) 324 (write-line "") 325 (write-count-grid (+ data-width reduced-steps)) 326 (write-line "") 327 (write-count-grid (+ data-width data-width reduced-steps)) 328 (let ((crown (+ (count-2* 1 2 2 3 reduced-steps) 329 (count-2* 2 1 3 2 reduced-steps) 330 (count-2* 2 3 3 4 reduced-steps) 331 (count-2* 3 2 4 3 reduced-steps))) 332 (edge1 (+ (count-2* 1 1 2 2 reduced-steps) 333 (count-2* 1 3 2 4 reduced-steps) 334 (count-2* 3 1 4 2 reduced-steps) 335 (count-2* 3 3 4 4 reduced-steps))) 336 (edge2 (+ (count-2* 1 1 2 2 (+ reduced-steps data-width)) 337 (count-2* 1 3 2 4 (+ reduced-steps data-width)) 338 (count-2* 3 1 4 2 (+ reduced-steps data-width)) 339 (count-2* 3 3 4 4 (+ reduced-steps data-width)))) 340 (middle1 (count-2* 2 2 3 3 reduced-steps)) 341 (middle2 (count-2* 2 2 3 3 (+ reduced-steps data-width)))) 342 (write-line (conc "Crown: " crown ", edges " edge1 " " edge2 ", middle " middle1 " " middle2)) 343 (+ crown 344 (* edge1 (add1 expansion-count)) 345 (* edge2 expansion-count) 346 (* middle1 (* (add1 expansion-count) (add1 expansion-count))) 347 (* middle2 (* expansion-count expansion-count)))))) 348 349 ;; The loop below shows it doesn't really work, 350 ;; but it does gives the correct answer for my input ¯\_(ツ)_/¯ 351 (let loop ((steps '(196 327 193 324))) 352 (unless (null? steps) 353 (write-line (conc "Debug: " (car steps) 354 " -> " (answer-2 (car steps)) 355 " vs " (count-2* 0 0 5 5 (car steps)))) 356 (loop (cdr steps)))) 357 358 (write-line (conc "Second puzzle: " (answer-2 26501365)))