day24.scm (14577B)
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 comparse 17 trace 18 srfi-1 19 srfi-14 20 srfi-69) 21 22 ;;;;;;;;;;;;;;;;; 23 ;; Input parsing 24 25 (define (as-number parser) 26 (bind (as-string parser) 27 (lambda (s) 28 (result (string->number s))))) 29 30 (define digit 31 (in char-set:digit)) 32 33 (define digits 34 (as-number (sequence (maybe (is #\-)) (one-or-more digit)))) 35 36 (define data-line 37 (sequence* ((px digits) 38 (_ (char-seq ", ")) 39 (py digits) 40 (_ (char-seq ", ")) 41 (pz digits) 42 (_ (sequence (char-seq " @") (zero-or-more (is #\space)))) 43 (vx digits) 44 (_ (sequence (is #\,) (zero-or-more (is #\space)))) 45 (vy digits) 46 (_ (sequence (is #\,) (zero-or-more (is #\space)))) 47 (vz digits) 48 (_ (is #\newline))) 49 (result `(,px ,py ,pz ,vx ,vy ,vz)))) 50 51 (define all-data 52 (one-or-more data-line)) 53 54 (define data 55 (parse all-data (read-string))) 56 (define verbose (< (length data) 10)) 57 (when verbose (write-line (conc "Input: " data))) 58 59 ;;;;;;;;;;;;;;;;; 60 ;; First Puzzle 61 62 (define (get-px line) (car line)) 63 (define (get-py line) (cadr line)) 64 (define (get-pz line) (caddr line)) 65 (define (get-vx line) (car (cdddr line))) 66 (define (get-vy line) (cadr (cdddr line))) 67 (define (get-vz line) (caddr (cdddr line))) 68 69 (define zone-min (if verbose 7 200000000000000)) 70 (define zone-max (if verbose 27 400000000000000)) 71 72 ;; 2D line is (px+t·vx, py+t·vy) i.e. (y-py)vx = (x-px)vy 73 ;; or x·vy - y·vx + py·vx - px·vy = 0 74 ;; intersect x·vy1·vx2 + py1·vx1·vx2 - px1·vy1·vx2 = 75 76 (define (intersect-2d line1 line2) 77 (let ((px1 (get-px line1)) 78 (py1 (get-py line1)) 79 (vx1 (get-vx line1)) 80 (vy1 (get-vy line1)) 81 (px2 (get-px line2)) 82 (py2 (get-py line2)) 83 (vx2 (get-vx line2)) 84 (vy2 (get-vy line2))) 85 (let ((d (- (* vx1 vy2) (* vx2 vy1)))) 86 (if (= 0 d) 87 (and (= px1 px2) (= py1 py2)) 88 (list (/ (+ (* py1 vx1 vx2) (* -1 px1 vy1 vx2) 89 (* px2 vy2 vx1) (* -1 py2 vx2 vx1)) d) 90 (/ (+ (* -1 px1 vy1 vy2) (* py1 vx1 vy2) 91 (* -1 py2 vx2 vy1) (* px2 vy2 vy1)) d)))))) 92 93 (define (check-1 line1 line2) 94 (let ((i (intersect-2d line1 line2))) 95 (cond ((not (pair? i)) 96 (when verbose (write-line "Degenerate")) 97 #f) 98 ((> 0 (+ (* (- (car i) (get-px line1)) 99 (get-vx line1)) 100 (* (- (cadr i) (get-py line1)) 101 (get-vy line1)))) 102 (when verbose (write-line "In the past of A: "))` 103 #f) 104 ((> 0 (+ (* (- (car i) (get-px line2)) 105 (get-vx line2)) 106 (* (- (cadr i) (get-py line2)) 107 (get-vy line2)))) 108 109 (when verbose (write-line "In the past of B")) 110 #f) 111 ((and (<= zone-min (car i) zone-max) 112 (<= zone-min (cadr i) zone-max)) 113 #t) 114 (else (when verbose (write-line "Not in zone")) #f)))) 115 116 (define (answer-1 dataset) 117 (let loop ((todo dataset) (rest (cdr dataset)) (result 0)) 118 (if (null? rest) 119 (if (null? (cdr todo)) 120 result 121 (loop (cdr todo) (cddr todo) result)) 122 (loop todo 123 (cdr rest) 124 (if (check-1 (car todo) (car rest)) 125 (add1 result) 126 result))))) 127 128 (write-line (conc "First puzzle: " (answer-1 data))) 129 130 ;;;;;;;;;;;;;;;;; 131 ;; Second Puzzle 132 133 ;; Giving index 0 to my stone and 1 to the hailsone, there is 134 ;; an intersection when there exists an integer t so that 135 ;; px0 + t·vx0 = px1 + t·vx1 and 136 ;; py0 + t·vy0 = py1 + t·vy1 and 137 ;; pz0 + t·vz0 = pz1 + t·vz1 and 138 ;; t >= 0 139 ;; which means that 140 ;; (px1-px0) / (vx1-vx0) = (py1-py0) / (vy1-vy0) = (pz1-pz0) / (vz1-vz0) ≤ 0 141 ;; with all these divisions having a zero remainder. 142 ;; So first v.0 intervals 143 144 ;; p.0 ∈ p.1 + ℕ·lcm((vx1-vx0),(vy1 145 ;; ≡ 146 147 (define (new-min inter target astep) 148 (let ((prev-min (car inter)) 149 (prev-step (cadr inter)) 150 (prev-max (caddr inter))) 151 (assert (> astep 0)) 152 (let loop ((result prev-min)) 153 (cond ((= target (remainder result astep)) result) 154 ((> result prev-max) #f) 155 (else (loop (+ result prev-step))))))) 156 157 (define (round-up val modulus) 158 (assert (and (> val 0) (> modulus 0))) 159 (let ((result (* modulus (add1 (quotient (sub1 val) modulus))))) 160 (assert (and (>= result val) (< val (+ result modulus)))) 161 result)) 162 163 (define (round-down val modulus) 164 (assert (and (>= val 0) (> modulus 0))) 165 (let ((result (* modulus (quotient val modulus)))) 166 (assert (and (<= result val) (> val (- result modulus)))) 167 result)) 168 169 (define (adjust-up val ref modulus) 170 (+ ref (round-up (- val ref) modulus))) 171 172 (define (adjust-down val ref modulus) 173 (+ ref (round-down (- val ref) modulus))) 174 175 (define (update-interval inter start step) 176 (let* ((prev-min (car inter)) 177 (prev-step (cadr inter)) 178 (prev-max (caddr inter)) 179 (astep (abs step)) 180 (new-step (if (or (= step 0) (= astep 0)) 0 (lcm astep prev-step))) 181 (div (if (or (= step 0) (= astep 0)) 0 (gcd astep prev-step)))) 182 (cond ((= step 0) 183 (if (and (<= prev-min start prev-max) 184 (or (= 0 prev-step) 185 (= 0 (remainder (- start prev-min) prev-step)))) 186 (list start 0 start) 187 #f)) 188 ((= prev-step 0) 189 (assert (= prev-min prev-max)) 190 (if (and (= (remainder prev-min astep) (remainder start astep)) 191 (or (= prev-min start) 192 (and (> prev-min start) (> step 0)) 193 (and (< prev-min start) (< step 0)))) 194 inter 195 #f)) 196 ((= (remainder prev-min div) (remainder start div)) 197 (let* ((updated-min (new-min inter 198 (remainder start astep) 199 astep)) 200 (result 201 (cond ((not updated-min) #f) 202 ((or (> updated-min prev-max) 203 (and (> step 0) (< prev-max start)) 204 (and (< step 0) (< start updated-min))) 205 #f) 206 ((> step 0) 207 (list (if (<= start updated-min) 208 updated-min 209 (adjust-up start updated-min new-step)) 210 new-step 211 (adjust-down prev-max updated-min new-step))) 212 (else 213 (list updated-min 214 new-step 215 (adjust-down (min prev-max start) 216 updated-min new-step)))))) 217 (cond ((or (not result) (> (car result) (caddr result))) #f) 218 ((= (car result) (caddr result)) 219 (list (car result) 0 (caddr result))) 220 (else result)))) 221 (else #f)))) 222 223 (define (next-v prev-v) 224 (if (<= prev-v 0) (- 1 prev-v) (- prev-v))) 225 226 227 (define (make-inter fn v) 228 (let loop ((inter (list 0 1 (* 2 zone-max))) 229 (to-check data)) 230 (cond ((not inter) #f) 231 ((null? to-check) inter) 232 (else (loop (update-interval inter 233 (fn (car to-check)) 234 (- (fn (cdddar to-check)) v)) 235 (cdr to-check)))))) 236 237 (define (next-valid-v fn start-v) 238 (let ((inter (make-inter fn start-v))) 239 (if inter (list start-v inter) (next-valid-v fn (next-v start-v))))) 240 241 (define (next-valid-vvv prev-vx prev-vy prev-vz) 242 (let ((vx (next-v prev-vx)) 243 (vy (next-v prev-vy)) 244 (vz (next-v prev-vz))) 245 (let ((inter-x (make-inter car vx))) 246 (if inter-x 247 (list 'x vx inter-x) 248 (let ((inter-y (make-inter cadr vy))) 249 (if inter-y 250 (list 'y vy inter-y) 251 (let ((inter-z (make-inter caddr vz))) 252 (if inter-z 253 (list 'z vz inter-z) 254 (next-valid-vvv vx vy vz))))))))) 255 256 (define (hail-valid? dpx dvx dpy dvy dpz dvz) 257 (cond ((= 0 dvx dvy dvz) (= 0 dpx dpy dpz)) 258 ((= 0 dvy dvz) 259 (assert (= 0 (remainder dpx dvx))) 260 (assert (>= 0 (quotient dpx dvx))) 261 (= 0 dpy dpz)) 262 ((= 0 dvx dvz) 263 (assert (= 0 (remainder dpy dvy))) 264 (assert (>= 0 (quotient dpy dvy))) 265 (= 0 dpx dpz)) 266 ((= 0 dvx dvy) 267 (assert (= 0 (remainder dpz dvz))) 268 (assert (>= 0 (quotient dpz dvz))) 269 (= 0 dpx dpy)) 270 ((= 0 dvx) 271 (assert (= 0 (remainder dpy dvy))) 272 (assert (= 0 (remainder dpz dvz))) 273 (assert (>= 0 (quotient dpy dvy))) 274 (assert (>= 0 (quotient dpz dvz))) 275 (and (= 0 dpx) 276 (= (quotient dpy dvy) 277 (quotient dpz dvz)))) 278 ((= 0 dvy) 279 (assert (= 0 (remainder dpx dvx))) 280 (assert (= 0 (remainder dpz dvz))) 281 (assert (>= 0 (quotient dpx dvx))) 282 (assert (>= 0 (quotient dpz dvz))) 283 (and (= 0 dpy) 284 (= (quotient dpx dvx) 285 (quotient dpz dvz)))) 286 ((= 0 dvz) 287 (assert (= 0 (remainder dpx dvx))) 288 (assert (= 0 (remainder dpy dvy))) 289 (assert (>= 0 (quotient dpx dvx))) 290 (assert (>= 0 (quotient dpy dvy))) 291 (and (= 0 dpz) 292 (= (quotient dpx dvx) 293 (quotient dpy dvy)))) 294 (else 295 (assert (= 0 (remainder dpx dvx))) 296 (assert (= 0 (remainder dpy dvy))) 297 (assert (= 0 (remainder dpz dvz))) 298 (assert (>= 0 (quotient dpx dvx))) 299 (assert (>= 0 (quotient dpy dvy))) 300 (assert (>= 0 (quotient dpz dvz))) 301 (= (quotient dpx dvx) 302 (quotient dpy dvy) 303 (quotient dpz dvz))))) 304 305 (define (start-pos-2 lx ly lz) 306 (let ((vx (car lx)) 307 (vy (car ly)) 308 (vz (car lz)) 309 (inter-px (cadr lx)) 310 (inter-py (cadr ly)) 311 (inter-pz (cadr lz))) 312 (let loop ((px (car inter-px)) 313 (py (car inter-py)) 314 (pz (car inter-pz)) 315 (to-check data)) 316 (cond ((> pz (caddr inter-pz)) 317 (loop px (+ py (max 1 (cadr inter-py))) (car inter-pz) data)) 318 ((> py (caddr inter-py)) 319 (loop (+ px (max 1 (cadr inter-px))) 320 (car inter-py) 321 (car inter-pz) 322 data)) 323 ((> px (caddr inter-px)) 324 #f) 325 ((null? to-check) (list px py pz)) 326 (else 327 (let ((hail-px (car (car to-check))) 328 (hail-py (cadr (car to-check))) 329 (hail-pz (caddr (car to-check))) 330 (hail-vx (car (cdddar to-check))) 331 (hail-vy (cadr (cdddar to-check))) 332 (hail-vz (caddr (cdddar to-check)))) 333 (if (hail-valid? (- hail-px px) (- hail-vx vx) 334 (- hail-py py) (- hail-vy vy) 335 (- hail-pz pz) (- hail-vz vz)) 336 (loop px py pz (cdr to-check)) 337 (loop px py (+ pz (max 1 (cadr inter-pz))) data)))))))) 338 339 (define (list-product l1 l2 l3) 340 (let loop ((r1 l1) (r2 l2) (r3 l3) (acc '())) 341 (cond ((null? r1) acc) 342 ((null? r2) (loop (cdr r1) l2 l3 acc)) 343 ((null? r3) (loop r1 (cdr r2) l3 acc)) 344 (else (loop r1 r2 (cdr r3) 345 (cons (list (car r1) (car r2) (car r3)) acc)))))) 346 347 (define answer-2 348 (let ((start-vx (next-valid-v car 0)) 349 (start-vz (next-valid-v caddr 0)) 350 (start-vy (next-valid-v cadr 0))) 351 (let loop ((all-vx (list start-vx)) 352 (all-vy (list start-vy)) 353 (all-vz (list start-vz)) 354 (todo (list (list start-vx start-vy start-vz)))) 355 (let ((result (start-pos-2 (caar todo) (cadar todo) (caddar todo)))) 356 (cond (result result) 357 ((not (null? (cdr todo))) 358 (loop all-vx all-vy all-vz (cdr todo))) 359 (else (let ((new-v (next-valid-vvv (caar all-vx) 360 (caar all-vy) 361 (caar all-vz)))) 362 (cond ((eqv? (car new-v) 'x) 363 (loop (cons (cdr new-v) all-vx) 364 all-vy 365 all-vz 366 (list-product (list (cdr new-v)) 367 all-vy 368 all-vz))) 369 ((eqv? (car new-v) 'y) 370 (loop all-vx 371 (cons (cdr new-v) all-vy) 372 all-vz 373 (list-product all-vx 374 (list (cdr new-v)) 375 all-vz))) 376 ((eqv? (car new-v) 'z) 377 (loop all-vx 378 all-vy 379 (cons (cdr new-v) all-vz) 380 (list-product all-vx 381 all-vy 382 (list (cdr new-v))))) 383 (else (assert #f)))))))))) 384 385 (write-line (conc "Second puzzle: " (apply + answer-2)))