day12.scm (7478B)
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 (as-number parser) 25 (bind (as-string parser) 26 (lambda (s) 27 (result (string->number s))))) 28 29 (define spaces 30 (one-or-more (is #\space))) 31 32 (define digit 33 (in char-set:digit)) 34 35 (define digits 36 (as-number (one-or-more digit))) 37 38 (define number-list 39 (sequence* ((first digits) 40 (rest (zero-or-more (preceded-by (is #\,) digits)))) 41 (result (cons first rest)))) 42 43 (define symbol 44 (in #\. #\# #\?)) 45 46 (define line 47 (sequence* ((symbols (zero-or-more symbol)) 48 (_ spaces) 49 (numbers number-list) 50 (_ (is #\newline))) 51 (result (list symbols numbers)))) 52 53 (define all-data 54 (zero-or-more line)) 55 56 (define data (parse all-data (read-string))) 57 ;(write-line (conc "Input: " data)) 58 59 ;;;;;;;;;;;;;;;;; 60 ;; First Puzzle 61 62 (define (count-broken l) 63 (let loop ((todo l) (acc '(0))) 64 (if (null? todo) 65 (reverse (if (= (car acc) 0) (cdr acc) acc)) 66 (loop (cdr todo) 67 (cond ((eqv? (car todo) #\#) (cons (add1 (car acc)) (cdr acc))) 68 ((= (car acc) 0) acc) 69 (else (cons 0 acc))))))) 70 71 ;(for-each (lambda (line) (write-line (conc (car line) " -> " (count-broken (car line))))) data) 72 73 (define (iterate-internal1 proc reversed-prefix suffix) 74 (cond ((null? reversed-prefix) (proc suffix)) 75 ((eqv? (car reversed-prefix) #\?) 76 (iterate-internal1 proc (cdr reversed-prefix) (cons #\# suffix)) 77 (iterate-internal1 proc (cdr reversed-prefix) (cons #\. suffix))) 78 (else (iterate-internal1 proc (cdr reversed-prefix) 79 (cons (car reversed-prefix) suffix))))) 80 81 (define (count-matches1 l ref) 82 (let ((acc 0)) 83 (iterate-internal1 84 (lambda (result) (if (equal? (count-broken result) ref) 85 (set! acc (add1 acc)))) 86 (reverse l) '()) 87 acc)) 88 89 (define (prefix? small large) 90 (cond ((null? small) #t) 91 ((null? large) #f) 92 ((eqv? (car small) (car large)) (prefix? (cdr small) (cdr large))) 93 (else (and (<= (car small) (car large)) (null? (cdr small)))))) 94 95 (define (count-matches l ref) 96 (let ((acc 0)) 97 (let internal ((rev-prefix '()) 98 (counts '()) 99 (new-streak #t) 100 (todo l)) 101 (cond ((null? todo) 102 (if (equal? (reverse counts) ref) 103 (set! acc (add1 acc)))) 104 ((not (prefix? (reverse counts) ref))) 105 ((eqv? (car todo) #\.) (internal (cons #\. rev-prefix) 106 counts 107 #t 108 (cdr todo))) 109 ((eqv? (car todo) #\#) (internal (cons #\# rev-prefix) 110 (if new-streak 111 (cons 1 counts) 112 (cons (add1 (car counts)) 113 (cdr counts))) 114 #f 115 (cdr todo))) 116 ((eqv? (car todo) #\?) (internal rev-prefix 117 counts 118 new-streak 119 (cons #\. (cdr todo))) 120 (internal rev-prefix 121 counts 122 new-streak 123 (cons #\# (cdr todo)))) 124 (else (assert #f)))) 125 acc)) 126 127 128 ;(for-each (lambda (line) (write-line (conc line " -> " (count-matches (car line) (cadr line))))) data) 129 130 (write-line (conc "First puzzle: " 131 (apply + (map (lambda (line) (count-matches (car line) (cadr line))) data)))) 132 133 ;;;;;;;;;;;;;;;;; 134 ;; Second Puzzle 135 136 (define (pow x y) 137 (let loop ((n y) (acc 1)) 138 (if (= 0 n) acc (loop (sub1 n) (* x acc))))) 139 140 (define (count-spaced-matches memo symbols numbers) 141 (cond ((null? symbols) (if (null? numbers) 1 0)) 142 ((eqv? (car symbols) #\#) 0) 143 (else (count-matches-2 memo (cdr symbols) numbers)))) 144 145 (define (count-anchored-matches memo symbols numbers) 146 (assert (not (null? numbers))) 147 (cond ((null? symbols) 0) 148 ((eqv? (car symbols) #\.) 0) 149 ((= 1 (car numbers)) 150 (count-spaced-matches memo (cdr symbols) (cdr numbers))) 151 (else (count-anchored-matches memo 152 (cdr symbols) 153 (cons (sub1 (car numbers)) 154 (cdr numbers)))))) 155 156 157 (define (count-matches-2 memo symbols numbers) 158 (if (hash-table-exists? memo (cons symbols numbers)) 159 (hash-table-ref memo (cons symbols numbers)) 160 (let ((result 161 (cond ((null? numbers) (cond ((null? symbols) 1) 162 ((eqv? (car symbols) #\#) 0) 163 (else (count-matches-2 memo 164 (cdr symbols) 165 numbers)))) 166 ((null? symbols) 0) 167 ((eqv? (car symbols) #\.) (count-matches-2 memo 168 (cdr symbols) 169 numbers)) 170 ((eqv? (car symbols) #\#) (count-anchored-matches memo 171 symbols 172 numbers)) 173 (else (assert (eqv? (car symbols) #\?)) 174 (+ (count-spaced-matches memo symbols numbers) 175 (count-anchored-matches memo symbols numbers)))))) 176 ; (write-line (conc "computed " symbols " " numbers " -> " result)) 177 (hash-table-set! memo (cons symbols numbers) result) 178 result))) 179 180 (define (unfold pat sep) 181 (append pat sep pat sep pat sep pat sep pat)) 182 183 (define (answer-2 line) 184 (let ((symbols (unfold (car line) '(#\?))) 185 (numbers (unfold (cadr line) '())) 186 (memo (make-hash-table))) 187 (count-matches-2 memo symbols numbers))) 188 189 190 ;(for-each 191 ; (lambda (line) (write-line (conc line " -> " 192 ; (count-matches (car line) (cadr line)) 193 ; " -> " 194 ; (answer-2 line)))) 195 ; data) 196 197 (write-line (conc "Second puzzle: " 198 (apply + (map (lambda (line) (answer-2 line)) data))))