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

day03.scm (4554B)

      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         srfi-1)
     17 
     18 ;; input data, as a list of strings
     19 (define grid (read-lines))
     20 
     21 ;; derived sizes
     22 (define width (string-length (car grid)))
     23 (define height (length grid))
     24 (define (xy-valid? x y)
     25   (and (< -1 x width) (< -1 y height)))
     26 
     27 ;; grid accessors
     28 (define (grid-char x y)
     29   (if (xy-valid? x y)
     30       (string-ref (list-ref grid y) x)
     31       #\nul))
     32 
     33 ;; grid iterators
     34 (define (next-x x)
     35   (if (>= x width) 0 (+ x 1)))
     36 (define (next-y y)
     37   (if (>= y height) 0 (+ y 1)))
     38 (define (last? x y)
     39   (and (= x (- width 1)) (= y (- height 1))))
     40 
     41 ;; symbol check
     42 ;; (in my input, symbols are "#$%&*+-./=@")
     43 (define (char-symbol? c)
     44   (or (<= 35 (char->integer c) 45) (eqv? c #\/) (eqv? c #\=) (eqv? c #\@)))
     45 
     46 ;;;;;;;;;;;;;;;;;
     47 ;; First Puzzle
     48 
     49 ;; list of (start-x end-x y value) for each part number
     50 (define number-position-list
     51   (let loop ((acc '()) (start-x -1) (x 0) (y 0) (n 0))
     52     (cond ((>= y height) acc)
     53           ((>= x width)
     54              (loop (if (>= start-x 0) (cons (list start-x x y n) acc) acc)
     55                    -1 0 (+ y 1) 0))
     56           ((char-numeric? (grid-char x y))
     57              (loop acc (if (>= start-x 0) start-x x) (+ x 1) y (+ (* n 10) (char->integer (grid-char x y)) -48)))
     58           ((>= start-x 0)
     59              (loop (cons (list start-x x y n) acc) -1 (+ x 1) y 0))
     60           (else
     61              (loop acc -1 (+ x 1) y 0)))))
     62 
     63 ;; check whether a given horizontal range contains a symbol
     64 (define (contains-symbol? start-x end-x y)
     65   (cond ((or (< y 0) (>= y height) (>= start-x end-x)) #f)
     66         ((char-symbol? (grid-char start-x y)) #t)
     67         (else (contains-symbol? (+ start-x 1) end-x y))))
     68 
     69 ;; check whether a symbol exists near the given number position
     70 (define (is-part-position? pos)
     71   (let ((start-x (car   pos))
     72         (end-x   (cadr  pos))
     73         (y       (caddr pos)))
     74     (or (contains-symbol? (sub1 start-x) (add1 end-x) (sub1 y))
     75         (contains-symbol? (sub1 start-x) (add1 end-x) (add1 y))
     76         (contains-symbol? (sub1 start-x)    start-x       y)
     77         (contains-symbol?     end-x      (add1 end-x)     y))))
     78 
     79 ;; extract part number from all numbers
     80 (define part-position-list (filter is-part-position? number-position-list))
     81 
     82 ;; sum of all part numbers
     83 (define answer-1
     84   (let loop ((position-list part-position-list) (acc 0))
     85     (if (null? position-list)
     86         acc
     87         (let ((rest (cdr position-list))
     88               (head (car position-list)))
     89           (loop rest (+ acc (cadddr head)))))))
     90 (write-line (conc "First puzzle:  " answer-1))
     91 
     92 ;;;;;;;;;;;;;;;;;
     93 ;; Second Puzzle
     94 
     95 ;; is the given number-position adjacent to the given position
     96 (define (adjacent? pos x y)
     97   (let ((start-x (car   pos))
     98         (end-x   (cadr  pos))
     99         (pos-y   (caddr pos)))
    100     (and (<= (sub1 pos-y) y (add1 pos-y))
    101          (<= (sub1 start-x) x end-x))))
    102 
    103 ;; list of all part positions adjacent to the given position
    104 (define (adjacent-pos-list x y todo found)
    105   (if (null? todo)
    106       found
    107       (adjacent-pos-list x y (cdr todo)
    108          (if (adjacent? (car todo) x y)
    109              (cons (car todo) found)
    110              found))))
    111 
    112 ;; list of all part numbers adjacent to the given position
    113 (define (adjacent-num-list x y)
    114   (map cadddr (adjacent-pos-list x y part-position-list '())))
    115 
    116 ;; compute the gear ratio
    117 (define (gear-ratio x y not-a-gear)
    118   (if (eqv? (grid-char x y) #\*)
    119       (let ((num-list (adjacent-num-list x y)))
    120         (if (= (length num-list) 2)
    121             (apply * num-list)
    122             not-a-gear))
    123       not-a-gear))
    124 
    125 ;; iterate over the whole grid
    126 (define answer-2
    127   (let loop ((x 0) (y 0) (acc 0))
    128     (cond ((>= y height) acc)
    129           ((>= x width) (loop 0 (add1 y) acc))
    130           (else (loop (add1 x) y (+ acc (gear-ratio x y 0)))))))
    131 (write-line (conc "Second puzzle: " answer-2))