day18.scm (10829B)
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 srfi-1 18 srfi-14) 19 20 (define verbose #f) 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 spaces 31 (one-or-more (is #\space))) 32 33 (define digit 34 (in char-set:digit)) 35 36 (define hex-digit 37 (in #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\a #\b #\c #\d #\e #\f)) 38 39 (define digits 40 (as-number (one-or-more digit))) 41 42 (define line 43 (sequence* ((dir (in #\L #\R #\U #\D)) 44 (_ spaces) 45 (steps digits) 46 (_ spaces) 47 (_ (char-seq "(#")) 48 (color (as-string (repeated hex-digit 6))) 49 (_ (char-seq ")\n"))) 50 (result (list dir steps color)))) 51 52 (define all-data 53 (one-or-more line)) 54 55 (define data (parse all-data (read-string))) 56 (when verbose (write-line (conc "Input: " data))) 57 58 ;;;;;;;;;;;;;;;;; 59 ;; First Puzzle 60 61 (define (move-xy xy dir) 62 (let ((x (car xy)) 63 (y (cdr xy))) 64 (case dir 65 ((#\L) (cons (sub1 x) y)) 66 ((#\R) (cons (add1 x) y)) 67 ((#\U) (cons x (sub1 y))) 68 ((#\D) (cons x (add1 y))) 69 (else (assert #f "Unknown direction " dir))))) 70 71 (define (move->xy-list dir steps acc) 72 (if (= 0 steps) 73 acc 74 (move->xy-list dir (sub1 steps) (cons (move-xy (car acc) dir) acc)))) 75 76 (define (moves->xy-list move-list acc) 77 (if (null? move-list) 78 acc 79 (moves->xy-list (cdr move-list) 80 (move->xy-list (caar move-list) (cadar move-list) acc)))) 81 82 (define (bounding-box xy-list) 83 (let loop ((min-x (caar xy-list)) 84 (min-y (cdar xy-list)) 85 (max-x (caar xy-list)) 86 (max-y (cdar xy-list)) 87 (todo (cdr xy-list))) 88 (if (null? todo) 89 (list min-x min-y max-x max-y) 90 (loop (min min-x (caar todo)) 91 (min min-y (cdar todo)) 92 (max max-x (caar todo)) 93 (max max-y (cdar todo)) 94 (cdr todo))))) 95 96 (define (char-for prev cur next) 97 (let ((right (or (= (add1 (car prev)) (car cur)) 98 (= (add1 (car next)) (car cur)))) 99 (left (or (= (sub1 (car prev)) (car cur)) 100 (= (sub1 (car next)) (car cur)))) 101 (down (or (= (add1 (cdr prev)) (cdr cur)) 102 (= (add1 (cdr next)) (cdr cur)))) 103 (up (or (= (sub1 (cdr prev)) (cdr cur)) 104 (= (sub1 (cdr next)) (cdr cur))))) 105 (cond ((and right left) #\-) 106 ((and right down) #\F) 107 ((and right up) #\L) 108 ((and left down) #\7) 109 ((and left up) #\J) 110 ((and down up) #\|) 111 (else (assert #f "Invalid combination " right left down up))))) 112 113 (define (xy-list->vec xy-list box) 114 (let* ((min-x (car box)) 115 (min-y (cadr box)) 116 (width (- (caddr box) min-x -1)) 117 (height (- (cadddr box) min-y -1)) 118 (result (make-vector (* width height) #\.))) 119 (assert (equal? (car xy-list) (last xy-list))) 120 (let loop ((todo (cdr xy-list)) (prev (car xy-list))) 121 (unless (null? todo) 122 (vector-set! result 123 (+ (- (caar todo) min-x) (* (- (cdar todo) min-y) width)) 124 (char-for prev 125 (car todo) 126 (if (null? (cdr todo)) 127 (cadr xy-list) (cadr todo)))) 128 (loop (cdr todo) (car todo)))) 129 result)) 130 131 (define (draw-vec xy-vec box) 132 (let* ((min-x (car box)) 133 (min-y (cadr box)) 134 (width (- (caddr box) min-x -1)) 135 (height (- (cadddr box) min-y -1))) 136 (let yloop ((y 0)) 137 (when (< y height) 138 (write-line (apply conc (let xloop ((x (sub1 width)) (acc '())) 139 (if (< x 0) 140 acc 141 (xloop (sub1 x) 142 (cons (vector-ref xy-vec (+ x (* y width))) acc)))))) 143 (yloop (add1 y)))))) 144 145 (define (answer-1 move-list) 146 (let* ((border-xy (moves->xy-list move-list '((0 . 0)))) 147 (border-length (sub1 (length border-xy))) 148 (data-box (bounding-box border-xy)) 149 (data-vec (xy-list->vec border-xy data-box)) 150 (min-x (car data-box)) 151 (min-y (cadr data-box)) 152 (max-x (caddr data-box)) 153 (max-y (cadddr data-box)) 154 (width (- (caddr data-box) min-x -1)) 155 (height (- (cadddr data-box) min-y -1)) 156 (xy-index (lambda (x y) (+ (- x min-x) (* (- y min-y) width))))) 157 (assert (equal? (car border-xy) '(0 . 0))) 158 ;(draw-vec (xy-list->vec border-xy data-box) data-box) 159 (let loop ((x min-x) (y min-y) 160 (up-before 0) (down-before 0) 161 (result 0)) 162 (cond ((> y max-y) ;(draw-vec data-vec data-box) 163 (+ border-length result)) 164 ((> x max-x) (loop min-x (add1 y) 0 0 result)) 165 (else (let ((char (vector-ref data-vec (xy-index x y)))) 166 (assert (or (not (eqv? char #\.)) 167 (= (remainder up-before 2) 168 (remainder down-before 2)))) 169 (loop (add1 x) y 170 (case char ((#\| #\J #\L) (add1 up-before)) 171 (else up-before)) 172 (case char ((#\| #\7 #\F) (add1 down-before)) 173 (else down-before)) 174 (if (and (eqv? char #\.) 175 (= 1 (remainder up-before 2))) 176 (begin (vector-set! data-vec (xy-index x y) #\:) 177 (add1 result) 178 ) 179 result)))))))) 180 181 (write-line (conc "First puzzle: " (answer-1 data))) 182 183 ;;;;;;;;;;;;;;;;; 184 ;; Second Puzzle 185 186 (define (move-xyl xy dir steps) 187 (let ((x (car xy)) 188 (y (cdr xy))) 189 (case dir 190 ((#\L) (cons (- x steps) y)) 191 ((#\R) (cons (+ x steps) y)) 192 ((#\U) (cons x (- y steps))) 193 ((#\D) (cons x (+ y steps))) 194 (else (assert #f "Unknown direction " dir))))) 195 196 (define (vert-edges moves xy acc) 197 (if (null? moves) 198 acc 199 (let ((next-xy (move-xyl xy (caar moves) (cadar moves)))) 200 (vert-edges (cdr moves) 201 next-xy 202 (if (= (car xy) (car next-xy)) 203 (cons (list (car xy) (cdr xy) (cdr next-xy)) acc) 204 acc))))) 205 206 (define (uniq l) 207 (let loop ((todo (cdr l)) (acc (list (car l)))) 208 (if (null? todo) 209 acc 210 (loop (cdr todo) 211 (if (= (car todo) (car acc)) 212 acc 213 (cons (car todo) acc)))))) 214 215 (define (vert-edge-y edges) 216 (uniq (sort (apply append (map cdr edges)) >))) 217 218 (define (recursive-< a b) 219 (if (null? a) 220 (not (null? b)) 221 (and (not (null? b)) 222 (or (< (car a) (car b)) 223 (and (= (car a) (car b)) 224 (recursive-< (cdr a) (cdr b))))))) 225 226 (define (width-at edges y) 227 (let loop ((todo edges) (state 'out) (prev-x 0) (acc 0)) 228 (if (null? todo) 229 (begin 230 (assert (eqv? state 'out) "Inconsistent final state " state) 231 acc) 232 (let ((min-y (apply min (cdar todo))) 233 (max-y (apply max (cdar todo))) 234 (cur-x (caar todo)) 235 (rest (cdr todo))) 236 (cond ((or (< y min-y) (> y max-y)) 237 (loop rest state prev-x acc)) 238 ((and (< min-y y max-y) (eqv? state 'out)) 239 (loop rest 'in cur-x (add1 acc))) 240 ((and (< min-y y max-y) (eqv? state 'in)) 241 (loop rest 'out 0 (+ (- cur-x prev-x) acc))) 242 ((= y min-y) 243 (loop rest 244 (cond ((eqv? state 'out) 'edge-out-down) 245 ((eqv? state 'in) 'edge-in-down) 246 ((eqv? state 'edge-out-down) 'out) 247 ((eqv? state 'edge-in-down) 'in) 248 ((eqv? state 'edge-out-up) 'in) 249 ((eqv? state 'edge-in-up) 'out) 250 (else (assert #f))) 251 cur-x 252 (if (eqv? state 'out) 253 (add1 acc) 254 (+ (- cur-x prev-x) acc)))) 255 ((= y max-y) 256 (loop rest 257 (cond ((eqv? state 'out) 'edge-out-up) 258 ((eqv? state 'in) 'edge-in-up) 259 ((eqv? state 'edge-out-down) 'in) 260 ((eqv? state 'edge-in-down) 'out) 261 ((eqv? state 'edge-out-up) 'out) 262 ((eqv? state 'edge-in-up) 'in) 263 (else (assert #f))) 264 cur-x 265 (if (eqv? state 'out) 266 (add1 acc) 267 (+ (- cur-x prev-x) acc)))) 268 (else (assert #f (list state prev-x cur-x min-y max-y)))))))) 269 270 (define (answer-1* data) 271 (let* ((edges (sort (vert-edges data '(0 . 0) '()) recursive-<)) 272 (y-list (vert-edge-y edges))) 273 (let loop ((y (car y-list)) (todo (cdr y-list)) (acc 0)) 274 (if (null? todo) 275 (+ acc (width-at edges y)) 276 (loop (car todo) 277 (cdr todo) 278 (+ acc 279 (width-at edges y) 280 (if (< (add1 y) (car todo)) 281 (* (- (car todo) y 1) 282 (width-at edges (add1 y))) 283 0))))))) 284 285 (define (convert-2 line) 286 (let* ((n (string->number (caddr line) 16)) 287 (steps (quotient n 16)) 288 (numdir (remainder n 16))) 289 (list (case numdir ((0) #\R) ((1) #\D) ((2) #\L) ((3) #\U) 290 (else (assert #f "Bad numdir " numdir))) 291 steps))) 292 293 (define (answer-2 lines) 294 (answer-1* (map convert-2 lines))) 295 296 (write-line (conc "Second puzzle: " (answer-2 data)))