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

day15.scm (4906B)

      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 
     17 (define data (read-line))
     18 
     19 (define verbose #f)
     20 
     21 ;;;;;;;;;;;;;;;;;
     22 ;; First Puzzle
     23 
     24 (define (update-hash hash c)
     25   (remainder (* 17 (+ hash (char->integer c))) 256))
     26 
     27 (define (answer-1 str)
     28   (let loop ((todo (string->list str))
     29              (hash 0)
     30              (acc 0))
     31     (cond ((null? todo) (+ acc hash))
     32           ((eqv? (car todo) #\,) (loop (cdr todo) 0 (+ acc hash)))
     33           (else (loop (cdr todo)
     34                       (update-hash hash (car todo))
     35                       acc)))))
     36 
     37 (write-line (conc "First puzzle:  " (answer-1 data)))
     38 
     39 ;;;;;;;;;;;;;;;;;
     40 ;; Second Puzzle
     41 
     42 (define (lens->string l)
     43   (conc " [" (list->string (car l)) " " (cadr l) "]"))
     44 
     45 (define (lens-list->string l)
     46   (let loop ((todo l) (acc '()))
     47     (if (null? todo)
     48         (apply conc (reverse acc))
     49         (loop (cdr todo) (cons (lens->string (car todo)) acc)))))
     50 
     51 (define (write-box vec)
     52   (let loop ((index 0))
     53     (unless (>= index (vector-length vec))
     54       (let ((element (vector-ref vec index)))
     55         (unless (null? element)
     56           (write-line (conc "  " index " -> " (lens-list->string element)))))
     57       (loop (add1 index)))))
     58 
     59 (define (add-lens label focal lens-list)
     60   (let loop ((todo lens-list)
     61              (acc '()))
     62     (cond ((null? todo)
     63               (reverse (cons (list label focal) acc)))
     64           ((equal? (caar todo) label)
     65               (append (reverse acc) (list (list label focal)) (cdr todo)))
     66           (else
     67               (loop (cdr todo) (cons (car todo) acc))))))
     68 
     69 (define (add-lens! boxes label hash focal)
     70   (vector-set! boxes hash (add-lens label focal (vector-ref boxes hash))))
     71 
     72 (define (rm-lens label lens-list)
     73   (let loop ((todo lens-list)
     74              (acc '()))
     75     (if (null? todo)
     76         (reverse acc)
     77         (loop (cdr todo)
     78               (if (equal? (caar todo) label)
     79                   acc
     80                   (cons (car todo) acc))))))
     81 
     82 (define (rm-lens! boxes label hash)
     83   (vector-set! boxes hash (rm-lens label (vector-ref boxes hash))))
     84 
     85 (define (answer-2 str)
     86   (let ((boxes (make-vector 256 '())))
     87     (let loop ((todo (append (string->list str) '(#\,)))
     88                (label '())
     89                (hash 0))
     90       (unless (null? todo)
     91         (case (car todo)
     92           ((#\-) (assert (eqv? (cadr todo) #\,))
     93                  (rm-lens! boxes (reverse label) hash)
     94                  (when verbose
     95                    (write-line
     96                      (conc "After \"" (list->string (reverse label)) "-\":"))
     97                    (write-box boxes))
     98                  (loop (cddr todo) '() 0))
     99           ((#\=) (assert (eqv? (caddr todo) #\,))
    100                  (assert (<= 48 (char->integer (cadr todo)) 57))
    101                  (add-lens! boxes (reverse label) hash
    102                             (- (char->integer (cadr todo)) 48))
    103                  (when verbose
    104                    (write-line
    105                      (conc "After \""
    106                            (list->string (reverse (cons (cadr todo)
    107                                                         (cons #\= label))))
    108                            "\":"))
    109                    (write-box boxes))
    110                  (loop (cdddr todo) '() 0))
    111           (else  (assert (not (eqv? (car todo) #\,)))
    112                  (loop (cdr todo)
    113                        (cons (car todo) label)
    114                        (update-hash hash (car todo)))))))
    115     (when verbose (write-line "Computing answer-2:"))
    116     (let loop ((box-index 1)
    117                (todo (vector-ref boxes 0))
    118                (lens-index 1)
    119                (acc 0))
    120       (if (null? todo)
    121           (if (< box-index 256)
    122               (loop (add1 box-index)
    123                     (vector-ref boxes box-index)
    124                     1
    125                     acc)
    126               acc)
    127           (begin
    128             (when verbose
    129                (write-line (conc
    130                   (lens->string (car todo)) " -> "
    131                   (* box-index lens-index (cadar todo)))))
    132             (loop box-index
    133                   (cdr todo)
    134                   (add1 lens-index)
    135                   (+ acc (* box-index lens-index (cadar todo)))))))))
    136 
    137 (write-line (conc "Second puzzle: " (answer-2 data)))