This problem feels a bit more Scheme-shaped. To keep things interesting, I have chosen to stick to pure functional programming.

A card consists of three components – a card number (which turned out to be completely unnecessary), a list of winning numbers, and a list of numbers. Here’s a function to parse a card from a string, turning it into a 3-element list:

(define (parse-card card)
  (let* ((parts (string-split card ":"))
         (numlists (string-split (cadr parts) "|")))
    (list (string->number (string-drop (car parts) 5))
          (map string->number (string-split (car numlists) " "))
          (map string->number (string-split (cadr numlists) " "))

The value of a card is easy enough to compute. The first matched winning number sets the value to 1, every subsequent one doubles it.

(define (card-value card)
  (let* ((card-parts (parse-card card))
         (winning-numbers (cadr card-parts)))
    (let loop ((nums (caddr card-parts)) (val 0))
      (cond ((null? nums) val)
            ((and (= val 0) (memq (car nums) winning-numbers)) (loop (cdr nums) 1))
            ((memq (car nums) winning-numbers) (loop (cdr nums) (* val 2)))
            (else (loop (cdr nums) val))))))

Solving part 1 is now straightforward:

(define (solve-part-1 cards)
  (apply + (map card-value cards)))

But oh no! Turns out I (or the elf) got the rules wrong, and apparently the game requires so many dead trees to play that I think it was probably designed by Jair Bolsonaro.

A function to count the card matches (eg. how many numbers match a winning number) is easily adapted from the above:

(define (card-matches card)
  (let* ((card-parts (parse-card card))
         (winning-numbers (cadr card-parts)))
    (let loop ((nums (caddr card-parts)) (val 0))
      (cond ((null? nums) val)
            ((memq (car nums) winning-numbers) (loop (cdr nums) (+ val 1)))
            (else (loop (cdr nums) val))))))

My strategy here is to have two lists: One of the card matches of all cards, the other of how many instances I have of each card. The second list will start as (1 1 1 1 ... ), and I need to be able to add some number x to the first n cards in the list. For example, if I have 4 instances of the first card, and it has 2 matches, then I’ll want to add 4 to however many instances I have of the next 2 cards. Here’s a function that reaches into a list and does just that:

(define (reach x n l)
  (if (or (= n 0) (null? l))
    l
    (cons (+ x (car l)) (reach x (- n 1) (cdr l)))))

Using this, here’s a recursive function that counts cards, given the two aforementioned lists:

(define (count-cards matches cards)
  (if (null? cards) 0
    (+ (car cards)
       (count-cards (cdr matches)
                    (reach (car cards) (car matches) (cdr cards))))))

Solving part 2 is now easy:

(define (solve-part-2 lines)
  (count-cards (map card-matches lines) (map (lambda (x) 1) lines)))

There you have it. It’d have been shorter if I had allowed myself some side effects, but pure functional programming is terrific fun.

To avoid annoying special cases for dealing with reading past the edges of the schematic, I start by adding one cell of padding on all sides.

(define (pad-schematic lines)
  (let* ((width (string-length (car lines)))
         (empty-line (make-string (+ width 2) #\.)))
    (append (list empty-line)
            (map (lambda (str) (string-append "." str ".")) lines)
            (list empty-line))))

I’m also going to define a few utility functions. The schematic-pos function reads what’s on the x,y position of the schematic, and is here to compensate for Scheme being awkward for dealing with two-dimensional structures. The two others check whether some position is a symbol (other than .) or a digit.

(define (schematic-pos s x y)
  (string-ref (list-ref s y) x))

(define (pos-symbol? s x y)
  (let ((chr (schematic-pos s x y)))
    (and (not (char=? chr #\.))
         (not (char-set-contains? char-set:digit chr)))))

(define (pos-digit? s x y)
  (let ((chr (schematic-pos s x y)))
    (char-set-contains? char-set:digit chr)))

I want a list of all positions of symbols in the schematic, so I can check them for adjacent numbers. I could also have gone with a list of numbers instead, but symbols seemed easier to find adjacencies for.

(define (symbol-positions s)
  (let ((width (string-length (car s)))  (height (length s)))
    (let loop ((x 0) (y 0) (syms '()))
      (cond ((>= y height) syms)
            ((>= x width) (loop 0 (+ y 1) syms))
            ((pos-symbol? s x y)
             (loop (+ x 1) y (cons (cons x y) syms)))
            (else (loop (+ x 1) y syms))))))

This produces a list of (x y) pairs, one for each symbol. Finding adjacent numbers is a bit tricky: Since there are three relevant positions above and below the symbol’s own position, there could be one or two numbers above or below, and if there are two, then I might be reading the same number twice. I accept this, and keep the numbers in an lset (which means that a duplicate simply won’t be inserted). The number reader itself produces triples on the form (x y n), where x is the position of the first character in the number, and n is a string containing the number itself. The coordinates are stored to ensure that if there are several instances of the same number in different positions in the schematic, they get treated separately.

(define (get-number-pos s x y)
  (letrec
    ((num_l (lambda (x) (if (pos-digit? s x y) (num_l (- x 1)) (+ x 1))))
     (num_r (lambda (x) (if (pos-digit? s x y) (num_r (+ x 1)) x))))
    (list (num_l x) y (string-copy (list-ref s y) (num_l x) (num_r x)))))

(define (get-adjacent-numbers s xpos ypos)
  (let loop ((x (- xpos 1)) (y (- ypos 1)) (nums '()))
    (cond
      ((> y (+ ypos 1)) nums)
      ((> x (+ xpos 1)) (loop (- xpos 1) (+ y 1) nums))
      ((pos-digit? s x y)
       (loop (+ x 1) y (lset-adjoin equal? nums (get-number-pos s x y))))
      (else (loop (+ x 1) y nums)))))

From here, solving the two parts is easy. For part 1, we get all the lists of number adjacencies and unpack them into a single list:

(define (get-part-numbers s)
  (let ((sym-nums (map (lambda (c) (get-adjacent-numbers s (car c) (cdr c)))
                       (symbol-positions s))))
    (let loop ((curr (car sym-nums)) (syms (cdr sym-nums)) (nums '()))
      (cond ((and (null? curr) (null? syms)) nums)
            ((null? curr) (loop (car syms) (cdr syms) nums))
            (else (loop (cdr curr) syms (cons (car curr) nums)))))))

(define (solve-part-1 schematic)
  (apply + (map (lambda (x) (string->number (caddr x)))
                (get-part-numbers schematic))))

For part 2, we need a list of gears. We can just get all the symbols, filter out everything that isn’t a *, and then filter out everything that doesn’t have exactly two adjacencies.

(define (gears s)
  (filter (lambda (x) (= (length x) 2))
          (map (lambda (x) (get-adjacent-numbers s (car x) (cdr x)))
               (filter
                 (lambda (x) (char=? (schematic-pos s (car x) (cdr x)) #\*))
                 (symbol-positions s)))))

(define (solve-part-2 s)
  (apply + (map (lambda (y) (* (string->number (caddr (car y)))
                               (string->number (caddr (cadr y)))))
                (gears s))))

I could probably have written nicer code if I weren’t still a bit sick (though I’m getting better!). However, the moment I realized this one would be about mucking around with two-dimensional structures, I knew Scheme was going to be a bit awkward. But here you have it.

The string format of a game is, for example: "Game 1: 3 blue, 4 red; 1 red, 2 green, 6 blue; 2 green". I’ll transform a game string into a list, such that the above example becomes (1 (4 0 3) (1 2 6) (0 2 0)).

I start by simply splitting on : and chopping off "Game" from the first string to get the game number. The second string consists of a sequence of draws, which need a bit further parsing effort.

(define (parse-game game)
  (let* ((parts (string-split game ":"))
         (number (string->number (string-drop (car parts) 5)))
         (draws (map parse-draws (string-split (cadr parts) ";"))))
    (cons number draws)))

Parsing a draw is done by first splitting it on ;, to yield strings on the form "3 blue, 4 red". Each such string represents a cubeset, which I represent as lists on the form (r g b). Since the input strings don’t have any well-defined ordering of cube colours, I split on , and iterate on the resulting list of strings until I find one that has the proper colour name as its suffix, in the order red -> green -> blue. If none exists, I return 0 for that colour.

(define (parse-draws cstr)
  (let ((cubes (map string-trim (string-split cstr ","))))
    (list (get-col cubes "red")
          (get-col cubes "green")
          (get-col cubes "blue"))))

(define (get-col cubeset col)
  (cond ((null? cubeset) 0)
        ((string-suffix? col (car cubeset))
         (string->number (car (string-split (car cubeset) " "))))
        (else (get-col (cdr cubeset) col))))

To determine whether a game is possible given some numbers of different colours, I need to find the maxima of each colour for all draws in a game:

(define (maxima cubesets)
  (let loop ((cubesets cubesets) (r 0) (g 0) (b 0))
    (if (null? cubesets)
      (list r g b)
      (loop (cdr cubesets)
            (max r (caar cubesets))
            (max g (cadar cubesets))
            (max b (caddar cubesets))))))

The maxima of the draw ((4 0 3) (1 2 6) (0 2 0)) is (4 2 6). With that, it’s easy to determine whether a game is possible:

(define (game-possible? game r g b)
  (let ((mx (maxima (cdr game))))
    (and (>= r (car mx))
         (>= g (cadr mx))
         (>= b (caddr mx)))))

The solution to part 1 is now simple:

(define (solve-part1 lines)
  (let solve ((sum 0) (games (map parse-game lines)))
    (cond ((null? games) sum)
          ((game-possible? (car games) 12 13 14)
           (solve (+ sum (caar games)) (cdr games)))
          (else (solve sum (cdr games))))))

…where lines is all the lines of the input file.

Part 2 is simple, given that I already have a way to get the maxima of the draws in a game. All I need to do is to multiply them together:

(define (power-cubeset cubeset)
  (* (car cubeset) (cadr cubeset) (caddr cubeset)))

(define (solve-part2 lines)
  (let solve ((sum 0) (games (map parse-game lines)))
    (cond ((null? games) sum)
          (else (solve (+ sum (power-cubeset (maxima (cdar games))))
                       (cdr games))))))

Here is a regex:·

rx = "(?=(one|two|three|four|five|six|seven|eight|nine|1|2|3|4|5|6|7|8|9))"

The leading ?= is a lookahead assertion. If we can read any of the subexpressions one,two,…, it produces the empty string as a match, with the actual matched string as a capturing group. Python’s re module has a findall function which finds all non-overlapping matches in a string … but since it’s the matches (not the capturing groups) that have to be non-overlapping, and lookahead produces empty strings as matches, we have re.findall(rx,"twone") == ["two","one"] and re.findall(rx,"sevenineight") == ["seven","nine","eight"]. Empty string doesn’t overlap!

So here’s the core of the solution:

def solve(s):
    m = [numeralize(t) for t in re.findall(rx, s)]
    return int(m[0] + m[len(m)-1])

Where numeralize is a simple function that converts “eight” into “8”. Not to the number 8, since we want to do string concatenation on them rather than addition. :-)

I haven’t written any Perl in ages, so I have no idea if Perl has an analogue to findall.

…but I do know that Scheme, at least CHICKEN, doesn’t. Here is the best my currently badly fever-addled brain could come up with:

I’m using the irregex library. I start by building an irregex out of a SRE (Scheme Regular Expression):

(define ir (sre->irregex '(seq bos (or "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"·
                                       "1" "2" "3" "4" "5" "6" "7" "8" "9"))))

This matches from the beginning of the string (hence bos), and doesn’t use any fancy lookahead. It only matches one string.

Here is a little recursive function that finds all matches using the above:

(define (all-matches s)
  (if (= (string-length s) 0)
    '()
    (let ((matches (irregex-search ir s)))
      (if (not matches)
        (all-matches (string-drop s 1))
        (cons (irregex-match-substring matches)
              (all-matches (string-drop s 1)))))))

It simply tries making a match from the beginning, and then continues making one from a substring with the first character hacked off, until it ends up with the empty string. Not exactly my proudest Scheme code, but it works.

Using that, the analogue of the solution I did for the Python version is:

(define (solve s)
  (let ((m (all-matches s)))
    (string->number
      (string-append (numeralize (list-ref m 0))
                     (numeralize (list-ref m (- (length m) 1)))))))

Again, not my proudest Scheme code! I am currently nursing a fever and trying not to sneeze and cough my lungs to pieces.