day23.scm (6229B)
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 trace 17 srfi-1 18 srfi-69) 19 20 (define data-list (string-split (read-string))) 21 22 (define data-height (length data-list)) 23 (define data-width (string-length (car data-list))) 24 25 (define verbose (< data-height 25)) 26 27 (for-each 28 (lambda (line) (assert (= (string-length line) data-width))) 29 data-list) 30 31 (define data-vec 32 (list->vector 33 (apply append (map string->list data-list)))) 34 (assert (= (vector-length data-vec) (* data-width data-height))) 35 36 (define (xy->index xy) 37 (assert (and (< -1 (car xy) data-width) (< -1 (cdr xy) data-height)) 38 "Invalid xy " xy) 39 (+ (* data-width (cdr xy)) (car xy))) 40 41 (define (get-xy xy) 42 (vector-ref data-vec (xy->index xy))) 43 44 (define start-index 45 (let loop ((index 0)) 46 (if (eqv? (vector-ref data-vec index) #\.) 47 index 48 (loop (add1 index))))) 49 50 (define end-index 51 (let loop ((index (sub1 (vector-length data-vec)))) 52 (if (eqv? (vector-ref data-vec index) #\.) 53 index 54 (loop (sub1 index))))) 55 56 (define start-xy 57 (cons (remainder start-index data-width) (quotient start-index data-width))) 58 59 (define end-xy 60 (cons (remainder end-index data-width) (quotient end-index data-width))) 61 62 ;;;;;;;;;;;;;;;;; 63 ;; First Puzzle 64 65 (define (right xy) (cons (add1 (car xy)) (cdr xy))) 66 (define (left xy) (cons (sub1 (car xy)) (cdr xy))) 67 (define (down xy) (cons (car xy) (add1 (cdr xy)))) 68 (define (up xy) (cons (car xy) (sub1 (cdr xy)))) 69 70 (define (inverse dir) 71 (cond ((eqv? dir right) left) 72 ((eqv? dir left) right) 73 ((eqv? dir down) up) 74 ((eqv? dir up) down) 75 (else (assert #f "Invalid direction " dir)))) 76 77 (define (get-xy* xy) 78 (if (and (< -1 (car xy) data-width) 79 (< -1 (cdr xy) data-height)) 80 (get-xy xy) 81 #\#)) 82 83 (define (move-allowed? xy dir) 84 (case (get-xy* (dir xy)) 85 ((#\.) #t) 86 ((#\#) #f) 87 ((#\<) (eqv? dir left)) 88 ((#\>) (eqv? dir right)) 89 ((#\^) (eqv? dir up)) 90 ((#\v) (eqv? dir down)) 91 (else (assser #f "Unknown character " (get-xy (dir xy)) dir xy)))) 92 93 (define (next-dirs-1 xy not-dir) 94 (filter 95 (lambda (dir) (and (not (equal? dir not-dir)) 96 (move-allowed? xy dir))) 97 (list right left up down))) 98 99 (define (follow next-dirs xy dir) 100 (assert (not (eqv? (get-xy xy) #\#))) 101 (let loop ((cur-dir dir) 102 (cur-xy (dir xy)) 103 (steps 1)) 104 (let ((dirs (next-dirs cur-xy (inverse cur-dir)))) 105 (if (= 1 (length dirs)) 106 (loop (car dirs) ((car dirs) cur-xy) (add1 steps)) 107 (list steps cur-xy dirs))))) 108 109 (define (data-edge-list next-dirs) 110 (let loop ((todo `(,start-xy)) 111 (visited (make-vector (vector-length data-vec) #f)) 112 (acc '())) 113 (cond ((null? todo) acc) 114 ((vector-ref visited (xy->index (car todo))) 115 (loop (cdr todo) visited acc)) 116 (else 117 (let ((next (filter (lambda (l) (not (null? l))) 118 (map (lambda (dir) (follow next-dirs (car todo) dir)) 119 (next-dirs (car todo) #f))))) 120 (vector-set! visited (xy->index (car todo)) #t) 121 (loop (append (map cadr next) (cdr todo)) 122 visited 123 (append (map (lambda (l) (cons (car todo) l)) next) 124 acc))))))) 125 126 ;(for-each 127 ; (lambda (l) (write-line (conc l))) 128 ; data-edge-list) 129 130 (define (max-path-length edge-list) 131 (let loop ((todo `((,start-xy 0))) 132 (result 0)) 133 (cond ((null? todo) result) 134 ((equal? (caar todo) end-xy) 135 (loop (cdr todo) (max (cadar todo) result))) 136 (else (loop (append (map (lambda (l) (list (caddr l) 137 (+ (cadr l) (cadar todo)))) 138 (filter (lambda (l) (equal? (car l) (caar todo))) 139 edge-list)) 140 (cdr todo)) 141 result))))) 142 143 ;(for-each 144 ; (lambda (l) (write-line (conc l))) 145 ; all-path-lengths) 146 147 (write-line (conc "First puzzle: " 148 (max-path-length (data-edge-list next-dirs-1)))) 149 150 ;;;;;;;;;;;;;;;;; 151 ;; Second Puzzle 152 153 (define (contains? l v) 154 (cond ((null? l) #f) 155 ((equal? (car l) v) #t) 156 (else (contains? (cdr l) v)))) 157 158 (define (extend edge-list line) 159 (let ((pos (cadr line)) 160 (steps (car line)) 161 (visited (cdr line))) 162 (map (lambda (l) (cons (+ steps (cadr l)) 163 (cons (caddr l) visited))) 164 (filter (lambda (l) (and (equal? (car l) pos) 165 (not (contains? visited (caddr l))))) 166 edge-list)))) 167 168 (define (next-dirs-2 xy not-dir) 169 (filter 170 (lambda (dir) (and (not (equal? dir not-dir)) 171 (not (eqv? (get-xy* (dir xy)) #\#)))) 172 (list right left up down))) 173 174 (define (max-path-length-2 edge-list) 175 (let loop ((todo `((0 ,start-xy))) 176 (result 0)) 177 (cond ((null? todo) result) 178 ((equal? (cadar todo) end-xy) 179 (loop (cdr todo) (max (caar todo) result))) 180 (else 181 (loop (append (extend edge-list (car todo)) 182 (cdr todo)) 183 result))))) 184 185 (when verbose 186 (for-each 187 (lambda (l) (write-line (conc l))) 188 (data-edge-list next-dirs-2))) 189 190 (write-line (conc "Second puzzle: " 191 (max-path-length-2 (data-edge-list next-dirs-2))))