aoc-all

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

day04.scm (3403B)

      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 spaces
     24   (one-or-more (is #\space)))
     25 
     26 (define digit
     27   (in char-set:digit))
     28 
     29 (define digits
     30   (as-string (one-or-more digit)))
     31 
     32 (define number-list
     33   (sequence* ((first digits)
     34               (rest (zero-or-more (preceded-by spaces digits))))
     35     (result (map string->number (cons first rest)))))
     36 
     37 (define card-line
     38   (sequence* ((_ (sequence (char-seq "Card") spaces))
     39               (id digits)
     40               (_ (sequence (is #\:) spaces))
     41               (winning number-list)
     42               (_ (sequence spaces (is #\|) spaces))
     43               (owned number-list)
     44               (_ (is #\newline)))
     45      (result (list (string->number id) winning owned))))
     46 
     47 (define all-data
     48   (one-or-more card-line))
     49 
     50 (define data (parse all-data (read-string)))
     51 
     52 ;;;;;;;;;;;;;;;;;
     53 ;; Second Puzzle
     54 
     55 (define (is-in? n l)
     56   (cond ((null? l) #f)
     57         ((= n (car l)) #t)
     58         (else (is-in? n (cdr l)))))
     59 
     60 (define (count-score winning todo acc)
     61   (if (null? todo)
     62       acc
     63       (count-score winning
     64                    (cdr todo)
     65                    (cond ((not (is-in? (car todo) winning)) acc)
     66                          ((= acc 0) 1)
     67                          (else (* acc 2))))))
     68 
     69 (define (card-score card)
     70   (let ((winning (cadr card))
     71         (owned (caddr card)))
     72     (count-score winning owned 0)))
     73 
     74 (define (answer-1 todo acc)
     75   (if (null? todo) acc (answer-1 (cdr todo) (+ acc (card-score (car todo))))))
     76 
     77 (write-line (conc "First puzzle:  " (answer-1 data 0)))
     78 
     79 ;;;;;;;;;;;;;;;;;
     80 ;; Second Puzzle
     81 
     82 (define (count-matches winning todo acc)
     83   (if (null? todo)
     84       acc
     85       (count-matches winning
     86                      (cdr todo)
     87                      (if (is-in? (car todo) winning) (add1 acc) acc))))
     88 
     89 (define (add-copies count-vector id m n)
     90   (if (= 0 n) count-vector
     91      (begin (vector-set! count-vector id (+ (vector-ref count-vector id) m))
     92             (add-copies count-vector (add1 id) m (sub1 n)))))
     93 
     94 (define (process-card count-vector card)
     95   (let ((id (car card))
     96         (winning (cadr card))
     97         (owned (caddr card)))
     98     (add-copies count-vector
     99                 (add1 id)
    100                 (vector-ref count-vector id)
    101                 (count-matches winning owned 0))))
    102 
    103 (define (process-cards count-vector todo)
    104   (if (null? todo)
    105       count-vector
    106       (process-cards (process-card count-vector (car todo)) (cdr todo))))
    107 
    108 (define inst-count
    109   (process-cards (make-vector (add1 (length data)) 1) data))
    110 (vector-set! inst-count 0 0)
    111 
    112 (write-line (conc "Second puzzle: " (apply + (vector->list inst-count))))