aoc-2023

My solutions in CHICKEN scheme to Advent of Code 2023
git clone https://git.instinctive.eu/aoc-2023.git
Log | Files | Refs | README | LICENSE

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))))