day11.scm (3731B)
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 #\. #\#)) 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 (find-xy m c) 48 (let loop ((y 0) (lines (cdr m)) (x 0) (chars (car m)) (acc '())) 49 (if (null? chars) 50 (if (null? lines) 51 acc 52 (loop (add1 y) (cdr lines) 0 (car lines) acc)) 53 (loop y lines (add1 x) (cdr chars) 54 (if (eqv? (car chars) c) (cons (cons x y) acc) acc))))) 55 56 (define (count-xy xy-list) 57 (let loop ((result (cons (make-vector (add1 (apply max (map car xy-list))) 0) 58 (make-vector (add1 (apply max (map cdr xy-list))) 0))) 59 (todo xy-list)) 60 (if (null? todo) 61 result 62 (begin 63 (vector-set! (car result) (caar todo) 64 (add1 (vector-ref (car result) (caar todo)))) 65 (vector-set! (cdr result) (cdar todo) 66 (add1 (vector-ref (cdr result) (cdar todo)))) 67 (loop result (cdr todo)))))) 68 69 (define (counts->expand-vec counts age) 70 (let ((result (make-vector (vector-length counts)))) 71 (let loop ((old-x 0) (delta-x 0)) 72 (unless (>= old-x (vector-length result)) 73 (vector-set! result old-x (+ old-x (* age delta-x))) 74 (loop (add1 old-x) 75 (if (= (vector-ref counts old-x) 0) 76 (add1 delta-x) 77 delta-x)))) 78 result)) 79 80 (define (expand-xy xy-list age) 81 (let* ((counts (count-xy xy-list)) 82 (expand-x (counts->expand-vec (car counts) age)) 83 (expand-y (counts->expand-vec (cdr counts) age))) 84 (map (lambda (xy) (cons (vector-ref expand-x (car xy)) 85 (vector-ref expand-y (cdr xy)))) 86 xy-list))) 87 88 (define (dist xy1 xy2) 89 (+ (abs (- (car xy1) (car xy2))) (abs (- (cdr xy1) (cdr xy2))))) 90 91 (define (dist-sum xy-list acc) 92 (if (null? xy-list) 93 acc 94 (let loop ((cur (car xy-list)) 95 (todo (cdr xy-list)) 96 (inner-acc acc)) 97 (if (null? todo) 98 (dist-sum (cdr xy-list) inner-acc) 99 (loop cur (cdr todo) (+ inner-acc (dist cur (car todo)))))))) 100 101 (define orig-xy (find-xy data #\#)) 102 103 (write-line (conc "First puzzle: " (dist-sum (expand-xy orig-xy 1) 0))) 104 105 ;;;;;;;;;;;;;;;;; 106 ;; Second Puzzle 107 108 (write-line (conc "Second puzzle: ")) 109 (write-line (conc " 10: " (dist-sum (expand-xy orig-xy 9) 0))) 110 (write-line (conc " 100: " (dist-sum (expand-xy orig-xy 99) 0))) 111 (write-line (conc " 1000000: " (dist-sum (expand-xy orig-xy 999999) 0)))