day16.scm (7757B)
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 17 (define data-list (string-split (read-string))) 18 19 (define data-height (length data-list)) 20 (define data-width (string-length (car data-list))) 21 22 (for-each 23 (lambda (line) (assert (= (string-length line) data-width))) 24 data-list) 25 26 ;;;;;;;;;;;;;;;;; 27 ;; First Puzzle 28 29 (define (next-step x y dir) 30 (cond 31 ((eqv? dir 'right) `(,(add1 x) ,y ,dir)) 32 ((eqv? dir 'left) `(,(sub1 x) ,y ,dir)) 33 ((eqv? dir 'down) `(,x ,(add1 y) ,dir)) 34 ((eqv? dir 'up) `(,x ,(sub1 y) ,dir)) 35 (else (assert #f "Invalid direction " dir)))) 36 37 (define (next-steps x y dirs) 38 (map (lambda (dir) (next-step x y dir)) dirs)) 39 40 (define (process-step x y dir) 41 (case (string-ref (list-ref data-list y) x) 42 ((#\.) (next-steps x y (list dir))) 43 ((#\\) (next-steps x y (cond ((eqv? dir 'right) '(down)) 44 ((eqv? dir 'left) '(up)) 45 ((eqv? dir 'down) '(right)) 46 ((eqv? dir 'up) '(left)) 47 (else (assert #f))))) 48 ((#\/) (next-steps x y (cond ((eqv? dir 'right) '(up)) 49 ((eqv? dir 'left) '(down)) 50 ((eqv? dir 'down) '(left)) 51 ((eqv? dir 'up) '(right)) 52 (else (assert #f))))) 53 ((#\|) (next-steps x y (cond ((eqv? dir 'right) '(up down)) 54 ((eqv? dir 'left) '(up down)) 55 ((eqv? dir 'down) '(down)) 56 ((eqv? dir 'up) '(up)) 57 (else (assert #f))))) 58 ((#\-) (next-steps x y (cond ((eqv? dir 'right) '(right)) 59 ((eqv? dir 'left) '(left)) 60 ((eqv? dir 'down) '(left right)) 61 ((eqv? dir 'up) '(left right)) 62 (else (assert #f))))) 63 (else (assert #f)))) 64 65 (define (dir-index dir) 66 (cond 67 ((eqv? dir 'right) 1) 68 ((eqv? dir 'left) 2) 69 ((eqv? dir 'down) 3) 70 ((eqv? dir 'up) 4) 71 (else (assert #f "Invalid direction " dir)))) 72 73 (define answer-1 74 (let ((visited (make-vector (* data-width data-height 4) #f))) 75 (let loop ((todo '((0 0 right))) (acc 0)) 76 (if (null? todo) 77 acc 78 (let ((x (caar todo)) 79 (y (cadar todo)) 80 (dir (caddar todo)) 81 (rest (cdr todo))) 82 (if (and (< -1 x data-width) 83 (< -1 y data-height)) 84 (let* ((base-index (* 4 (+ (* data-width y) x))) 85 (index (+ base-index (dir-index dir) -1)) 86 (seen (or (vector-ref visited base-index) 87 (vector-ref visited (+ 1 base-index)) 88 (vector-ref visited (+ 2 base-index)) 89 (vector-ref visited (+ 3 base-index))))) 90 (if (vector-ref visited index) 91 (loop rest acc) 92 (begin 93 (vector-set! visited index #t) 94 (loop (append (process-step x y dir) rest) 95 (if seen acc (add1 acc)))))) 96 (loop rest acc))))))) 97 98 (write-line (conc "First puzzle: " answer-1)) 99 100 ;;;;;;;;;;;;;;;;; 101 ;; Second Puzzle 102 103 (define (prev-coord x y dir) 104 (cond 105 ((eqv? dir 'right) `(,(sub1 x) ,y)) 106 ((eqv? dir 'left) `(,(add1 x) ,y)) 107 ((eqv? dir 'down) `(,x ,(sub1 y))) 108 ((eqv? dir 'up) `(,x ,(add1 y))) 109 (else (assert #f "Invalid direction " dir)))) 110 111 (define (runner-2 start) 112 (let ((visited (make-vector (* data-width data-height 4) #f))) 113 (let loop ((todo (list start)) 114 (count 0) 115 (edges (list (apply prev-coord start)))) 116 (if (null? todo) 117 (list count edges) 118 (let ((x (caar todo)) 119 (y (cadar todo)) 120 (dir (caddar todo)) 121 (rest (cdr todo))) 122 (if (and (< -1 x data-width) 123 (< -1 y data-height)) 124 (let* ((base-index (* 4 (+ (* data-width y) x))) 125 (index (+ base-index (dir-index dir) -1)) 126 (seen (or (vector-ref visited base-index) 127 (vector-ref visited (+ 1 base-index)) 128 (vector-ref visited (+ 2 base-index)) 129 (vector-ref visited (+ 3 base-index))))) 130 (if (vector-ref visited index) 131 (loop rest count edges) 132 (begin 133 (vector-set! visited index #t) 134 (loop (append (process-step x y dir) rest) 135 (if seen count (add1 count)) 136 edges)))) 137 (loop rest count (cons (list x y) edges)))))))) 138 139 (define answer-2 140 (let ((visited-top (make-vector data-width #f)) 141 (visited-bottom (make-vector data-width #f)) 142 (visited-left (make-vector data-height #f)) 143 (visited-right (make-vector data-height #f)) 144 (best-score 0)) 145 (let* ((visited-set! (lambda (coord) 146 (cond ((= (cadr coord) data-height) 147 (vector-set! visited-bottom (car coord) #t)) 148 ((= (cadr coord) -1) 149 (vector-set! visited-top (car coord) #t)) 150 ((= (car coord) data-width) 151 (vector-set! visited-right (cadr coord) #t)) 152 ((= (car coord) -1) 153 (vector-set! visited-left (cadr coord) #t)) 154 (else (assert #f "Invalid edge coord " coord))))) 155 (scores-set! (lambda (coords score) 156 (for-each (lambda (coord) (visited-set! coord score)) 157 coords))) 158 (run (lambda (start) 159 (let ((result (runner-2 start))) 160 (when (> (car result) best-score) 161 (set! best-score (car result))) 162 (for-each visited-set! (cadr result)))))) 163 (let xloop ((x (sub1 data-width))) 164 (when (not (vector-ref visited-top x)) 165 (run (list x 0 'down))) 166 (when (not (vector-ref visited-bottom x)) 167 (run (list x (sub1 data-height) 'up))) 168 (when (> x 0) (xloop (sub1 x)))) 169 (let yloop ((y (sub1 data-height))) 170 (when (not (vector-ref visited-left y)) 171 (run (list 0 y 'right))) 172 (when (not (vector-ref visited-right y)) 173 (run (list (sub1 data-width) y 'left))) 174 (when (> y 0) (yloop (sub1 y)))) 175 best-score))) 176 177 (write-line (conc "Second puzzle: " answer-2))