day14.scm (5839B)
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 srfi-69) 20 21 ;;;;;;;;;;;;;;;;; 22 ;; Input parsing 23 24 (define symbol 25 (in #\. #\# #\O)) 26 27 (define line 28 (sequence* ((symbols (zero-or-more symbol)) 29 (_ (is #\newline))) 30 (result symbols))) 31 32 (define all-data 33 (zero-or-more line)) 34 35 (define data (parse all-data (read-string))) 36 37 (define (draw-area prefix m) 38 (unless (null? m) 39 (write-line (conc prefix (list->string (car m)))) 40 (draw-area prefix (cdr m)))) 41 42 ;(write-line "Input:") 43 ;(draw-area " " data) 44 45 ;;;;;;;;;;;;;;;;; 46 ;; First Puzzle 47 48 (define width (length (car data))) 49 (define height (length data)) 50 (define (index-xy x y) (+ x (* width y))) 51 (define (get-xy vec x y) (vector-ref vec (index-xy x y))) 52 (define (set-xy! vec x y v) (vector-set! vec (index-xy x y) v)) 53 54 (define data-vec 55 (let ((result (make-vector (* width height)))) 56 (let loop ((x 0) (y 0) (line (car data)) (rest (cdr data))) 57 (if (null? line) 58 (if (null? rest) 59 result 60 (loop 0 (add1 y) (car rest) (cdr rest))) 61 (begin 62 (set-xy! result x y (car line)) 63 (loop (add1 x) y (cdr line) rest)))))) 64 65 (define (iter-vec proc) 66 (let loop ((x 0) (y 0)) 67 (cond ((>= y height) proc) 68 ((>= x width) (loop 0 (add1 y))) 69 (else (proc x y) 70 (loop (add1 x) y))))) 71 72 (define (bump-north! vec x y) 73 (when (and (> y 0) 74 (eqv? (get-xy vec x y) #\O) 75 (eqv? (get-xy vec x (sub1 y)) #\.)) 76 (set-xy! vec x y #\.) 77 (set-xy! vec x (sub1 y) #\O) 78 (bump-north! vec x (sub1 y)))) 79 80 (define (tilt-north! vec) 81 (iter-vec (lambda (x y) (bump-north! vec x y))) 82 vec) 83 84 (define (answer-1 vec) 85 (let ((acc 0)) 86 (iter-vec 87 (lambda (x y) 88 (when (eqv? (get-xy vec x y) #\O) 89 (set! acc (+ acc (- height y)))))) 90 acc)) 91 92 (tilt-north! data-vec) 93 94 (write-line (conc "First puzzle: " (answer-1 data-vec))) 95 96 ;;;;;;;;;;;;;;;;; 97 ;; Second Puzzle 98 99 (define (bump! vec x y dx dy) 100 (let ((tx (+ x dx)) (ty (+ y dy))) 101 (when (and (< -1 ty height) 102 (< -1 tx width) 103 (eqv? (get-xy vec x y) #\O) 104 (eqv? (get-xy vec tx ty) #\.)) 105 (set-xy! vec x y #\.) 106 (set-xy! vec tx ty #\O) 107 (bump! vec tx ty dx dy)))) 108 109 (define (rev-iter-vec proc) 110 (let loop ((x (- width 1)) (y (- height 1))) 111 (cond ((< y 0) proc) 112 ((< x 0) (loop (- width 1) (sub1 y))) 113 (else (proc x y) 114 (loop (sub1 x) y))))) 115 116 (define (tilt! vec dx dy) 117 (if (or (> dx 0) (> dy 0)) 118 (rev-iter-vec (lambda (x y) (bump! vec x y dx dy))) 119 (iter-vec (lambda (x y) (bump! vec x y dx dy))))) 120 121 (define (finish-cycle! vec) 122 (tilt! vec -1 0) 123 (tilt! vec 0 1) 124 (tilt! vec 1 0)) 125 126 (define (cycle! vec) 127 (tilt! vec 0 -1) 128 (finish-cycle! vec)) 129 130 (finish-cycle! data-vec) 131 132 (define (draw-area-vec vec) 133 (let outer-loop ((index 0)) 134 (unless (>= index (* width height)) 135 (let inner-loop ((x (- width 1)) (acc '())) 136 (if (< x 0) 137 (write-line (list->string acc)) 138 (inner-loop (sub1 x) (cons (vector-ref vec (+ index x)) acc)))) 139 (outer-loop (+ index width))))) 140 141 ;(draw-area-vec data-vec) 142 ;(write-line "---") 143 ;(tilt! data-vec -1 0) 144 ;(draw-area-vec data-vec) 145 ;(write-line "---") 146 ;(tilt! data-vec 0 1) 147 ;(draw-area-vec data-vec) 148 149 (define (save!-and-equal? source target) 150 (let loop ((index (- (* width height) 1)) (result #t)) 151 (if (< index 0) 152 result 153 (let* ((val (vector-ref source index)) 154 (next-result (and result (eqv? (vector-ref target index) val)))) 155 (vector-set! target index val) 156 (loop (sub1 index) next-result))))) 157 158 (define (vector-sig vec) 159 (let loop ((index 0) (acc 0)) 160 (if (>= index (vector-length vec)) 161 acc 162 (loop (add1 index) 163 (+ (case (vector-ref vec index) 164 ((#\.) 0) 165 ((#\#) 1) 166 ((#\O) 2) 167 (else (assert #f))) 168 (* 3 acc)))))) 169 170 (define memo (make-hash-table)) 171 (define memo-period 0) 172 (define memo-length 0) 173 174 (define start-sig (vector-sig data-vec)) 175 176 (let fill-memo ((n 1) (sig start-sig)) 177 (if (hash-table-exists? memo sig) 178 (begin 179 (set! memo-length n) 180 (set! memo-period (- n (cadr (hash-table-ref memo sig)))) 181 (write-line (conc "Memo table filled in " n " cycles, " 182 " period " memo-period))) 183 (begin 184 (cycle! data-vec) 185 (let ((new-sig (vector-sig data-vec))) 186 (hash-table-set! memo sig (list new-sig n (answer-1 data-vec))) 187 (fill-memo (add1 n) new-sig))))) 188 189 (define (answer-2 sig n) 190 (cond ((> n (+ memo-period memo-length)) 191 (answer-2 sig 192 (+ memo-length 193 (remainder (- n memo-length) memo-period)))) 194 ((= n 1) (caddr (hash-table-ref memo sig))) 195 (else (answer-2 (car (hash-table-ref memo sig)) (sub1 n))))) 196 197 (write-line (conc "Second puzzle: " (answer-2 start-sig (- 1000000000 1))))