day22.scm (10972B)
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 (one-or-more digit))) 35 36 (define data-line 37 (sequence* ((x1 digits) 38 (_ (is #\,)) 39 (y1 digits) 40 (_ (is #\,)) 41 (z1 digits) 42 (_ (is #\~)) 43 (x2 digits) 44 (_ (is #\,)) 45 (y2 digits) 46 (_ (is #\,)) 47 (z2 digits) 48 (_ (is #\newline))) 49 (result `(,x1 ,y1 ,z1 ,x2 ,y2 ,z2)))) 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 (list-max-xyz l) 63 (foldl (lambda (acc item) 64 `(,(max (car acc) (car item) (car (cdddr item))) 65 ,(max (cadr acc) (cadr item) (cadr (cdddr item))) 66 ,(max (caddr acc) (caddr item) (caddr (cdddr item))))) 67 '(0 0 0) 68 l)) 69 70 (define (for-each-xyz proc line) 71 (let ((start-x (car line)) 72 (start-y (cadr line)) 73 (start-z (caddr line)) 74 (end-x (car (cdddr line))) 75 (end-y (cadr (cdddr line))) 76 (end-z (caddr (cdddr line)))) 77 (let loop ((x start-x) (y start-y) (z start-z)) 78 (cond ((> z end-z)) 79 ((> y end-y) (loop start-x start-y (add1 z))) 80 ((> x end-x) (loop start-x (add1 y) z)) 81 (else (proc x y z) 82 (loop (add1 x) y z)))))) 83 84 (define (fold-xyz proc init line) 85 (let ((start-x (car line)) 86 (start-y (cadr line)) 87 (start-z (caddr line)) 88 (end-x (car (cdddr line))) 89 (end-y (cadr (cdddr line))) 90 (end-z (caddr (cdddr line)))) 91 (let loop ((x start-x) (y start-y) (z start-z) (val init)) 92 (cond ((> z end-z) val) 93 ((> y end-y) (loop start-x start-y (add1 z) val)) 94 ((> x end-x) (loop start-x (add1 y) z val)) 95 (else (loop (add1 x) y z 96 (proc val x y z))))))) 97 98 (define (data->vec l) 99 (let* ((max-xyz (list-max-xyz (map cdr l))) 100 (x-size (add1 (car max-xyz))) 101 (y-size (add1 (cadr max-xyz))) 102 (z-size (add1 (caddr max-xyz))) 103 (idx (lambda (x y z) 104 (assert (< -1 x x-size) "Out of bound x " x x-size) 105 (assert (< -1 y y-size) "Out of bound y " y y-size) 106 (assert (< -1 z z-size) "Out of bound z " z z-size) 107 (+ x (* x-size (+ y (* y-size z)))))) 108 (result (make-vector (* x-size y-size z-size) 0))) 109 (let loop ((todo l)) 110 (if (null? todo) 111 (list idx result) 112 (begin 113 (for-each-xyz 114 (lambda (x y z) 115 (assert (= 0 (vector-ref result (idx x y z)))) 116 (vector-set! result (idx x y z) (caar todo))) 117 (cdar todo)) 118 (loop (cdr todo))))))) 119 120 (define (lower-line line) 121 `(,(car line) 122 ,(cadr line) 123 ,(sub1 (caddr line)) 124 ,(car (cdddr line)) 125 ,(cadr (cdddr line)) 126 ,(sub1 (caddr (cdddr line))))) 127 128 (define (flatten-line line) 129 `(,(car line) 130 ,(cadr line) 131 ,(min (caddr line) (caddr (cdddr line))) 132 ,(car (cdddr line)) 133 ,(cadr (cdddr line)) 134 ,(min (caddr line) (caddr (cdddr line))))) 135 136 (define (drop! xyz->index vec l) 137 (let* ((all-are? (lambda (line num) 138 (fold-xyz 139 (lambda (val x y z) 140 (and val 141 (= num (vector-ref vec (xyz->index x y z))))) 142 #t 143 line))) 144 (update! (lambda (line from-num to-num) 145 (for-each-xyz 146 (lambda (x y z) 147 (assert 148 (= from-num (vector-ref vec (xyz->index x y z)))) 149 (vector-set! vec (xyz->index x y z) to-num)) 150 line))) 151 (valid? (lambda (line) 152 (and (< 0 (caddr line)) 153 (< 0 (caddr (cdddr line))) 154 (all-are? (flatten-line line) 0))))) 155 (let loop ((todo l) (done '()) (changed? #f)) 156 (if (null? todo) 157 (if changed? 158 (drop! xyz->index vec done) 159 done) 160 (let* ((num (caar todo)) 161 (line (cdar todo)) 162 (new-line (lower-line (cdar todo))) 163 (change? (valid? new-line))) 164 (assert (all-are? line num)) 165 (when change? 166 (update! line num 0) 167 (update! new-line 0 num)) 168 (loop (cdr todo) 169 (cons (if change? (cons num new-line) (car todo)) done) 170 (or change? changed?))))))) 171 172 (define (unique! l) 173 (let ((sorted (sort! l >))) 174 (let loop ((todo (cdr sorted)) (acc (list (car sorted)))) 175 (if (null? todo) 176 acc 177 (loop (cdr todo) 178 (if (= (car todo) (car acc)) 179 acc 180 (cons (car todo) acc))))))) 181 182 (define (dep-graph xyz->index vec l) 183 (let loop ((todo l) (acc '())) 184 (if (null? todo) 185 acc 186 (loop (cdr todo) 187 (cons (if (or (= 1 (caddr (cdar todo))) 188 (= 1 (cadddr (cdddar todo)))) 189 `(,(caar todo) 0) 190 (cons (caar todo) (unique! 191 (fold-xyz 192 (lambda (l x y z) 193 (let ((v (vector-ref vec (xyz->index x y z)))) 194 (if (> v 0) (cons v l) l))) 195 '() 196 (flatten-line (lower-line (cdar todo))))))) 197 acc))))) 198 199 (define (answer-1 numberless-l) 200 (let* ((l (let loop ((todo numberless-l) (num 1) (acc '())) 201 (if (null? todo) acc 202 (loop (cdr todo) 203 (add1 num) 204 (cons (cons num (car todo)) acc))))) 205 (rich-vec (data->vec l)) 206 (xyz->index (car rich-vec)) 207 (vec (cadr rich-vec)) 208 (dropped (drop! xyz->index vec l)) 209 (deps (dep-graph xyz->index vec dropped)) 210 (rdeps (make-vector (add1 (length l)) '()))) 211 (let loop ((todo deps) (result (vector-length rdeps))) 212 (cond ((null? todo) result) 213 ((= 2 (length (car todo))) 214 (let ((prev (vector-ref rdeps (cadar todo)))) 215 (vector-set! rdeps (cadar todo) (cons (caar todo) prev)) 216 (loop (cdr todo) 217 (if (null? prev) (sub1 result) result)))) 218 (else (loop (cdr todo) result)))))) 219 220 (write-line (conc "First puzzle: " (answer-1 data))) 221 222 ;;;;;;;;;;;;;;;;; 223 ;; Second Puzzle 224 225 (define (answer-2 numberless-l) 226 (let* ((l (let loop ((todo numberless-l) (num 1) (acc '())) 227 (if (null? todo) acc 228 (loop (cdr todo) 229 (add1 num) 230 (cons (cons num (car todo)) acc))))) 231 (rich-vec (data->vec l)) 232 (xyz->index (car rich-vec)) 233 (vec (cadr rich-vec)) 234 (dropped (drop! xyz->index vec l)) 235 (deps (dep-graph xyz->index vec dropped)) 236 (dep-vec (make-vector (add1 (length l)) '())) 237 (rdeps (let loop ((num -1) 238 (d '()) 239 (todo deps) 240 (result (make-vector (add1 (length l)) '()))) 241 (if (null? d) 242 (if (null? todo) 243 result 244 (begin 245 (vector-set! dep-vec (caar todo) (cdar todo)) 246 (loop (caar todo) 247 (cdar todo) 248 (cdr todo) 249 result))) 250 (let ((prev (vector-ref result (car d)))) 251 (vector-set! result (car d) (cons num prev)) 252 (loop num (cdr d) todo result))))) 253 (marks (make-vector (add1 (length l)) #f)) 254 (unmark! (lambda (ll) (let loop ((l ll)) 255 (unless (null? l) 256 (vector-set! marks (car l) #f) 257 (loop (cdr l)))))) 258 (any-unmarked? (lambda (ll) (let loop ((l ll)) 259 (if (null? l) #f 260 (or (not (vector-ref marks (car l))) 261 (loop (cdr l)))))))) 262 (let loop ((next-num 1) 263 (todo '()) 264 (marked '()) 265 (result 0)) 266 (cond ((null? todo) 267 (if (>= next-num (vector-length rdeps)) 268 result 269 (begin 270 (unmark! marked) 271 (vector-set! marks next-num #t) 272 (loop (add1 next-num) 273 (vector-ref rdeps next-num) 274 `(,next-num) 275 result)))) 276 ((vector-ref marks (car todo)) 277 (loop next-num (cdr todo) marked result)) 278 ((any-unmarked? (vector-ref dep-vec (car todo))) 279 (loop next-num (cdr todo) (cons (car todo) marked) result)) 280 (else 281 (vector-set! marks (car todo) #t) 282 (loop next-num 283 (append (vector-ref rdeps (car todo)) 284 (cdr todo)) 285 (cons (car todo) marked) 286 (add1 result))))))) 287 288 (write-line (conc "Second puzzle: " (answer-2 data)))