day10.scm (6862B)
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 20 ;;;;;;;;;;;;;;;;; 21 ;; Input parsing 22 23 (define symbol 24 (in #\| #\- #\L #\J #\7 #\F #\. #\S)) 25 26 (define line 27 (sequence* ((data (zero-or-more symbol)) 28 (_ (is #\newline))) 29 (result data))) 30 31 (define all-data 32 (zero-or-more line)) 33 34 (define data (parse all-data (read-string))) 35 36 (define (draw-map prefix m) 37 (unless (null? m) 38 (write-line (conc prefix (list->string (car m)))) 39 (draw-map prefix (cdr m)))) 40 41 ;(write-line "Input:") 42 ;(draw-map " " data) 43 44 ;;;;;;;;;;;;;;;;; 45 ;; First Puzzle 46 47 (define (up xy) (cons (car xy) (sub1 (cdr xy)))) 48 (define (down xy) (cons (car xy) (add1 (cdr xy)))) 49 (define (left xy) (cons (sub1 (car xy)) (cdr xy))) 50 (define (right xy) (cons (add1 (car xy)) (cdr xy))) 51 52 (define (valid? m xy) 53 (and (< -1 (car xy) (length (car m))) 54 (< -1 (cdr xy) (length m)))) 55 56 (define start-xy 57 (let y-loop ((y 0) (lines data)) 58 (if (null? lines) 59 (cons -1 -1) 60 (let x-loop ((x 0) (line (car lines))) 61 (cond ((null? line) (y-loop (add1 y) (cdr lines))) 62 ((eqv? #\S (car line)) (cons x y)) 63 (else (x-loop (add1 x) (cdr line)))))))) 64 65 (define (read-cell m xy) 66 (assert (valid? m xy)) 67 (list-ref (list-ref m (cdr xy)) (car xy))) 68 69 (define (neighbors m xy) 70 (case (read-cell m xy) 71 ((#\|) (list (up xy) (down xy))) 72 ((#\-) (list (left xy) (right xy))) 73 ((#\L) (list (up xy) (right xy))) 74 ((#\J) (list (up xy) (left xy))) 75 ((#\7) (list (down xy) (left xy))) 76 ((#\F) (list (down xy) (right xy))) 77 ((#\.) '()) 78 ((#\S) '()) 79 (else (assert #f "Invalid cell data at " xy)))) 80 81 (define (connected? m xy1 xy2) 82 (any (lambda (xy) (equal? xy xy2)) (neighbors m xy1))) 83 84 (define data-width (length (car data))) 85 (define start-tile 0) 86 (define dist-from-start 87 (let* ((result (make-vector (* data-width (length data)) -1)) 88 (get-index (lambda (xy) (+ (car xy) (* (cdr xy) data-width)))) 89 (get-dist (lambda (xy) (vector-ref result (get-index xy)))) 90 (set-dist! (lambda (xy d) (assert (= (get-dist xy) -1)) 91 (vector-set! result (get-index xy) d))) 92 (start-neighbors (filter (lambda (xy) (and (valid? data xy) 93 (connected? data xy start-xy))) 94 (list (up start-xy) (down start-xy) 95 (left start-xy) (right start-xy))))) 96 (set-dist! start-xy 0) 97 (assert (= 2 (length start-neighbors))) 98 (set! start-tile 99 (cond ((= (caar start-neighbors) (caadr start-neighbors)) #\|) 100 ((= (cdar start-neighbors) (cdadr start-neighbors)) #\-) 101 ((and (or (= (caar start-neighbors) (sub1 (car start-xy))) 102 (= (caadr start-neighbors) (sub1 (car start-xy)))) 103 (or (= (cdar start-neighbors) (sub1 (cdr start-xy))) 104 (= (cdadr start-neighbors) (sub1 (cdr start-xy))))) #\J) 105 ((and (or (= (caar start-neighbors) (sub1 (car start-xy))) 106 (= (caadr start-neighbors) (sub1 (car start-xy)))) 107 (or (= (cdar start-neighbors) (add1 (cdr start-xy))) 108 (= (cdadr start-neighbors) (add1 (cdr start-xy))))) #\7) 109 ((and (or (= (caar start-neighbors) (add1 (car start-xy))) 110 (= (caadr start-neighbors) (add1 (car start-xy)))) 111 (or (= (cdar start-neighbors) (sub1 (cdr start-xy))) 112 (= (cdadr start-neighbors) (sub1 (cdr start-xy))))) #\L) 113 ((and (or (= (caar start-neighbors) (add1 (car start-xy))) 114 (= (caadr start-neighbors) (add1 (car start-xy)))) 115 (or (= (cdar start-neighbors) (add1 (cdr start-xy))) 116 (= (cdadr start-neighbors) (add1 (cdr start-xy))))) #\F) 117 (else (assert #f)))) 118 (let loop ((todo start-neighbors) 119 (steps 1)) 120 (if (apply equal? todo) 121 (begin 122 (set-dist! (car todo) steps) 123 (write-line (conc "First puzzle: " steps))) 124 (begin 125 ; (write-line (conc "Step " steps ": " todo)) 126 (for-each (lambda (xy) 127 (set-dist! xy steps)) 128 todo) 129 (loop (filter (lambda (xy) (= (get-dist xy) -1)) 130 (apply append (map (lambda (xy) (neighbors data xy)) 131 todo))) 132 (add1 steps))))) 133 result)) 134 135 (write-line (conc "Start tile: " start-tile)) 136 137 ;;;;;;;;;;;;;;;;; 138 ;; Second Puzzle 139 140 (define data-height (length data)) 141 142 (define (vec-ref-xy* vec x y) 143 (vector-ref vec (+ x (* y data-width)))) 144 145 (define (vec-ref-xy vec x y) 146 (let ((result (vec-ref-xy* vec x y))) 147 ; (write-line (conc "vec-ref-xy " x " " y " -> " result)) 148 result)) 149 150 (define (tile-at x y) 151 (if (equal? start-xy (cons x y)) 152 start-tile 153 (read-cell data (cons x y)))) 154 155 (define answer-2 156 (let loop ((x 0) (y 0) (up-before 0) (down-before 0) (acc 0)) 157 (cond ((>= y data-height) acc) 158 ((>= x data-width) (loop 0 (add1 y) 0 0 acc)) 159 ((>= (vec-ref-xy dist-from-start x y) 0) 160 (case (tile-at x y) 161 ((#\|) 162 (loop (add1 x) y (add1 up-before) (add1 down-before) acc)) 163 ((#\-) 164 (loop (add1 x) y up-before down-before acc)) 165 ((#\L #\J) 166 (loop (add1 x) y (add1 up-before) down-before acc)) 167 ((#\F #\7) 168 (loop (add1 x) y up-before (add1 down-before) acc)) 169 (else (assert #f)))) 170 ((= 1 (remainder up-before 2) (remainder down-before 2)) 171 (loop (add1 x) y up-before down-before (add1 acc))) 172 ((= 0 (remainder up-before 2) (remainder down-before 2)) 173 (loop (add1 x) y up-before down-before acc)) 174 (else (assert #f))))) 175 176 (write-line (conc "Second puzzle: " answer-2))