aoc-all

My solutions to all Advent of Code
git clone https://git.instinctive.eu/aoc-all.git
Log | Files | Refs | README | LICENSE

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)))