day08.scm (8683B)
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 comparse 17 srfi-1 18 srfi-14 19 srfi-69) 20 21 ;;;;;;;;;;;;;;;;; 22 ;; Input parsing 23 24 (define (as-number parser) 25 (bind (as-string parser) 26 (lambda (s) 27 (result (string->number s))))) 28 29 (define spaces 30 (zero-or-more (is #\space))) 31 32 (define direction 33 (in #\L #\R)) 34 35 (define directions 36 (sequence* ((data (one-or-more direction)) 37 (_ (one-or-more (is #\newline)))) 38 (result data))) 39 40 (define node 41 (as-string (repeated (in char-set:letter) 3))) 42 43 (define (punctuation p) 44 (sequence spaces (is p) spaces)) 45 46 (define network-line 47 (sequence* ((start node) 48 (_ (punctuation #\=)) 49 (_ (punctuation #\()) 50 (left node) 51 (_ (punctuation #\,)) 52 (right node) 53 (_ (punctuation #\))) 54 (_ (is #\newline))) 55 (result (list start left right)))) 56 57 (define network 58 (one-or-more network-line)) 59 60 (define all-data 61 (sequence directions network)) 62 63 (define data (parse all-data (read-string))) 64 ;(write-line (conc "Input: " data)) 65 66 ;;;;;;;;;;;;;;;;; 67 ;; First Puzzle 68 69 (define left-link-table 70 (alist->hash-table 71 (map (lambda (x) (cons (car x) (cadr x))) (cadr data)))) 72 73 (define right-link-table 74 (alist->hash-table 75 (map (lambda (x) (cons (car x) (caddr x))) (cadr data)))) 76 77 (define (follow-link dir node) 78 (cond ((eqv? dir #\L) (hash-table-ref left-link-table node)) 79 ((eqv? dir #\R) (hash-table-ref right-link-table node)))) 80 81 (define (count-links-until directions start stop acc) 82 ; (write-line (conc "At step " acc ": " start)) 83 (cond ((equal? start stop) acc) 84 ((null? directions) (count-links-until (car data) start stop acc)) 85 (else (count-links-until (cdr directions) 86 (follow-link (car directions) start) 87 stop 88 (add1 acc))))) 89 90 (when (and (hash-table-exists? left-link-table "AAA") 91 (hash-table-exists? left-link-table "ZZZ")) 92 (write-line (conc "First puzzle: " (count-links-until '() "AAA" "ZZZ" 0)))) 93 94 ;;;;;;;;;;;;;;;;; 95 ;; Second Puzzle 96 97 (define (start-node? node) 98 (equal? (substring node 2 3) "A")) 99 100 (define (final-node? node) 101 (equal? (substring node 2 3) "Z")) 102 103 (define node-list 104 (hash-table-keys left-link-table)) 105 106 (define start-node-list 107 (filter start-node? node-list)) 108 109 (define state-list 110 (let loop ((directions (car data)) 111 (nodes node-list) 112 (acc '())) 113 (cond ((null? directions) acc) 114 ((null? nodes) (loop (cdr directions) node-list acc)) 115 (else (loop directions 116 (cdr nodes) 117 (cons (cons (car nodes) directions) acc)))))) 118 119 (define final-state-list 120 (filter (lambda (state) (final-node? (car state))) state-list)) 121 122 (define (next-state state) 123 (let ((node (car state)) 124 (cur-dir (cadr state)) 125 (next-dir (cddr state))) 126 (cons (follow-link cur-dir node) 127 (if (null? next-dir) (car data) next-dir)))) 128 129 (define next-final-memo (make-hash-table)) 130 131 ; state -> '(steps next-final-state) 132 (define (next-final! state) 133 (cond ((final-node? (car state)) (list 0 state)) 134 ((hash-table-exists? next-final-memo state) 135 (hash-table-ref next-final-memo state)) 136 (else 137 (let* ((next-result (next-final! (next-state state))) 138 (result (cons (add1 (car next-result)) (cdr next-result)))) 139 ; (write-line (conc "next-final " state " -> " result)) 140 (hash-table-set! next-final-memo state result) 141 result)))) 142 143 (define (next-final-state state) 144 (cadr (next-final! (next-state state)))) 145 146 ; position: '(state steps) 147 (define (update-beyond position min-steps) 148 (let* ((next-final (next-final! (next-state (car position)))) 149 (state (cadr next-final)) 150 (steps (+ (cadr position) 1 (car next-final))) 151 (updated-position (list state steps))) 152 (if (>= steps min-steps) 153 updated-position 154 (update-beyond updated-position min-steps)))) 155 156 (define (finished? positions) 157 (apply = (map cadr positions))) 158 159 (define (update-positions positions) 160 (let ((min-steps (apply min (map cadr positions))) 161 (max-steps (apply max (map cadr positions)))) 162 ; (write-line (conc "Updating from steps " min-steps "+" (- max-steps min-steps))) 163 (map (lambda (position) (if (< (cadr position) max-steps) 164 (update-beyond position max-steps) 165 position)) 166 positions))) 167 168 (define (answer-2 positions) 169 ; (write-line (conc "Positions: " positions)) 170 (if (finished? positions) 171 (write-line (conc "Second puzzle: " (cadar positions))) 172 (answer-2 (update-positions positions)))) 173 174 (define start-positions 175 (map (lambda (node) (list (cons node (car data)) 0)) start-node-list)) 176 177 (define initial-positions 178 (map (lambda (x) (update-beyond x 0)) start-positions)) 179 180 (define cycle-id-table (make-hash-table)) 181 (define next-cycle-id 1) 182 183 (define (update-cycle-id-table! state from-id to-id until-id) 184 ; (write-line (conc "update-cycle-id " (car state) "-" (length (cdr state)) " -> " to-id)) 185 (let ((prev-id (hash-table-ref cycle-id-table state))) 186 (if (= prev-id from-id) 187 (begin (hash-table-set! cycle-id-table state to-id) 188 (update-cycle-id-table! 189 (next-final-state state) from-id to-id until-id)) 190 (assert (= prev-id until-id))))) 191 192 (define (cycle-id state) 193 (assert (final-node? (car state))) 194 ; (write-line (conc "cycle-id " state)) 195 (unless (hash-table-exists? cycle-id-table state) 196 (let loop ((cur-state state)) 197 ; (write-line (conc " loop " state)) 198 (if (hash-table-exists? cycle-id-table cur-state) 199 (let ((entry (hash-table-ref cycle-id-table cur-state))) 200 (cond ((= entry (- next-cycle-id)) 201 (update-cycle-id-table! cur-state 202 (- next-cycle-id) 203 next-cycle-id 204 next-cycle-id) 205 (set! next-cycle-id (add1 next-cycle-id))) 206 ((< 0 entry next-cycle-id) 207 (update-cycle-id-table! 208 state (- next-cycle-id) (- entry) entry)) 209 ((< (- cycle-id) entry 0) 210 (update-cycle-id-table! 211 state (- next-cycle-id) entry (- entry)) 212 (else (assert #f))))) 213 (begin 214 (hash-table-set! cycle-id-table cur-state (- next-cycle-id)) 215 (loop (next-final-state cur-state)))))) 216 (hash-table-ref cycle-id-table state)) 217 218 (define (position->string position) 219 (conc (caar position) "-" (length (cdar position)) "/" (cadr position))) 220 221 ; I'm making weird assumptions there, let's check them 222 (define assert-ok 223 (let assert-loop ((positions initial-positions) (result #t)) 224 (if (null? positions) 225 result 226 (let ((next-position (update-beyond (car positions) (cadar positions))) 227 (cur-position (car positions))) 228 (if (and (equal? (caar cur-position) (caar next-position)) 229 (equal? (cdar cur-position) (cdar next-position)) 230 (= (* 2 (cadr cur-position) (cadr next-position)))) 231 (assert-loop (cdr positions) result) 232 (begin 233 (write-line (conc "Assumption mismatch for " 234 (position->string cur-position) 235 " -> " 236 (position->string next-position))) 237 (assert-loop (cdr positions) #f))))))) 238 239 ; So when all inputs reach a cycle of a single final-position without offset, 240 ; the result is simply the LCM of all lengths. 241 (when assert-ok 242 (write-line (conc "Second puzzle: " 243 (apply lcm (map cadr initial-positions)))))