Advent of Wisp Code 2021

Day 1, puzzle 1: Sweep the deep

arne@fluss (Dr. Arne Babenhauserheide) — Thu, 02 Dec 2021 01:05:00 +0100

Count how often the depth of the ocean increases.

import : srfi :1 lists
         srfi :9 records

define example-input ' : 199 200 208 210 200 207 240 269 260 263

;; aggregate using a two number window.
define : count-larger current next count
  + count : if {next > current} 1 0

display
  fold count-larger 0
    ;; dropping the first element of the second list
    ;; this shifts the second element in count-larger by 1 => next
    . example-input
    drop example-input 1

For the real calculation, I plugged in the input via define input '(...).

Hacky but quick.

Day 1, puzzle 2: Sweep the deep averages

arne@fluss (Dr. Arne Babenhauserheide) — Thu, 02 Dec 2021 01:05:00 +0100

Count how often the three element moving sum of the depth increases.

import : srfi :1 lists
         srfi :9 records

define example-input ' : 199 200 208 210 200 207 240 269 260 263

;; aggregate using a 4 number window.
define : count-larger n0 n1 n2 n3 count
  + count : if {(+ n1 n2 n3) > (+ n0 n1 n2)} 1 0

display
  fold count-larger 0
    . example-input
    drop example-input 1
    drop example-input 2
    drop example-input 3

I’m not fully happy with this code — it is longer and more complex than I’d like it to be. But it solves the problem. For a quick fix it is OK, and the adaption from puzzle 1 to puzzle 2 was easy, which is a good sign.

Day 2, Puzzle 1: Pilot the submarine

arne@fluss (Dr. Arne Babenhauserheide) — Fri, 03 Dec 2021 02:03:00 +0100

Read instructions to find the position when following them.

These look like wisp: I’m trying to turn them into code.

The input is now written to a file:

forward 5
down 5
forward 8
up 3
down 8
forward 2

define horizontal 0
define vertical 0
define-syntax-rule : inc var steps
  set! var {var + steps}
define-syntax-rule : dec var steps
  set! var {var - steps}
define (forward steps) : inc horizontal steps
define (down steps) : inc vertical steps
define (up steps) : dec vertical steps

;; load the input as code
;; load "advent-of-wisp-code-2021-d2p1-real-input.w"
load "advent-of-wisp-code-2021-d2p1-example-input.w"

display {horizontal * vertical}

Day 2, Puzzle 2: Aim the submarine

arne@fluss (Dr. Arne Babenhauserheide) — Fri, 03 Dec 2021 07:24:00 +0100

The input is the same, but the code is different.

define aim 0
define horizontal 0
define vertical 0
define-syntax-rule : inc var steps
  set! var {var + steps}
define-syntax-rule : dec var steps
  set! var {var - steps}
;; the commands and the presence of aim are all that changes:
define (forward steps)
   inc horizontal steps
   inc vertical {aim * steps}
define (down steps) : inc aim steps
define (up steps) : dec aim steps

;; load the input as code
;; load "advent-of-wisp-code-2021-d2p1-real-input.w"
load "advent-of-wisp-code-2021-d2p1-example-input.w"

display {horizontal * vertical}

I actually like this code quite a bit, and adjusting it from puzzle 1 to puzzle 2 was a breeze. It’s still a hack, though …

Update: simple shell-script

While the previous version is kind of a hack (but one that uses a method I actually use to write games), it would be an even funnier hack to replace the auto-pilot with a simple shell script.

export AIM=0
export HORIZONTAL=0
export VERTICAL=0
function inc() {
  export ${1}=$((${1} + ${2}))
}
function dec() {
  export ${1}=$((${1} - ${2}))
}
function forward () {
  inc HORIZONTAL ${1}
  inc VERTICAL $((${AIM} * ${1}))
}
function down () {
  inc AIM ${1}
}
function up () {
  dec AIM ${1}
}
source "advent-of-wisp-code-2021-d2p1-example-input.w"

echo $(($HORIZONTAL * $VERTICAL))

Would you bet your life on it? :-)

Day 3, Puzzle 1: Diagnose a Dive

arne@fluss (Dr. Arne Babenhauserheide) — Fri, 03 Dec 2021 23:15:00 +0100

Calculate the most common bit in each position. The resulting bits give the diagnostic number γ. Using least common bit gives ε.

Example Input:

First define a helper function that was re-used a lot later: map-over-lines. This receives a function and a filename and applies the function to every line read from the file.

;; snippet: {{{map-over-lines}}}
import : only (ice-9 rdelim) read-line
define : map-over-lines fun filename
  let : : port : open-input-file filename
    let loop : (lines '()) (line (read-line port))
      if : eof-object? line
        begin
          close port
          reverse! lines
        loop
          cons : fun line
               . lines
          read-line port

Also for both tasks of day 3, I need base2 tools:

;; snippet: {{{base2-functions}}}
define : base2->number str
  . "read binary: a base2 number."
  string->number str 2

define : numbers->string list-of-numbers
  string-join 
    map number->string list-of-numbers
    . ""

define : numbers->decimal list-of-numbers
  base2->number
    numbers->string list-of-numbers

define : split-line-into-numbers line
  map string->number : map string : string->list line

Now the actual solution:

import : only (ice-9 rdelim) read-line

{{{map-over-lines}}}
{{{base2-functions}}}

define input
  map-over-lines split-line-into-numbers
    . "advent-of-wisp-code-2021-d3p1-example-input.dat"

define len/2 {(length input) / 2}

define most-common
    map : λ(x) : if {x > len/2} #\1 #\0
        apply map + input

define least-common
    map : λ(x) : if (equal? x #\1) #\0 #\1
        . most-common

define γ : base2->number : apply string most-common
define ε : base2->number : apply string least-common 

display {γ * ε}

Originally this was more complex than I’d like it to be, but switching to map-over-lines from Day 13, it got a lot cleaner.

Day 3, Puzzle 2: Diagnose for Life

arne@fluss (Dr. Arne Babenhauserheide) — Fri, 03 Dec 2021 23:15:00 +0100

Filter the numbers bit by bit, keeping only those where the bit in the given position is the most common bit. If only one number remains, that’s the result.

import : only (ice-9 rdelim) read-line
         srfi :9 records
         only (srfi :26) cut
;; using map-over-lines again, this will be used many times over
{{{map-over-lines}}}
;; base2->number, numbers->string and numbers->decimal
{{{base2-functions}}}
define input
  map-over-lines split-line-into-numbers 
    . "advent-of-wisp-code-2021-d3p1-example-input.dat"
;; most- and least-common as functions to use as aggregator
define : most-common input len/2
   map : λ(x) : if {x >= len/2} 1 0
       apply map + input
define : least-common input len/2
   map : λ(x) : if {x >= len/2} 0 1
       apply map + input
define : filt input aggregator bitindex
  define len/2 {(length input) / 2}
  define aggregated : aggregator input len/2
  define : matches pattern bitindex
    equal? : list-ref pattern bitindex
             list-ref aggregated bitindex
  filter : cut matches <> bitindex
         . input

define : select aggregator
  let loop : (input (filt input aggregator 0)) (next-bitindex 1)
    if : = 1 : length input
       car input
       loop : filt input aggregator next-bitindex
            + next-bitindex 1

define oxygen : select most-common
define co2scrub : select least-common
display
  * : numbers->decimal oxygen
      numbers->decimal co2scrub

Day 4, Puzzle 1: Cheat the Squid

arne@fluss (Dr. Arne Babenhauserheide) — Sun, 05 Dec 2021 01:56:00 +0100

A squid attached to the ship. I need to cheat it in Bingo.

Known numbers that will be drawn, and bingo boards:

7,4,9,5,11,17,23,2,0,14,21,24,10,16,13,6,15,25,12,22,18,20,8,19,3,26,1

22 13 17 11  0
 8  2 23  4 24
21  9 14 16  7
 6 10  3 18  5
 1 12 20 15 19

 3 15  0  2 22
 9 18 13 17  5
19  8  7 25 23
20 11 10 24  4
14 21 16 12  6

14 21 17 24  4
10 16 15  9 19
18  8 23 26 20
22 11 13  6  5
 2  0 12  3  7

Both solutions of this day need to read the bingo board:

;; snippet: {{{bingo-board}}}
define-record-type 
  make-bingo numbers boards
  . bingo?
  numbers bingo-numbers bingo-numbers-set!
  boards bingo-boards bingo-boards-set!

define : split-bingo-line line
  if : eof-object? line
    list
    map string->number : delete "" : string-split line #\space

define bingo
  let : : port : open-input-file "advent-of-wisp-code-2021-d4p1-example-input.dat"
    define numbers :  map string->number : string-split (read-line port) #\,
    ;; skip separator line
    read-line port
    define boards
      let read-board : (boards '())
        if : eof-object? : peek-char port
          reverse boards
          read-board
            cons
              let loop : (board '()) (line (split-bingo-line (read-line port)))
                if : null? line
                  reverse board
                  loop : cons line board
                         split-bingo-line : read-line port
              . boards
    close port
    make-bingo numbers boards

define : play-number number board
  map : λ(x) (map (λ(y) (if (equal? number y) #f y)) x)
      . board

define : board-won? board
  define : row-won? row
    every not row
  if ;; force explicit #t or #f
    or
      member #t : map row-won? board
      member #t : apply map (λ(. x) (row-won? x)) board
    . #t #f

On day one I want to win:

To cheat the squid, I need to find the sum of all the unmarked fields in the winning board (the first to have one fully marked row or column).

Then multiply it with the winning number to get the result.

import : only (ice-9 rdelim) read-line
         srfi :9 records
         only (srfi :26) cut
         only (srfi :1) every fold list-index

{{{bingo-board}}}

display
  let loop : (boards (bingo-boards bingo)) (numbers (bingo-numbers bingo))
    define played : map (cut play-number (car numbers) <>) boards
    define result : map board-won? played
    cond
      : null? numbers
        . #f
      : member #t result
        let : : winner : list-ref played : list-index (λ(x) x) result
          * : car numbers
              apply + : apply map (λ(. x) (apply + (delete #f x)))  winner
      else
        loop played
             cdr numbers

Day 4, Puzzle 2: Let the squid win

arne@fluss (Dr. Arne Babenhauserheide) — Sun, 05 Dec 2021 01:56:00 +0100

A squid attached to the ship. I need to let it win in Bingo. For sure. So I take the board that wins last.

Need to find the sum of all the unmarked fields in the winning board (the first to have one fully marked row or column).

Multiply it with the winning number.

import : only (ice-9 rdelim) read-line
         srfi :9 records
         only (srfi :26) cut
         only (srfi :1) every fold list-index remove

{{{bingo-board}}}

display
  let loop : (boards (bingo-boards bingo)) (numbers (bingo-numbers bingo))
    define played : map (cut play-number (car numbers) <>) boards
    define result : map board-won? played
    cond
      : null? numbers
        . #f
      : every identity result
         ;; choose the first of the last winners
        let : : winner : list-ref played 0
          * : car numbers
              apply + : apply map (λ(. x) (apply + (delete #f x)))  winner
      else
        loop : remove board-won? played
             cdr numbers

The adjustment worked very well: the only changes are in the final let loop:

replace loop played by loop : remove board-won? played and
replace member #t result by every identity result and
always take the first of the last winners.

Day 5, Puzzle 1: Sidestep the vents

arne@fluss (Dr. Arne Babenhauserheide) — Mon, 06 Dec 2021 23:54:00 +0100

Draw lines and find meeting points.

0,9 -> 5,9
8,0 -> 0,8
9,4 -> 3,4
2,2 -> 2,1
7,0 -> 7,4
6,4 -> 2,0
0,9 -> 2,9
3,4 -> 1,4
0,0 -> 8,8
5,5 -> 8,2

import : only (ice-9 rdelim) read-line
         only (srfi :26) cut
         only (srfi :1) fold
         ice-9 hash-table

define : pixels-for-line x0 y0 x1 y1
  cond ;; only vertical and orthogonal lines
    {y0 = y1} 
      map (cut cons <> y0)
        if {x0 < x1} : iota (+ 1 {x1 - x0}) x0
                       iota (+ 1 {x0 - x1}) x1
    {x0 = x1} 
      map (cut cons x0 <>)
        if {y0 < y1} : iota (+ 1 {y1 - y0}) y0
                       iota (+ 1 {y0 - y1}) y1
    else '()

define : line-coordinates line
  map string->number : string-tokenize line char-set:digit

define : hash-add1 key al
  hash-set! al key : + 1 : hash-ref al key 0
  . al

define port : open-input-file "advent-of-wisp-code-2021-d5p1-example-input.dot"


display
  hash-count : λ(key value) {value >= 2}
      let loop : : coordinates : make-hash-table
        define line : read-line port
        if : eof-object? line
          . coordinates
          loop
            fold hash-add1 coordinates
                 apply pixels-for-line : line-coordinates line

Day 5, Puzzle 2: Sidestep the vents diagonally

arne@fluss (Dr. Arne Babenhauserheide) — Mon, 06 Dec 2021 23:54:00 +0100

Draw lines and find meeting points.

import : only (ice-9 rdelim) read-line
         only (srfi :26) cut
         only (srfi :1) fold
         ice-9 hash-table
define : pixels-for-line x0 y0 x1 y1
  cond ;; only vertical and orthogonal lines
    {y0 = y1} 
      map (cut cons <> y0)
        if {x0 < x1} : iota (+ 1 {x1 - x0}) x0
                       iota (+ 1 {x0 - x1}) x1
    {x0 = x1} 
      map (cut cons x0 <>)
        if {y0 < y1} : iota (+ 1 {y1 - y0}) y0
                       iota (+ 1 {y0 - y1}) y1
    else 
      map cons
        if {x0 < x1} : iota (+ 1 {x1 - x0}) x0
                       iota (+ 1 {x0 - x1}) x0 -1
        if {y0 < y1} : iota (+ 1 {y1 - y0}) y0
                       iota (+ 1 {y0 - y1}) y0 -1

define : line-coordinates line
  map string->number : string-tokenize line char-set:digit
define : hash-add1 key al
  hash-set! al key : + 1 : hash-ref al key 0
  . al

define port : open-input-file "advent-of-wisp-code-2021-d5p1-example-input.dot"
display
  hash-count : λ(key value) {value >= 2}
      let loop : : coordinates : make-hash-table
        define line : read-line port
        if : eof-object? line
          . coordinates
          loop
            fold hash-add1 coordinates
                 apply pixels-for-line : line-coordinates line

Day 6, Puzzle 1: Model Exponential Fish

arne@fluss (Dr. Arne Babenhauserheide) — Mon, 06 Dec 2021 23:54:00 +0100

Strange lanternfishes reproduce every 7 days, new fish initially reproduce after 9 days. Model the population growth.

How many will there be after 80 days?

Input: The time to reproduce for each fish.

3,4,3,1,2

For this data format, a simplest possible csv parser is useful. I could use guile-dsv, but I want to avoid libraries here to you can run the code without installing anything but Guile and wisp. So here is the simplest tool to read commaseparated numbers from a line of text:

;; snippet: {{{read-numbers-from-csv-line}}}
define : read-numbers-from-csv-line filename
  let : : port : open-input-file filename
    define res : map string->number : string-split (read-line port) #\,
    close port
    . res

For 80 days, I can use a naive approach and simply keep a list of numbers with the reproduction time.

import : only (srfi :1) fold
         only (ice-9 rdelim) read-line
{{{read-numbers-from-csv-line}}}

define input
  read-numbers-from-csv-line
    . "advent-of-wisp-code-2021-d6p1-example-input.dat"
define : reproduce time-to-reproduce prev
  if : zero? time-to-reproduce
       cons 8 : cons 6 prev
       cons {time-to-reproduce - 1} prev

display
 length
  let rep : (steps 80) (swarm input)
    if (zero? steps) swarm
      rep {steps - 1} : fold reproduce '() swarm

Day 6, Puzzle 2: Model Exponential Fish in Memory

arne@fluss (Dr. Arne Babenhauserheide) — Mon, 06 Dec 2021 23:54:00 +0100

Now the goal is 256 days. That kills my memory for sure. Need a tighter datastructure. Let’s use the keys for the lifetimes. The keys are contiguous integers, so why not a vector?

3,4,3,1,2

import : only (srfi :1) fold
         only (ice-9 rdelim) read-line

{{{read-numbers-from-csv-line}}}

define input
  read-numbers-from-csv-line
    . "advent-of-wisp-code-2021-d6p1-example-input.dat"

define swarm-lifetime-counts
  let : : swarm : make-vector 9 0
    for-each : λ (x) : vector-set! swarm x : + 1 : vector-ref swarm x
      . input
    . swarm

define : reproduce swarm
  define reproducing : vector-ref swarm 0
  ;; reduce all lifetimes by 1
  for-each
    λ (lifetime)
      vector-set! swarm {lifetime - 1} : vector-ref swarm lifetime
    iota 8 1
  ;; add the reproducing to lifetime 6 and 8
  vector-set! swarm 6 : + reproducing : vector-ref swarm 6
  vector-set! swarm 8 reproducing
  . swarm

display
  apply +
    vector->list
      let rep : (steps 256) (swarm swarm-lifetime-counts)
        if (zero? steps) swarm
          rep {steps - 1} : reproduce swarm

Since the fish with the real data are in the trillions, no way I could have done this with the plain list. Each pointer in a linked list needs around 8 byte; just the datastructure would have eaten all my memory many times over. Even a naively optimized tight array with 3-bit-numbers would not have enabled that.

With the new index-counting vector datastructure though, I can easily do 2560 steps. With the example data, the resulting number has 98 digits. 256000 steps take about a second to compute a number with 9687 digits.

Computers are fast.

Day 7, Puzzle 1: Align Fuel Constrained Crab Guns

arne@fluss (Dr. Arne Babenhauserheide) — Thu, 09 Dec 2021 20:15:00 +0100

Crabs come to blast a path into a cave. You must align them: Find the positions where they need to move the least amount of steps so their guns can interlock into one big gun.

16,1,2,0,4,2,7,1,2,14

import : only (ice-9 rdelim) read-line
         only (srfi :26) cut
         only (srfi :1) list-index list-ref

{{{read-numbers-from-csv-line}}}

define crabs
  read-numbers-from-csv-line
    . "advent-of-wisp-code-2021-d7p1-example-input.dat"

define min-position : apply min crabs
define max-position : apply max crabs

define possible-positions
  iota (+ 1 {max-position - min-position}) min-position

define : fuel-cost target-position crabs
  define : fuel-cost crab 
    abs {crab - target-position}
  apply + : map fuel-cost crabs

define costs : map (cut fuel-cost <> crabs) possible-positions
define min-cost : apply min costs
define ideal-position
  list-ref possible-positions
    list-index (cut equal? min-cost <>) costs

display min-cost

Day 7, Puzzle 2: Align Stingy Crab Guns

arne@fluss (Dr. Arne Babenhauserheide) — Thu, 09 Dec 2021 20:15:00 +0100

Movement cost now increases by one per step. Step 1 is 1. Step 2 costs 2, so it is 3. Formula: (step * (step + 1)) / 2

16,1,2,0,4,2,7,1,2,14

import : only (ice-9 rdelim) read-line
         only (srfi :26) cut
         only (srfi :1) list-index list-ref

{{{read-numbers-from-csv-line}}}

define crabs
  read-numbers-from-csv-line
    . "advent-of-wisp-code-2021-d7p1-example-input.dat"

define min-position : apply min crabs
define max-position : apply max crabs

define possible-positions
  iota (+ 1 {max-position - min-position}) min-position

define : fuel-cost target-position crabs
  define : distance crab 
    abs {crab - target-position}
  define : cost crab
    define dist : distance crab
    * 1/2 dist {dist + 1}
  apply + : map cost crabs

define costs : map (cut fuel-cost <> crabs) possible-positions
define min-cost : apply min costs
define ideal-position
  list-ref possible-positions
    list-index (cut equal? min-cost <>) costs

display : format #f "position: ~a, cost: ~a" ideal-position min-cost

Day 8, Puzzle 1: Which numbers are shown?

arne@fluss (Dr. Arne Babenhauserheide) — Wed, 15 Dec 2021 00:26:00 +0100

I’m late on this, because a brief solution wasn’t directly obvious and I didn’t have much time.

I have 10 patterns and 4 displays. Four numbers use a unique number of connections:

1: 2
4: 4
7: 3
8: 7

So basically I just need to count occurence of length of strings.

Input:

be cfbegad cbdgef fgaecd cgeb fdcge agebfd fecdb fabcd edb | fdgacbe cefdb cefbgd gcbe
edbfga begcd cbg gc gcadebf fbgde acbgfd abcde gfcbed gfec | fcgedb cgb dgebacf gc
fgaebd cg bdaec gdafb agbcfd gdcbef bgcad gfac gcb cdgabef | cg cg fdcagb cbg
fbegcd cbd adcefb dageb afcb bc aefdc ecdab fgdeca fcdbega | efabcd cedba gadfec cb
aecbfdg fbg gf bafeg dbefa fcge gcbea fcaegb dgceab fcbdga | gecf egdcabf bgf bfgea
fgeab ca afcebg bdacfeg cfaedg gcfdb baec bfadeg bafgc acf | gebdcfa ecba ca fadegcb
dbcfg fgd bdegcaf fgec aegbdf ecdfab fbedc dacgb gdcebf gf | cefg dcbef fcge gbcadfe
bdfegc cbegaf gecbf dfcage bdacg ed bedf ced adcbefg gebcd | ed bcgafe cdgba cbgef
egadfb cdbfeg cegd fecab cgb gbdefca cg fgcdab egfdb bfceg | gbdfcae bgc cg cgb
gcafb gcf dcaebfg ecagb gf abcdeg gaef cafbge fdbac fegbdc | fgae cfgab fg bagce

Code:

import : only (ice-9 rdelim) read-line
         srfi :9 records
         only (srfi :26) cut
         only (srfi :1) second
define : split-result-into-length line
  map string-length
    string-tokenize
      second : string-split line #\|
      . char-set:letter

{{{map-over-lines}}}

define input
  apply append
    map-over-lines split-result-into-length
      . "advent-of-wisp-code-2021-d8p1-example-input.dat"

define counter : make-vector 8 0

for-each : λ(len) : vector-set! counter len : + 1 : vector-ref counter len
         . input  

display
  apply +
    map (cut vector-ref counter <>)
      list 2 4 3 7

Day 8, Puzzle 2: Which numbers are shown?

arne@fluss (Dr. Arne Babenhauserheide) — Thu, 16 Dec 2021 02:20:00 +0100

Now do the full mapping.

Use the left-hand patterns to recover the configuration.

import : only (ice-9 rdelim) read-line
         srfi :9 records
         only (srfi :26) cut
         only (srfi :1) first second fold assoc
         only (rnrs lists (6)) find
;;; problem definition
;; the numbers with letters for fields. The fields got scrambled.
;;   0:      1:      2:      3:      4:
;;  aaaa    ....    aaaa    aaaa    ....
;; b    c  .    c  .    c  .    c  b    c
;; b    c  .    c  .    c  .    c  b    c
;;  ....    ....    dddd    dddd    dddd
;; e    f  .    f  e    .  .    f  .    f
;; e    f  .    f  e    .  .    f  .    f
;;  gggg    ....    gggg    gggg    ....  
;; 
;;   5:      6:      7:      8:      9:
;;  aaaa    aaaa    aaaa    aaaa    aaaa
;; b    .  b    .  .    c  b    c  b    c
;; b    .  b    .  .    c  b    c  b    c
;;  dddd    dddd    ....    dddd    dddd
;; .    f  e    f  .    f  e    f  .    f
;; .    f  e    f  .    f  e    f  .    f
;;  gggg    gggg    ....    gggg    gggg  

;; define number-by-length deciders
define : 1? string
  = 2 : string-length string
define : 7? string
  = 3 : string-length string
define : 4? string
  = 4 : string-length string
define : 8? string
  = 7 : string-length string
;; 6 numbers share lengths
define : 2-or-3-or-5? string
  = 5 : string-length string
define : 0-or-6-or-9? string
  = 6 : string-length string


;;; get the input
;; returns (pattern-part result-part)
define : split-into-strings line
  map : cut string-tokenize <> char-set:letter
    string-split line #\|

{{{map-over-lines}}}

define input-strings
  map-over-lines split-into-strings
    . "advent-of-wisp-code-2021-d8p1-example-input.dat"

define input-charsets
  map
    λ(line)
      map : λ(x) : map string->char-set x
          . line
    . input-strings


;;; Calculate and apply the de-scrambling and calculation per line
define : process-one-line line-strings line-charsets
  ;; identify the char-sets for digits of unique length
  define pattern-strings
    first line-strings
  define result-charsets
    second line-charsets
  define : find-matching-charsets string-matches? pattern-strings
           fold
             λ(string prev)
               append
                 if : string-matches? string
                   list : string->char-set string
                   . '()
                 . prev
             . '() pattern-strings
  define one : first : find-matching-charsets 1? pattern-strings
  define four : first : find-matching-charsets 4? pattern-strings
  define seven : first : find-matching-charsets 7? pattern-strings
  define eight : first : find-matching-charsets 8? pattern-strings
  define zero-or-six-or-nine
    find-matching-charsets 0-or-6-or-9? pattern-strings

  define six
    find : λ(x) : not : char-set<= one x
         . zero-or-six-or-nine
  define zero-or-nine
    filter : λ(x) : char-set<= one x
         . zero-or-six-or-nine
  define nine
    find : λ(x) : char-set<= four x
      . zero-or-nine
  define zero
    find : λ(x) : not : char-set<= four x
      . zero-or-nine
  define two-or-three-or-five
    find-matching-charsets 2-or-3-or-5? pattern-strings
  define three
    find : λ(x) : char-set<= one x
         . two-or-three-or-five
  define five
    find : λ(x) : char-set<= x nine
         delete three two-or-three-or-five
  define two
    first : delete five : delete three two-or-three-or-five

  define charset-to-number
    list
      cons zero 0
      cons one 1
      cons two 2
      cons three 3
      cons four 4
      cons five 5
      cons six 6
      cons seven 7
      cons eight 8
      cons nine 9

  string->number
    string-join
      map number->string
        map : λ(x) : cdr : assoc x charset-to-number char-set=
            . result-charsets
      . ""

write : apply + : map process-one-line input-strings input-charsets

This one was long, far longer than I would have liked. And with much more logic coming in from me instead of the program. I wonder if micro-/minikanren or Prolog would provide for a nicer solution.

Day 9, Puzzle 1: Avoid smoke-sinks

arne@fluss (Dr. Arne Babenhauserheide) — Thu, 16 Dec 2021 02:20:00 +0100

Find low points in height-map.

import : only (ice-9 rdelim) read-line
         only (ice-9 pretty-print) pretty-print
         only (srfi :1) fold

{{{map-over-lines}}}

define : string-letters->numbers line
    . "turn every letter in the string into the base10 number it represents"
    map string->number : map string : string->list line

define input
  list->vector
    map-over-lines
      λ (line) : list->vector : string-letters->numbers line
      . "advent-of-wisp-code-2021-d9p1-example-input.dat"

define len-y : 1- : vector-length input
define len-x : 1- : vector-length : vector-ref input 0

define : at vec x y
  vector-ref (vector-ref input y) x

define : low-point? input x y
  define up : and {y > 0} {y - 1}
  define down : and {y < len-y} {y + 1}
  define left : and {x > 0} {x - 1}
  define right : and {x < len-x} {x + 1}
  define val : at input x y
  define : y-lowerequal y
    >= val : at input x y
  define : x-lowerequal x
    >= val : at input x y
  not ;; no accessible point may be lower or equal
   or : and=> up y-lowerequal
        and=> down y-lowerequal
        and=> left x-lowerequal
        and=> right x-lowerequal

define risk-levels
 map
  λ(y)
    map : λ(x) : if (low-point? input x y) (+ 1 (at input x y)) 0
             iota : + 1 len-x
  iota : + 1 len-y

pretty-print 
  map : λ(x) : string-join (map number->string x) ""
    . risk-levels

pretty-print : apply + : map (λ(row) (apply + row)) risk-levels

Day 9, Puzzle 2: Discover Smoke Lakes

arne@fluss (Dr. Arne Babenhauserheide) — Sat, 18 Dec 2021 02:04:00 +0100

Expand each low-point while the ground gets higher, except if it reaches 9.

import : only (ice-9 rdelim) read-line
         only (ice-9 pretty-print) pretty-print
         only (srfi :1) fold every any lset-difference delete-duplicates take
         only (srfi :26) cut
         ice-9 string-fun

{{{map-over-lines}}}

define : string-letters->numbers line
    . "turn every letter in the string into the base10 number it represents"
    map string->number : map string : string->list line

define input
  list->vector
    map-over-lines
      λ (line) : list->vector : string-letters->numbers line
      . "advent-of-wisp-code-2021-d9p1-example-input.dat"

define len-y : 1- : vector-length input
define len-x : 1- : vector-length : vector-ref input 0

define : at vec x y
  vector-ref (vector-ref input y) x

define : around x y
  . "Get all points around the coordinate"
  define up : and {y > 0} {y - 1}
  define down : and {y < len-y} {y + 1}
  define left : and {x > 0} {x - 1}
  define right : and {x < len-x} {x + 1}
  delete #f
    list
      and up : cons x up
      and down : cons x down
      and left : cons left y
      and right : cons right y

define : low-point? input x y known
  define val : at input x y
  define : part-of-area? x y
    or : member (cons x y) known
      < val : at input x y
  and {val < 9}
    every : λ(point) : part-of-area? (car point) (cdr point)
        around x y

define low-points
  filter : λ(x) : low-point? input (car x) (cdr x) '()
    apply append
      map : λ(y) : map (cut cons <> y) : iota : + 1 len-x
        iota : + 1 len-y

define : next x y known
  define : open? point
    and : not : member point known
        . point
  delete #f : map open? : around x y

define : expand-area area
  define : expands-basin? val new
    define newval : at input (car new) (cdr new)
    < val newval 9    
  define : expand-point point
    define val : at input (car point) (cdr point)
    cons point
      filter (cut expands-basin? val <>)
        next (car point) (cdr point) area
  delete-duplicates : apply append : map expand-point area

define areas
  let loop : : areas : map list low-points
    define open-points
      lset-difference equal?
        apply append
          map expand-area areas
        apply append areas
    if : null? open-points
       . areas
       loop : map expand-area areas


define : basin-value x y
    if : any identity : map (cut member (cons x y) <>) areas
       at input x y
       . 0

define area-levels
 map
  λ(y) : map (cut basin-value <> y) : iota : + 1 len-x
  iota : + 1 len-y

pretty-print 
  map
    λ(x)
      string-replace-substring
        string-join (map number->string x) ""
        . "0" " "
    . area-levels

pretty-print : apply * : take (sort (map length areas) >) 3

This is much too long for my taste, but I don’t see how to make it shorter.

Day 10, Puzzle 1: Pick Wrongly Paired Parens

arne@fluss (Dr. Arne Babenhauserheide) — Sun, 19 Dec 2021 04:23:00 +0100

Input:

[({(<(())[]>[[{[]{<()<>>
[(()[<>])]({[<{<<[]>>(
{([(<{}[<>[]}>{[]{[(<()>
(((({<>}<{<{<>}{[]{[]{}
[[<[([]))<([[{}[[()]]]
[{[{({}]{}}([{[{{{}}([]
{<[[]]>}<{[{[{[]{()[[[]
[<(<(<(<{}))><([]([]()
<{([([[(<>()){}]>(<<{{
<{([{{}}[<[[[<>{}]]]>[]]

Goal: Read the code and find a wrongly paired paren.

First parenthesis tools:

;; snippet: {{{paren-tools}}}
define opening : string->char-set "([{<"
define paired
  '
    #\( . #\)
    #\[ . #\]
    #\{ . #\}
    #\< . #\>

define : opening? char
  char-set-contains? opening char
define : valid-char? letter-stack char
  or : opening? char
       equal? char : car letter-stack
define : process letter-stack char
  if : opening? char
    cons (assoc-ref paired char) letter-stack
    cdr letter-stack

Now give the correct error codes:

import : only (ice-9 rdelim) read-line
         only (ice-9 pretty-print) pretty-print
         only (srfi :26) cut

{{{map-over-lines}}}
;; opening paired opening? valid-char? process
{{{paren-tools}}}

define input
  map-over-lines : λ (x) x ;; unchanged line, identity
    . "advent-of-wisp-code-2021-d10p1-example-input.dat"

define error-values
  '
    #\) . 3
    #\] . 57
    #\} . 1197
    #\> . 25137

define : find-syntax-error line
  let loop : (letter-stack '()) (open (string->list line))
    cond
      : null? open
        . #f
      : valid-char? letter-stack (car open)
        loop : process letter-stack (car open)
               cdr open
      else
        car open

pretty-print
  apply + 
    map (cut assoc-ref error-values <>)
      delete #f
        map find-syntax-error input

Day 10, Puzzle 2: Cleanly close closables

arne@fluss (Dr. Arne Babenhauserheide) — Tue, 28 Dec 2021 00:00:00 +0100

Close unclosed parentheses, keep score of the kind of paren closed, multiplying the previous by 5 for each new error.

import : only (ice-9 rdelim) read-line
         only (ice-9 pretty-print) pretty-print
         only (srfi :26) cut
         only (srfi :1) fold

{{{map-over-lines}}}
;; opening paired opening? valid-char? process
{{{paren-tools}}}

define input
  map-over-lines : λ (x) x ;; unchanged line, identity
    . "advent-of-wisp-code-2021-d10p1-example-input.dat"

define closing-values
  '
    #\) . 1
    #\] . 2
    #\} . 3
    #\> . 4

define : score numbers
  define : add-number number prev
    + number : * 5 prev
  fold add-number 0 numbers

define : find-syntax-error line
  let loop : (letter-stack '()) (open (string->list line))
    cond
      : null? open
        score : map (cut assoc-ref closing-values <>) letter-stack
      : valid-char? letter-stack (car open)
        loop : process letter-stack (car open)
               cdr open
      else #f

pretty-print
  let : : res : delete #f : map find-syntax-error input
    list-ref (sort res <) : floor/ (length res) 2

Day 11, Puzzle 1: Flashing Octopuses

arne@fluss (Dr. Arne Babenhauserheide) — Tue, 28 Dec 2021 00:00:00 +0100

Every step each number is increased by 1. If it is higher than 9, it flashes, and the up to 8 sourrounding numbers increase by 1, too, also flashing if they become higher than 9.

Flashing logic:

;; snippet: {{{flashing-logic}}}
define input
  map : λ (x) (map string->number (map string x))
    map-over-lines string->list "advent-of-wisp-code-2021-d11p1-example-input.dat"

define : 1++ arr
  . "increase every arr value by 1"
  map : λ (x) : map 1+ x
      . arr

define : flash-indizes arr
  define : flash y
    define L : list-ref arr y
    map : cut cons y <>
      delete #f
        map
          λ(idx)
              let : : num : list-ref L idx
                  ;; 99 means "already flashing"
                  and {num > 9} {num < 99} idx
          iota : length L
  apply append : map flash : iota : length arr


define : flash arr
  . "return as values: changed arr and count of flashing"
  let reflash : : count 0
    define indizes : flash-indizes arr
    define : apply-flash index
      define y : car index
      define x : cdr index
      define line : list-ref arr y
      define len-line-1 : 1- : length line
      define len-arr-1 : 1- : length arr
      ;; all indizes around the current index
      ;; but only inside the limits
      define around
        delete #f
          list ;; #f if outside the limits
             and {x > 0}
                 cons {x - 1} y
             and {x < len-line-1}
                 cons {x + 1} y
             and {y < len-arr-1}
                 cons x {y + 1}
             and (and {y < len-arr-1} {x > 0})
                 cons {x - 1} {y + 1}
             and (and {y < len-arr-1} {x < len-line-1})
                 cons {x + 1} {y + 1}
             and {y > 0}
                 cons x {y - 1}
             and (and {y > 0} {x > 0})
                 cons {x - 1} {y - 1}
             and (and {y > 0} {x < len-line-1})
                 cons {x + 1} {y - 1}
      for-each
        λ : x y
          let : : line : list-ref arr y
            list-set! line x : 1+ : list-ref line x
            list-set! arr y line
        map car around
        map cdr around
      ;; 99 means "already flashing"
      list-set! line x 99
    if : null? indizes
       ;; use multiple values return as a side-channel 
       ;; to report the number of flashes (as count)
       values
         map : λ (line) : map (λ (num) (if {num >= 99} 0 num)) line
             . arr
         . count
       begin
         for-each apply-flash indizes
         reflash : + count : length indizes

define : step arr
  flash : 1++ arr

Put it together:

import : only (ice-9 rdelim) read-line
         only (ice-9 pretty-print) pretty-print
         only (srfi :26) cut
         only (srfi :1) fold first second
         only (srfi :11) let-values

{{{map-over-lines}}}
;; input, step
{{{flashing-logic}}}

define flash-counter 0

display
  string-join
    map : λ (line) : string-join (map number->string line) ""
      fold 
         λ (num prev)
           let-values : : (arr count) (step prev)
             set! flash-counter {flash-counter + count}
             . arr
         . input
         iota 100
    . "\n"
newline
display flash-counter

Day 11, Puzzle 2: Flash together, right now

arne@fluss (Dr. Arne Babenhauserheide) — Wed, 26 Jan 2022 22:47:00 +0100

Find the step where all flashh together.

Use a local return to stop the fold when I find the flashing.

import : only (ice-9 rdelim) read-line
         only (ice-9 pretty-print) pretty-print
         only (ice-9 control) call/ec ; non-local exit -> return
         only (srfi :26) cut
         only (srfi :1) fold first second
         only (srfi :11) let-values

{{{map-over-lines}}}
;; input, step
{{{flashing-logic}}}

display
  string-join
    map : λ (line) : string-join (map number->string line) ""
      ;; introduce a return statement locally
      call/ec
        λ : return
          fold
             λ (num prev)
               let-values : : (arr count) (step prev)
                 when : = 0 : apply + : map (λ(x) (apply + x)) arr
                   return : append arr `((,(+ 1 num)))
                 . arr
             . input
             iota 1999
    . "\n"

Day 12, Puzzle 1: All the exciting trails

arne@fluss (Dr. Arne Babenhauserheide) — Sat, 14 May 2022 07:04:00 +0200

Find all paths through the cave that visit small caves only once.

I enter at start, I exit at end, I’m only allowed to enter uppercase rooms more than once. These are the edges (the connections) between rooms that give 10 paths:

start-A
start-b
A-c
A-b
b-d
A-end
b-end

And a larger input with 226 paths:

fs-end
he-DX
fs-he
start-DX
pj-DX
end-zg
zg-sl
zg-pj
pj-he
RW-he
fs-DX
pj-RW
zg-RW
start-pj
he-WI
zg-he
pj-fs
start-RW

import : only (ice-9 rdelim) read-line
         only (ice-9 pretty-print) pretty-print
         only (srfi :26) cut
         only (srfi :1) first second append-map remove

{{{map-over-lines}}}

define input
  map-over-lines
    cut string-split <> #\-
    . "advent-of-wisp-code-2021-d12p1-example-input-larger.dat"

define : undirected edges
  append-map : λ (edge) : list edge (reverse edge)
    . edges

define : all-paths edges
  let loop : (path '("start")) (edges (undirected edges))
    define matching-edges
      ;; keep the edges that match the first element of the path
      filter : λ (edge) : equal? (first edge) (first path)
        . edges
    define remaining-edges
      ;; remove edges that match the first element of the path
      ;; if we’re in a lowercase field, otherwise keep all
      if : string-every char-set:upper-case (first path)
         . edges
         remove : λ (edge) : equal? (first edge) (first path)
           . edges
    define extended-paths-for-matching
      ;; create one extended path for each matching edge
      map : λ (edge) : cons (second edge) path
          . matching-edges
    define : process-one extended-path
      loop extended-path  remaining-edges
    cond
      : equal? "end" : first path
        list : string-join (reverse path) ","
      : null? edges
        list ;; empty, because we did not reach the end
      else
        append-map process-one extended-paths-for-matching

pretty-print : length : all-paths input

Day 12, Puzzle 2: Accept boredom just once

arne@fluss (Dr. Arne Babenhauserheide) — Sat, 14 May 2022 07:04:00 +0200

Find all paths through the cave that visit small caves only once; except that you may visit one of them twice.

I enter at start, I exit at end, I’m allowed to enter uppercase rooms more than once. These are the edges (the connections) between rooms that give 36 paths:

start-A
start-b
A-c
A-b
b-d
A-end
b-end

And a larger input with 3509 paths:

fs-end
he-DX
fs-he
start-DX
pj-DX
end-zg
zg-sl
zg-pj
pj-he
RW-he
fs-DX
pj-RW
zg-RW
start-pj
he-WI
zg-he
pj-fs
start-RW

This looks harmless, but it originally pushed my non-optimized code to its limits and got my CPU to suffer. It could benefit a lot from a functional dictionary datastructure instead of a linear-update alist. But still, it’s nice to my memory and already did the job.

After finishing it, I optimized it to avoid doing work twice, so this now has reasonable speed.

import : only (ice-9 rdelim) read-line
         only (ice-9 pretty-print) pretty-print
         only (srfi :26) cut
         only (srfi :1) first second append-map remove

{{{map-over-lines}}}

define input
  map-over-lines
    cut string-split <> #\-
    . "advent-of-wisp-code-2021-d12p1-example-input.dat"

define : undirected edges
  append-map : λ (edge) : list edge (reverse edge)
    . edges

define : lower? str
  string-every char-set:lower-case str

define : all-paths edges
  let loop : (path '("start")) (edges (undirected edges)) (bored? #f)
    define : twice-in-path?
      if : member (first path) (cdr path)
         . #t #f
    define path-head : first path
    define start? : equal? path-head "start"
    define end? : equal? path-head "end"
    define lowercase? : lower? path-head
    define boring? : and lowercase? : twice-in-path?
    define matching-edges
      ;; keep the edges that match the first element of the path
      filter : λ (edge) : equal? path-head : first edge
        . edges
    define remaining-edges
      ;; remove edges that match the first element of the path 
      ;; if we’re in a lowercase field, otherwise keep all
      cond
        boring? ;; remove the current edge and all lowercase path elements
          let : : lowercase-path-elements : filter lower? path
            remove : λ (edge) : member (first edge) lowercase-path-elements
              . edges
        : or  start? : and bored? lowercase?
          remove : λ (edge) : equal? path-head : first edge
           . edges
        else edges ;; keep all
    define extended-paths-for-matching
      ;; create one extended path for each matching edge
      map : λ (edge) : cons (second edge) path
          . matching-edges
    define : process-one extended-path
      loop extended-path  remaining-edges : or bored? boring?
    cond
      end?
        list : string-join (reverse path) ","
      : null? edges
        list ;; empty, because we did not reach the end
      : and start? : not : null? : cdr path
        list ;; empty, because revisiting start is forbidden
      else
        append-map process-one extended-paths-for-matching

pretty-print : length : all-paths input

Profiling this, gives the expected results: remove, string-every and lower? are the most expensive actions, since they are the inner loops. To profile it, just copy it into a wisp shell and then run:

,profile pretty-print : length : all-paths input .

The output with profile looks like this:

3509
%     cumulative   self             
time   seconds     seconds  procedure
 26.47      0.16      0.16  string-every-c-code
 14.71      0.16      0.09  remove
 14.71      0.11      0.09  lower?
 11.76      0.07      0.07  :50:39
  8.82      0.62      0.05  :31:38:loop
  8.82      0.07      0.05  :71:0
  2.94      0.38      0.02  filter
  2.94      0.02      0.02  car
  2.94      0.02      0.02  %after-gc-thunk
  2.94      0.02      0.02  string-join
  2.94      0.02      0.02  procedure?
  0.00     15.13      0.00  srfi/srfi-1.scm:584:5:map1
  0.00      5.55      0.00  srfi/srfi-1.scm:672:0:append-map
  0.00      0.62      0.00  anon #x1752678
  0.00      0.02      0.00  anon #xe3d160
  0.00      0.02      0.00  ice-9/boot-9.scm:340:2:string-every
---
Sample count: 34
Total time: 0.621091946 seconds (0.093273494 seconds in GC)

Since string-every, remove and lower? already have 0.34s — more than half the runtime — I won’t optimize further. A better datastructure could get rid of most of the cost of remove, and the lower? could be cached to save another 10% of the runtime, for example like this:

define lower?
  let : : cache '()
    lambda (str)
      let : : cached : assoc str cache
        if cached
          cdr cached
          let : : res : string-every char-set:lower-case str
            set! cache : cons (cons str res) cache
            . res

See, now I did optimize further, but I’ll stop here :-)

Have fun!

Day 13, Puzzle 1: Fold your password

arne@fluss (Dr. Arne Babenhauserheide) — Sat, 08 Oct 2022 09:50:00 +0200

Mirror points over a given axis.

6,10
0,14
9,10
0,3
10,4
4,11
6,0
6,12
4,1
0,13
10,12
3,4
3,0
8,4
1,10
2,14
8,10
9,0

fold along y=7
fold along x=5

Here I need to read two fields. I realize that with a modification of map-over-lines:

;; snippet: {{{map-over-lines-port}}}: an alternate map-over-lines
;; that takes a port and a terminator, so multiple fields can be read
import : only (ice-9 rdelim) read-line
         only (srfi :26) cut
         only (ice-9 optargs) define*
define* : map-over-lines/port fun port #:key (terminator eof-object?)
  define terminator?
    if : or  (procedure? terminator) (macro? terminator)
       . terminator
       cut equal? terminator <>
  let loop : (lines '()) (line (read-line port))
    if : terminator? line
      begin : reverse! lines
      loop : cons (fun line) lines
             read-line port

Also I need to draw coordinates on the commandline:

;; snippet: {{{draw-coordinates}}}
define : draw coordinates
  define xs : map first coordinates
  define ys : map second coordinates
  define len-x
    + 1 : apply max xs
  define len-y
    + 1 : apply max ys
  define pane
    let loop : (res '()) (rest-y len-y)
      if : zero? rest-y
         . res
         loop : cons (make-list len-x #\.) res
                - rest-y 1
  for-each : λ (x y) : list-set! (list-ref pane y) x #\#
             . xs ys
  string-join
    map : λ (sublist) : apply string sublist
       . pane
    . "\n"

And I need to read the coordinates and instructions and apply instructions:

;; snippet: {{{coordinates-and-instructions}}}
define-values : coordinates instructions
  let : : port : open-input-file "advent-of-wisp-code-2021-d13p1-example-input.dat"
    define coordinates
        map-over-lines/port
          λ (line) : map string->number : string-split line #\,
          . port
          . #:terminator "" ;; split by empty line
    define instructions
      map-over-lines/port
        cut string-split <> #\=
        . port
    values coordinates instructions

define : apply-instruction coordinates instruction
  define instruction-value : string->number : second instruction
  define is-y : equal? "fold along y" : first instruction
  define : process-one coordinate
    define val : if is-y (second coordinate) (first coordinate)
    define new-val
      if {val < instruction-value} val
         - {instruction-value * 2} val
    if is-y
      list (first coordinate) new-val
      list new-val (second coordinate)
  map process-one coordinates

Finally: actually apply one instruction, and draw the coordinates:

import : only (ice-9 rdelim) read-line
         only (ice-9 pretty-print) pretty-print
         only (ice-9 optargs) define*
         only (srfi :26) cut
         only (srfi :1) first second append-map remove

{{{map-over-lines-port}}}
{{{draw-coordinates}}}
{{{coordinates-and-instructions}}}

display
  string-count : draw  : apply-instruction coordinates : car instructions
    . #\#

I did too much when solving this: I directly implemented folding to the end, because I did not read the final paragraph carefully enough.

I took that additional part out again for the code above. It’s in the code for part 2.

Day 13, Puzzle 2: Fold your password

arne@fluss (Dr. Arne Babenhauserheide) — Sun, 16 Oct 2022 10:18:00 +0200

Complete folding, then use the letters as result (in the example: O). The only changees are creating folded by let-recursion over the instructions and printing the drawing instead of the count.

import : only (ice-9 rdelim) read-line
         only (ice-9 pretty-print) pretty-print
         only (ice-9 optargs) define*
         only (srfi :26) cut
         only (srfi :1) first second append-map remove

{{{map-over-lines-port}}}
{{{draw-coordinates}}}
{{{coordinates-and-instructions}}}

define folded
  let loop : (coords coordinates) (instrs instructions)
    if : null? instrs
       . coords
       loop : apply-instruction coords : car instrs
              cdr instrs

display : draw folded

And since it just calls for it, let’s follow Scheme tradition and implement map-over-lines on top of map-over-lines/port:

{{{map-over-lines-port}}}
define : map-over-lines fun filename
  define port : open-input-file filename
  define lines : map-over-lines/port fun port
  close port
  . lines

This closes the port explicitly. Without that, closing is delayed until garbage-collection which could exhaust file descriptors if I open many files in a very short time.

Day 14, Puzzle 1: Polymer-synthesis

arne@fluss (Dr. Arne Babenhauserheide) — Fri, 11 Nov 2022 08:00:00 +0100

Insert characters inside matching pairs.

The first line is the initial sequence. A second block gives a lookup table: insert the character in the middle of matching pairs.

NNCB

CH -> B
HH -> N
CB -> H
NH -> C
HB -> C
HC -> B
HN -> C
NN -> C
BH -> H
NC -> B
NB -> B
BN -> B
BB -> N
BC -> B
CC -> N
CN -> C

import : only (srfi :1) take first second fold
         only (ice-9 string-fun) string-replace-substring
{{{map-over-lines-port}}}

define input
  let : : port : open-input-file "advent-of-wisp-code-2021-d14p1-example-input.dat"
    define init
        first : map-over-lines/port string->list port #:terminator ""
    define : split-line line
        define key-value
          string-split : string-replace-substring line " -> " ";"
            . #\;
        cons : string->list : first key-value
               first : string->list : second key-value
    define rules
        map-over-lines/port split-line port
    list init rules

define : apply-rule left right prev rules
  define matching : assoc (list left right) rules
  define prev-with-match
      if matching : cons (cdr matching) prev
         . prev
  cons right prev-with-match

define : apply-rules letters rules
  reverse!
    fold (cut apply-rule <> <> <> rules)
      take letters 1 ;; initial value: first letter
      . letters ;; left letters in pairs
      cdr letters ;; shifted => right right letters

define : apply-rules-n-times N letters rules
  let loop : (N N) (letters letters)
    if : zero? N
       . letters
       loop {N - 1}
         apply-rules letters rules

define result-string
  apply string
    apply-rules-n-times 10 (first input) (second input)

define all-possible-letters
   let : : with-duplicates : append (first input) : map cdr (second input)
     ;; hack: use char-set conversion to remove duplicates
     char-set->list
       list->char-set with-duplicates

define occurrences
  map (cut string-count result-string <>) all-possible-letters

let
  : maxOcc : apply max occurrences
    minOcc : apply min occurrences
  display {maxOcc - minOcc}

This is pretty slow. At 20 steps it takes two seconds to calculate 3 million elements and at 22 steps it’s already at 6 seconds for 12 million elements.

The second part needs 40 steps. I must change the approach.

Also I’m still kind of annoyed that reading the input usually takes a too large fraction of the total code. I have the feeling that some primitives are too low level in Scheme — need to fix that.

Consequence: I just wrote string-split-substring and if/once the tests pass, I’ll submit it to Guile to ease the pain and use it in the next step.

Day 14, Puzzle 2: predict the element disbalance

arne@fluss (Dr. Arne Babenhauserheide) — Fri, 11 Nov 2022 20:40:00 +0100

The answer actually only needs the counts of letters, so why should I actually synthesize the polymer-string? Just having letter-bigrams with their counts should avoid the algorithmic explosion.

But first let’s simplify the string input:

;; snippet: {{{string-split-substring}}}
define : string-split-substring str substring
  if : equal? substring ""
      map string : string->list str ;; split each letter
      let : : sublen : string-length substring
        let lp : (start 0) (res '())
          cond
           (string-contains str substring start) =>
             λ : end
                 lp (+ end sublen) (cons (substring/shared str start end) res)
           else
             reverse! : cons (substring/shared str start) res

This allows to simplify reading the input a bit:

;; before
define key-value
  string-split : string-replace-substring line " -> " ";"
    . #\;
;; after
define key-value
  string-split-substring line " -> "

To fix the algorithmic explosion, I’ll just not generate the polymer: since nature already does it, why should I do it myself when all I need are the resulting statistics? :-)

The simplest option is to use hash-maps and global mutation.

import : only (srfi :1) take first second third fold drop-right
         only (ice-9 string-fun) string-replace-substring
         only (srfi :26) cut

{{{map-over-lines-port}}}
{{{string-split-substring}}}

define letters : make-hash-table
define : letters-inc! key value
  hash-set! letters key : + value : or (hash-ref letters key) 0

define pairs : make-hash-table
define : pairs-inc! key value
  hash-set! pairs key : + value : or (hash-ref pairs key) 0
define : pairs-dec! key value
  pairs-inc! key : - value

define input
  let : : port : open-input-file "advent-of-wisp-code-2021-d14p1-example-input.dat"
    ;; get the letters as before
    define init
        first : map-over-lines/port string->list port #:terminator ""
    ;; get the rules as before
    define : split-line line
        define key-value
          string-split-substring line " -> "
        cons : string->list : first key-value
               first : string->list : second key-value
    define rules
        map-over-lines/port split-line port

    ;; split the letters into pairs
    define init-pairs
        map cons 
          drop-right init 1
          cdr init
    ;; track letters and pairs in the global hash-maps
    for-each (cut letters-inc! <> 1) init
    for-each (cut pairs-inc! <> 1) init-pairs
    . rules

define : apply-rule left right weight rules
  define pair : cons left right
  define matching : assoc (list left right) rules
  when matching
    let : : middle : cdr matching
      pairs-dec! pair weight
      pairs-inc! (cons left middle) weight
      pairs-inc! (cons middle right) weight
      letters-inc! middle weight

define : apply-rules rules
  ;; get the items to fold over (avoid mutation while folding)
  define letters-and-weights
    hash-map->list : lambda (key value) : list (car key) (cdr key) value
      . pairs
  for-each (cut apply-rule <> <> <> rules)
    map first letters-and-weights ;; first
    map second letters-and-weights ;; second
    map third letters-and-weights ;; weight

define : apply-rules-n-times N rules
  ;; simplified: no need for return values
  for-each : λ(x) : apply-rules rules
    iota N

apply-rules-n-times 40 input

define occurrences
  hash-map->list : λ(key value) value
    . letters
let
  : maxOcc : apply max occurrences
    minOcc : apply min occurrences
  display {maxOcc - minOcc}

This now solves my speed problems: It takes 7 seconds for 10k steps. The version from part 1 could only do 22 steps in that time.

Day 15, Puzzle 1: Path planning

arne@fluss (Dr. Arne Babenhauserheide) — Mon, 14 Nov 2022 00:31:00 +0100

Now we’re getting serious. Find the path with the lowest aggregated cost of fields to enter. I need the globally best path, so the obvious choice is Dijkstra's algorithm.

For Dijkstra I need a set of unvisited nodes and a set of visited nodes. For simplicity I’ll start with plain lists of lists, the most direct translation of the task, though that will not scale, so I will likely have to change to a better datastructure in part 2.

The datastructure is a simple list of lists, defined by its accessors xy-ref and xy-set!:

;;; snippet: {{{p15-xy-ref-and-set}}}
define : xy-ref arr x y
  list-ref : list-ref arr y
    . x
define : xy-set! arr x y val
  list-set! : list-ref arr y
    . x val

In this naive approach, calculating the neighbors just looks around in the datastructure.

;;; snippet: {{{d15-neighbors}}}
define : neighbors x y
  define dpos
    ' (-1 0) (0 -1) (+1 0) (0 +1)
  delete #f
    map
      λ : dx dy
        let : (xx {x + dx}) (yy {y + dy})
          and {xx >= 0} {xx < len-x} {yy >= 0} {yy < len-y}
            pos {x + dx} {y + dy}
      map first dpos
      map second dpos

Positions are tracked as records with x and y and distances use a simple xy-structure:

;;; snippet: {{{d15-position-handling}}}
define-record-type 
  pos x y
  . pos?
  x pos-x
  y pos-y
;; Distances check x and y in a distances map:
define : distance node
  xy-ref distances (pos-x node) (pos-y node)
define : distance- A B
  <
    distance A
    distance B
define : calculate-distance node current-distance
  define X : pos-x node
  define Y : pos-y node
  define path-cost : xy-ref input X Y
  define known-distance : xy-ref distances X Y
  min known-distance {current-distance + path-cost}

Finding the closest node just iterates over all positions and keeps the unvisited one with the shortest distance.

;; snippet: {{{d15-closest-unvisited-simple}}}
define : find-closest-unvisited-node
  define len-x-1 {len-x - 1}
  define len-y-1 {len-y - 1}
  let loop : (x 0) (y 0) (closest-x 0) (closest-y 0) (closest-dist (inf))
    define dist : distance : pos x y
    define unvisited : not : xy-ref visited x y
    if : and unvisited {dist < closest-dist}
      loop x y x y dist
      cond
        : and {len-x-1 <= x} {len-y-1 <= y}
          if unvisited
            pos closest-x closest-y
            . #f
        {len-x-1 <= x}
          loop 0 {y + 1} closest-x closest-y closest-dist
        else : loop {x + 1} y closest-x closest-y closest-dist

And processing one node just means calculating and setting the distances of all its not yet visited neighbors:

;; snippet: {{{d15-visit-current-node-simple}}}
define : visit-current-node
  define neigh ;; all unvisited neighbors
    remove : λ (node) : xy-ref visited (pos-x node) (pos-y node)
      neighbors (pos-x current-node) (pos-y current-node)
  define current-distance
    xy-ref distances (pos-x current-node) (pos-y current-node)
  for-each
    λ : node
      . #f
      xy-set! distances
         pos-x node
         pos-y node
         calculate-distance node current-distance
    . neigh
  xy-set! visited (pos-x current-node) (pos-y current-node) #t
  and=> (find-closest-unvisited-node) : cut set! current-node <>

To put it all together:

import : only (ice-9 rdelim) read-line
         only (ice-9 pretty-print) pretty-print
         only (ice-9 optargs) define*
         only (srfi :26) cut
         only (srfi :9) define-record-type
         only (srfi :1) first second append-map remove

{{{map-over-lines}}}
{{{string-split-substring}}}

;; use the new string-split-substring function
define : line->numbers line
  map string->number : string-split-substring line ""

define input
  map-over-lines line->numbers "advent-of-wisp-code-2021-d15p1-example-input.dat"

define len-y : length input
define len-x : length (list-ref input 0)

{{{p15-xy-ref-and-set}}}

define visited
  map : λ(y) : map (λ(x) #f) : iota len-x
        iota len-y
define distances
  map : λ(y) : map (λ(x) (inf)) : iota len-x
        iota len-y
;; init the risk of the first node as 0
xy-set! distances 0 0 0

{{{d15-position-handling}}}
{{{d15-neighbors}}}

define initial-node  : pos 0 0
define target-node : pos {len-x - 1} {len-y - 1}
define current-node initial-node

{{{d15-closest-unvisited-simple}}}

{{{d15-visit-current-node-simple}}}

while : visit-current-node
  . #f

;; Now the cost of all shortest paths to all nodes is known.
;; The lowest total risk is just the distance to the target
pretty-print : distance target-node

That finished with the real input in less than one minute despite the sub-par datastructures used here.

Day 15, Puzzle 2: Larger path planning

arne@fluss (Dr. Arne Babenhauserheide) — Fri, 18 Nov 2022 00:33:00 +0100

As expected, the second task has a larger map. More exactly: a 25x larger map.

I need better datastructures. But the first step is profiling:

;; add here all the code before calling visit-current-node with the real code
,profile while (visit-current-node) #f

%     cumulative   self             
time   seconds     seconds  procedure
 71.06     27.98     27.98  list-ref
 13.18     39.19      5.19  find-closest-unvisited-node
  6.16      2.43      2.43  distance
  5.95     15.86      2.34  xy-ref
  3.38      1.33      1.33  %after-gc-thunk
  0.09     39.35      0.03  visit-current-node
  0.04     39.38      0.02  anon #x18f2be8
  0.04      0.02      0.02  :82:0
  0.04      0.02      0.02  xy-set!
  0.04      0.02      0.02  ice-9/boot-9.scm:812:0:and=>
  0.00      1.33      0.00  anon #xf88160
  0.00      0.07      0.00  ice-9/boot-9.scm:253:2:for-each
  0.00      0.07      0.00  :112:0
  0.00      0.02      0.00  remove
  0.00      0.02      0.00  neighbors
  0.00      0.02      0.00  ice-9/boot-9.scm:230:5:map2

The culprits are obvious: list-ref and find-closest-unvisited-node.

The reason is clear: list-ref on the linked lists scales linearly: O(N). Once it is taken out, the next target for optimization is find-closest-unvisited-node: it currently looks at all nodes, so it also scales at best in the number of list-access: O(N) * list-ref. Since it is needed once per node in Dijkstra, the total algorithmic cost of this naive implementation is at least cubic:

O(N) * find-closest-unvisited-node * list-ref ~ O(N³)

But first: let’s check whether just switching to a vector is enough. With 25x the nodes, quadratic scaling would mean 625x the runtime. Vectors already reduce the runtime for the unchanged input to 17s, so this could finish in 3 hours.

Change: Use 25x the nodes:

;;;snippet: {{{d15p2-5x-input}}}
define : inc number
  let : : num {number + 1}
    if {num > 9} 1 num
define : inc-list L
  map inc L

define : 5x-line line
  define nextline line
  let loop :  (n 4) (line line)
    set! nextline : map inc nextline
    if : zero? n
       . line
       loop {n - 1} : append line nextline
define : 5x-arr arr
  define nextarr arr
  let loop :  (n 4) (arr arr)
    set! nextarr : map inc-list nextarr
    if : zero? n
       . arr
       loop {n - 1} : append arr nextarr
;; 5x each line
set! input : map 5x-line input
;; 5x the input, in lazy mode
set! input : 5x-arr input

Change: Use a vector. Change the data to vectors and adjust xy-ref and xy-set!.

;; snippet:  {{{d15p2-move-to-vector}}}
;; move to a vector
set! input
  list->vector : map list->vector input

define : xy-ref arr x y
  vector-ref : vector-ref arr y
    . x
define : xy-set! arr x y val
  vector-set! : vector-ref arr y
    . x val

;; move to a vector
define visited
 list->vector
  map : λ(y) : list->vector : map (λ(x) #f) : iota len-x
        iota len-y
define distances
 list->vector
  map : λ(y) : list->vector : map (λ(x) (inf)) : iota len-x
        iota len-y

That’s all the changes: the other snippets stay the same. Putting it all together (re-using snippets from part 1):

import : only (ice-9 rdelim) read-line
         only (ice-9 pretty-print) pretty-print
         only (ice-9 optargs) define*
         only (srfi :26) cut
         only (srfi :9) define-record-type
         only (srfi :1) first second append-map remove

{{{map-over-lines}}}
{{{string-split-substring}}}

define : line->numbers line
  map string->number : string-split-substring line ""
define input
  map-over-lines line->numbers "advent-of-wisp-code-2021-d15p1-example-input.dat"

;; change: use 5x the input
{{{d15p2-5x-input}}}

define len-y : length input
define len-x : length (list-ref input 0)

;; change: use a vector instead of a list
{{{d15p2-move-to-vector}}}

;; init the risk of the first node as 0
xy-set! distances 0 0 0

{{{d15-position-handling}}}
{{{d15-neighbors}}}

define initial-node  : pos 0 0
define target-node : pos {len-x - 1} {len-y - 1}
define current-node initial-node

{{{d15-closest-unvisited-simple}}}        

{{{d15-visit-current-node-simple}}}

while : visit-current-node
  . #f

;; Now the cost of all shortest paths to all nodes is known.
;; The lowest total risk is just the distance to the target
pretty-print : distance target-node

Yes, it works. Slow, but fast enough to finish. That’s the power of just switching out the basic datastructure for one that’s better suited for the task. Don’t use a linked list, if you want to access elements at arbitrary positions by index.

With this, the task is done, but not yet done well.

Simple Priority Queue

The next step is changing find-closest-unvisited-node to use a priority queue.

I’ll have to implement a Fibonacci heap — or one of the other priority queues with sufficient scaling.

Likely I should try a Strict Fibonacci heap for the best scaling (Brodal, Gerth Stølting; Lagogiannis, George; Tarjan, Robert E., 2012), or one of the queues with best empirical results (Daniel H. Larkin, Siddhartha Sen, Robert E. Tarjan, 2014).

But that requires thinking in trees, so let’s make the simplest priority queue instead. The scaling will not suffice for hard challenges, but it should suffice for this Dijkstra — and keep it simple. The data holder is a plain list for starters and ordering is done by simply sorting after every insert and searching the list linearly when decreasing, because there a value has to be moved.

The algorithm uses a slowly moving front of open nodes of roughly O(sqrt N) size, and it kind of follows the natural ordering of the elements, so the scaling of the priority queue for the task at hand may actually be O(sqrt N).

;; snippet {{{priority-queue}}}
import : only (ice-9 pretty-print) pretty-print
         only (srfi :9) define-record-type
         only (srfi :1) take

define-record-type 
    queue-item priority value
    . queue-item?
    priority queue-item-priority queue-item-priority-set!
    value queue-item-value

define : make-priority-queue
       . '() ;; plain linked list
define : pq-find-min q
    if : null? q
       . #f
       queue-item-value : car q
define pq-delete-min cdr
define : pq-sort q
    sort q : λ (a b) : < (queue-item-priority a) (queue-item-priority b)
define : pq-insert q q-item
    and=> (cons q-item q) pq-sort
define : pq-decrease q priority q-item-value
    . "This has linear time: O(N).

    For a proper priority queue it should have O(log n) or O(1)."
    let loop : (item (car q)) (before '()) (after '()) (rest (cdr q))
        cond
          : equal? q-item-value : queue-item-value item
            ;; use mutating functions (!) for efficiency
            append!
              reverse! before
              cons : queue-item priority q-item-value
                     reverse! after
              . rest
          : null? rest
            error "item not found in q:" q-item-value : take q 10
          ;; the <= is required to have stable sorting.
          { (queue-item-priority item) <= priority }
             loop : car rest
                    cons item before
                    . after
                    cdr rest
          else
             loop : car rest
                    . before
                    cons item after
                    cdr rest

Now I use the priority queue to track the unvisited nodes and get the closest one:

;; snippet {{{priority-queue-usage-unvisited}}}
;; priority-queue: unvisited (this should decrease the cost)
define unvisited
  append-map
    λ (x)
      map
        λ (y) : queue-item (inf) : pos x y
        iota len-y
    iota len-x

;; With the priority queue, this is down to a single line.
define : find-closest-unvisited-node
  pq-find-min unvisited

Processing the current node not only sets the by position, but also changes the distance inside the priority queue and takes the next node to process from it:

;; snippet {{{priority-queue-usage-visit-current-node}}}
define : visit-current-node
  define neigh ;; all unvisited neighbors
    remove : λ (node) : xy-ref visited (pos-x node) (pos-y node)
      neighbors (pos-x current-node) (pos-y current-node)
  define current-distance
    xy-ref distances (pos-x current-node) (pos-y current-node)
  for-each
    λ : node
      let : : d : calculate-distance node current-distance
        set! unvisited : pq-decrease unvisited d node
        xy-set! distances
           pos-x node
           pos-y node
           . d
    . neigh
  xy-set! visited (pos-x current-node) (pos-y current-node) #t
  ;; delete the current-node
  set! unvisited : pq-delete-min unvisited
  and=> (find-closest-unvisited-node) : cut set! current-node <>

Putting the full Dijkstra together again, now with the priority queue:

import : only (ice-9 rdelim) read-line
         only (ice-9 pretty-print) pretty-print
         only (ice-9 optargs) define*
         only (srfi :26) cut
         only (srfi :9) define-record-type
         only (srfi :1) first second append-map remove take

{{{map-over-lines}}}
{{{string-split-substring}}}
{{{priority-queue}}}

define : line->numbers line
  map string->number : string-split-substring line ""

define input
  map-over-lines line->numbers "advent-of-wisp-code-2021-d15p1-example-input.dat"

{{{d15p2-5x-input}}}

define len-y : length input
define len-x : length (list-ref input 0)

{{{d15p2-move-to-vector}}}

;; init the risk of the first node as 0
xy-set! distances 0 0 0

{{{d15-position-handling}}}

{{{d15-neighbors}}}

define initial-node  : pos 0 0
define target-node : pos {len-x - 1} {len-y - 1}
define current-node initial-node

{{{priority-queue-usage-unvisited}}}
set! unvisited : pq-decrease unvisited 0 : pos 0 0

{{{priority-queue-usage-visit-current-node}}}

define : cost-to-target
  while : visit-current-node
    . #f
  distance target-node

;; Now the cost of all shortest paths to all nodes is known.
;; The lowest total risk is just the distance to the target
pretty-print : cost-to-target

Using this trivial priority queue, we’re down from 2h with the naive search on the raw map-data to 11 minutes. The algorithmic cost is dominated by pq-decrease, so using a better priority-queue could decrease the cost a lot:

,profile cost-to-target .
%     cumulative   self             
time   seconds     seconds  procedure
 81.49    883.98    734.70  pq-decrease
  6.49     58.50     58.50  %after-gc-thunk
  6.45     58.11     58.11  reverse!
  3.63     32.70     32.70  equal?
  1.73     15.58     15.56  append!
  0.03    900.08      0.30  :185:0
  0.03      0.28      0.28  :203:8
  0.03      0.24      0.24  xy-ref
  0.02    901.51      0.19  visit-current-node
  0.02      0.15      0.15  :160:0
  0.01      0.13      0.13  xy-set!
  0.01      0.56      0.11  neighbors
  0.01      0.54      0.11  ice-9/boot-9.scm:230:5:map2
  0.01      0.09      0.09  min
  0.01    900.25      0.06  ice-9/boot-9.scm:253:2:for-each
  0.01      0.06      0.06  cadr
  0.00      0.26      0.04  ice-9/boot-9.scm:220:5:map1
  0.00      0.04      0.04  pq-delete-min

Purely Functional Priority Search Queue

Redefining the priority queue with the Priority Search Queue from the Purely Functional Data Structures should give us much better performance. Let’s try that:

;; snippet {{{priority-queue-pfds}}}
import : only (ice-9 pretty-print) pretty-print
         only (srfi :26) cut
         only (srfi :9) define-record-type
         only (srfi :1) take
         pfds psqs ;; Priority Search Queue

define-record-type 
    queue-item priority value
    . queue-item?
    priority queue-item-priority queue-item-priority-set!
    value queue-item-value
;; the position comparator defines the traversal order
define : pos- p0 p1
  define x0 : pos-x p0
  define y0 : pos-y p0
  define x1 : pos-x p1
  define y1 : pos-y p1
  if {x0 = x1} {y0 < y1} {x0 < x1}
define : make-priority-queue
       make-psq pos-define pq-find-min psq-min
define pq-delete-min psq-delete-min
define pq-delete psq-delete
define pq-insert psq-set
define : pq-decrease q priority q-item-value
    psq-update q q-item-value 
      λ (prio) : min priority prio
      . priority

We’ll have to adjust the creation of the unvisited node queue:

;; snippet {{{priority-queue-usage-unvisited-pfds}}}
;; priority-queue: unvisited (this should decrease the cost)
define unvisited
  fold : λ (next previous) : pq-insert previous next : inf
       make-priority-queue
       append-map
         λ (x)
           map
             λ (y) : pos x y
             iota len-y
         iota len-x
;; With the priority queue, this is down to a single line.
define : find-closest-unvisited-node
  and
    not : psq-empty? unvisited
    pq-find-min unvisited

And delete the minimum node before adjusting other nodes to avoid an infinite loop:

;; snippet {{{priority-queue-usage-visit-current-node-pfds}}}
define : visit-current-node
  define neigh ;; all unvisited neighbors
    remove : λ (node) : xy-ref visited (pos-x node) (pos-y node)
      neighbors (pos-x current-node) (pos-y current-node)

  define current-distance
    xy-ref distances (pos-x current-node) (pos-y current-node)
  ;; delete the current-node from unvisited
  set! unvisited : pq-delete-min unvisited

  for-each
    λ : node
      let : : d : calculate-distance node current-distance
        set! unvisited : pq-decrease unvisited d node
        xy-set! distances
           pos-x node
           pos-y node
           . d
    . neigh

  xy-set! visited (pos-x current-node) (pos-y current-node) #t
  and=> (find-closest-unvisited-node) : cut set! current-node <>

But overall the changes are pretty minor:

import : only (ice-9 rdelim) read-line
         only (ice-9 pretty-print) pretty-print
         only (ice-9 optargs) define*
         only (srfi :26) cut
         only (srfi :9) define-record-type
         only (srfi :1) first second append-map remove take fold
         pfds psqs ;; Priority Search Queue

{{{map-over-lines}}}
{{{string-split-substring}}}


define : line->numbers line
  map string->number : string-split-substring line ""

define input
  map-over-lines line->numbers "advent-of-wisp-code-2021-d15p1-example-input.dat"

{{{d15p2-5x-input}}}

define len-y : length input
define len-x : length (list-ref input 0)

{{{d15p2-move-to-vector}}}

;; init the risk of the first node as 0
xy-set! distances 0 0 0

{{{d15-position-handling}}}

{{{priority-queue-pfds}}}
{{{priority-queue-usage-unvisited-pfds}}}
{{{d15-neighbors}}}

define initial-node  : pos 0 0
define target-node : pos {len-x - 1} {len-y - 1}
define current-node initial-node

set! unvisited : pq-decrease unvisited 0 : pos 0 0

{{{priority-queue-usage-visit-current-node-pfds}}}

define : cost-to-target
  while : visit-current-node
    . #t
  distance target-node

;; Now the cost of all shortest paths to all nodes is known.
;; The lowest total risk is just the distance to the target
pretty-print : cost-to-target

This code now takes only 10 seconds for completion instead of 8 minutes.

The difference of the previous version compared to the earlier results are due to faster hardware.

wisp@(guile-user)> ,profile cost-to-target 
... 
... 

%     cumulative   self             
time   seconds     seconds  procedure
 29.36      4.10      4.10  struct-ref
 15.65      4.08      2.19  ice-9/boot-9.scm:1211:8
 14.46      6.33      2.02  rnrs/records/procedural.scm:141:6
  5.37      1.89      0.75  ice-9/boot-9.scm:978:0:record-type-parents
  4.32      0.75      0.60  ice-9/boot-9.scm:1169:19
  4.17      0.71      0.58  pfds/psqs.sls:235:0:update
  3.28      7.37      0.46  pfds/psqs.sls:149:0:play-match
  2.68      2.69      0.37  pfds/psqs.sls:359:0:balance
  2.53      0.35      0.35  <
  2.24      0.31      0.31  %after-gc-thunk
...
---
Sample count: 671
Total time: 13.97066953 seconds (4.1994665 seconds in GC)

I cannot fix struct-ref, so I finally consider this task done. Though it is now 30 months after my first try.

Day 16, Puzzle 1: Read Elf Transmission

arne@fluss (Dr. Arne Babenhauserheide) — Thu, 03 Oct 2024 19:13:00 +0200

After diving into the deep end, we get back to fundamentals: parsing bitstreams represented in hexadecimal.

Example packets:

D2FE28
EE00D40C823060
8A004A801A8002F478
620080001611562C8802118E34
C0015000016115A2E0802F182340
A0016C880162017C3686B18A3D4780

Let’s do that test-driven. Start with the test-setup:

import : srfi :1 lists
         srfi :26 cut
         srfi :60 integers-as-bits
         srfi :64 tests
         only (srfi :11) let-values
         only (ice-9 match) match-let ;; pattern matching

;; implementations that will be tested
{{{d16-parse-hexadecimal}}}
{{{d16-parse-literal-packets}}}
{{{d16-parse-operator-packets}}}

test-begin "elf-messages"

{{{d16-parse-hexadecimal--tests}}}
{{{d16-parse-literal-packets--tests}}}
{{{d16-parse-operator-packets--tests}}}

{{{d16-input-data-test}}}

test-end

See test results:

cat "elf-messages.log"

First we need to parse Hexadecimal into binary:

;; snippet: {{{d16-parse-hexadecimal--tests}}}
test-equal #*110100101111111000101000
  hexadecimal->bits "D2FE28"
test-equal 
  . #*0000000100100011010001010110011110001001101010111100110111101111
  hexadecimal->bits "0123456789abcdef"

;; snippet: {{{d16-parse-hexadecimal}}}
define : hexadecimal->bits hex
  . "Turn hexadecimal string into a bitvector"
  apply bitvector ;; turn bits into efficient bitarray
    append-map (cut integer->list <> 4) ;; represent as bits
      map (cut string->number <> 16) ;; parse as hexadecimal
        map string ;; turn back to one-element strings
          string->list hex ;; split into characters

Then we parse literal packets (direct data):

;; snippet: {{{d16-parse-literal-packets--tests}}}
test-equal '(6 . 4)
  identify-packet #*110100101111111000101000
test-equal 2021
  literal-value-packet-data #*110100101111111000101000

;; snippet: {{{d16-parse-literal-packets}}}
define : bitvector->integer vec
    list->integer
      bitvector->list vec

define : identify-packet packet
  . "Return (version . type) for the PACKET."
  define version : bitvector->integer : bitvector-copy packet 0 3
  define type : bitvector->integer : bitvector-copy packet 3 6
  cons version type

define : bitvectors->integer . packets
  . "Flatten subvectors and re-interpret the bits as integer"
  list->integer : apply append : map bitvector->list packets

define* : literal-value-packet-data packet #:key (start 6)
  . "Return values: data as integer and index after the last bit."
  let loop : (nibbles '()) (index start)
    define nibble : bitvector-copy packet {index + 1} {index + 5}
    define value : cons nibble nibbles
    if : not : bitvector-bit-set? packet index
       values : apply bitvectors->integer : reverse! value
              + index 5
       loop value {index + 5}

Now we parse operator packets (packets containing packets) and extract versions:

;; snippet: {{{d16-parse-operator-packets--tests}}}
;; packet types other than 4 are detected
test-equal '(1 . 6) ;; 6 means operator type
  identify-packet
    hexadecimal->bits "38006F45291200"
;; operator length type bitcount and packet number are detected
test-equal 15
  operator-length-bitlength
    hexadecimal->bits "38006F45291200"
test-equal 11
  operator-length-bitlength
    hexadecimal->bits "EE00D40C823060"
;; parses packet versions
test-equal '(1 6 2)
  extract-packet-versions
    hexadecimal->bits "38006F45291200"
test-equal '(7 2 4 1)
  extract-packet-versions
    hexadecimal->bits "EE00D40C823060"
;; gives correct version sums
test-equal 16
  apply + ;; apply + calculates the sum of the values in a list
    extract-packet-versions
      hexadecimal->bits "8A004A801A8002F478"
test-equal 12
  apply +
    extract-packet-versions
      hexadecimal->bits "620080001611562C8802118E34"
test-equal 23
  apply +
    extract-packet-versions
      hexadecimal->bits "C0015000016115A2E0802F182340"
test-equal 31
  apply +
    extract-packet-versions
      hexadecimal->bits "A0016C880162017C3686B18A3D4780"

;; snippet: {{{d16-parse-operator-packets}}}
define : operator-length-bitlength packet
  if : bitvector-bit-set? packet 6
     . 11 15

define* : extract-packet-versions packet #:optional max-packets
  . "Extract the version numbers of all packets as flat list."
  define : done start-index
    . "check whether enough bits remain for the minimum packet"
    define min-bits {6 + 5} ;; header plus one literal data nibble
    > {start-index + min-bits} : bitvector-length packet
  match-let : : (version . type) : identify-packet packet
    ;; no more packets to parse or not enough bits for a packet
    if : or (and=> max-packets zero?) : done 0
       . '() ;; rest of the packet is only padding
       cons version
        cond
          : equal? 4 type ;; literal value
            let-values
              : (data after-end) : literal-value-packet-data packet
              if (done after-end) '()
                extract-packet-versions
                  bitvector-copy packet after-end 
          else ;; operator packet that can have sub-packets
             let*
               : len-bits : operator-length-bitlength packet
                 data-start : + 6 1 len-bits
                 subvec : bitvector-copy packet 7 data-start
                 len : list->integer : bitvector->list subvec
               if : = 15 len-bits
                 ;; fixed length, arbitrary number of packets
                 append
                     ;; extract packets from packet-body
                     extract-packet-versions
                       bitvector-copy packet data-start
                         + data-start len
                     ;; extract further packets after the packet body
                     if
                       or : equal? max-packets 1
                            done : + data-start len
                       . '()
                       extract-packet-versions
                         bitvector-copy packet : + data-start len
                         and=> max-packets 1-
                 ;; unknown length, fixed num of packets: keep parsing
                 extract-packet-versions
                   bitvector-copy packet data-start
                   . len

Finally we check whether the actual input is parsed correctly:

;; snippet: {{{d16-input-data-test}}}
;; my input gives the correct version sum
test-equal 993
  apply +
    extract-packet-versions
      hexadecimal->bits
        string-append "420D5A802122FD25C8CD7CC010B00564D0E4B76C7D5A"
          . "59C8C014E007325F116C958F2C7D31EB4EDF90A9803B2EB5340924"
          . "CA002761803317E2B4793006E28C2286440087C5682312D0024B9E"
          . "F464DF37EFA0CD031802FA00B4B7ED2D6BD2109485E3F3791FDEB3"
          . "AF0D8802A899E49370012A926A9F8193801531C84F5F573004F803"
          . "571006A2C46B8280008645C8B91924AD3753002E512400CC170038"
          . "400A002BCD80A445002440082021DD807C0201C510066670035C00"
          . "940125D803E170030400B7003C0018660034E6F180120104257588"
          . "0A5004D9372A520E735C876FD2C3008274D24CDE614A68626D9480"
          . "4D4929693F003531006A1A47C85000084C4586B10D802F5977E88D"
          . "2DD2898D6F17A614CC0109E9CE97D02D006EC00086C64859174001"
          . "0C8AF14E0E180253673400AA48D15E468A2000ADCCED1A174218D6"
          . "C017DCFAA4EB2C8C5FA7F21D3F9152012F6C01797FF3B4AE38C32F"
          . "FE7695C719A6AB5E25080250EE7BB7FEF72E13980553CE932EB26C"
          . "72A2D26372D69759CC014F005E7E9F4E9FA7D3653FCC879803E200"
          . "CC678470EC0010E82B11E34080330D211C663004F0010191179117"
          . "9296E7F869F9C017998EF11A1BCA52989F5EA778866008D8023255"
          . "DFBB7BD2A552B65A98ECFEC51D540209DFF2FF2B9C1B9FE5D6A469"
          . "F81590079160094CD73D85FD2699C5C9DCF21F0700094A1AC9EDA6"
          . "4AE3D37D34200B7B401596D678A73AFB2D0B1B88057230A42B2BD8"
          . "8E7F9F0C94F1ECB7B0DD393489182F9802D3F875C00DC40010F891"
          . "1C61F8002111BA1FC2E400BEA5AA0334F9359EA741892D81100B83"
          . "337BD2DDB4E43B401A800021F19A09C1F1006229C3F8726009E002"
          . "A12D71B96B8E49BB180273AA722468002CC7B818C01B04F77B39EF"
          . "DF53973D95ADB5CD921802980199CF4ADAA7B67B3D9ACFBEC4F82D"
          . "19A4F75DE78002007CD6D1A24455200A0E5C47801559BF58665D80"

Day 16, Puzzle 2: Math for Elves

arne@fluss (Dr. Arne Babenhauserheide) — Sat, 12 Jul 2025 00:00:00 +0200

Operator packets are math.

Let’s combine the parts from day one into one unified piece of code.

import : srfi :1 lists
         srfi :26 cut
         srfi :60 integers-as-bits
         only (srfi :11) let-values
         only (ice-9 match) match-let

;; map packet IDs to operator procedures
define : comp op
  define proc
    λ (. x) : if (apply op x) 1 0
  ;; preserve the name for easier debugging
  set-procedure-property! proc 'name
    procedure-name op
  . proc

define id-operator-map
  `
    0 . ,+
    1 . ,*
    2 . ,min
    3 . ,max
    4 . #f ;; data
    5 . , : comp >
    6 . , : comp <
    7 . , : comp equal?

define : id->operator id
 and=> : assoc id id-operator-map
       . cdr

;; unchanged tools
define : hexadecimal->bits hex
  . "Turn hexadecimal string into a bitvector"
  apply bitvector ;; turn bits into efficient bitarray
    append-map (cut integer->list <> 4) ;; represent as bits
      map (cut string->number <> 16) ;; parse as hexadecimal
        map string ;; turn back to one-element strings
          string->list hex ;; split into characters

define : bitvector->integer vec
    list->integer
      bitvector->list vec

define : identify-packet packet
  . "Return (version . type) for the PACKET."
  define version : bitvector->integer : bitvector-copy packet 0 3
  define type : bitvector->integer : bitvector-copy packet 3 6
  cons version type

define : bitvectors->integer . packets
  . "Flatten subvectors and re-interpret the bits as integer"
  list->integer : apply append : map bitvector->list packets

define* : literal-value-packet-data packet #:key (start 6)
  . "Return values: data as integer and index after the last bit."
  let loop : (nibbles '()) (index start)
    define nibble : bitvector-copy packet {index + 1} {index + 5}
    define value : cons nibble nibbles
    if : not : bitvector-bit-set? packet index
       values : apply bitvectors->integer : reverse! value
              + index 5
       loop value {index + 5}

define : operator-length-bitlength packet
  if : bitvector-bit-set? packet 6
     . 11 15

;; adjusted parsing
define : operator-packet/fixed-len packet op data-start len
    . "parse operator packet: fixed length, arbitrary packet-count."
    define : after-the-end? index len
        define minimal-packet {len + 6 + 5}
        . {index > minimal-packet}
    let loop
      : next-packet data-start
        packets '()
      if : after-the-end? next-packet len
         ;; return the result and the end of the body
         values : apply op : reverse packets
                + data-start len ;; end of body
         ;; extract packets from the packet-body
         let-values
           :
             : data after-end
               calculate-result
                 bitvector-copy packet next-packet
           loop : + next-packet after-end
                cons data packets

define : operator-packet/fixed-num packet op data-start len
    . "parse operator packet: unknown length, fixed packets-count."
    let loop
      : next-packet data-start
        packets '()
        remaining len
      if : zero? remaining
         values : apply op : reverse packets
                . next-packet
         let-values
           :
             : data after-end
               calculate-result
                 bitvector-copy packet next-packet
           loop : + next-packet after-end
                cons data packets
                1- remaining

define* : calculate-result packet
  . "Extract the data of literal packets and apply operations."
  match-let : : (version . type) : identify-packet packet
    define op : id->operator type
    define : extract-len packet data-start
        . "extract the length data of the packet as integer."
        define vec : bitvector-copy packet 7 data-start
        list->integer : bitvector->list vec
    if : not op
       literal-value-packet-data packet
       let* ;; operator packet that can have sub-packets
         : len-bits : operator-length-bitlength packet
           data-start : + 6 1 len-bits
           len : extract-len packet data-start
           extractor
             if {len-bits = 15}
               . operator-packet/fixed-len
               . operator-packet/fixed-num
         extractor packet op data-start len

equal? '(3 54 7 9 1 0 0 1)
  map calculate-result
    map hexadecimal->bits '(
      "C200B40A82" ;; 1+2 => 3
      "04005AC33890" ;; 6*9 => 54
      "880086C3E88112" ;; min 7 8 9 => 7
      "CE00C43D881120" ;; max 7 8 9 => 9
      "D8005AC2A8F0" ;; < 5 15 => 1
      "F600BC2D8F" ;; > 5 15 => 0
      "9C005AC2F8F0" ;; = 5 15 => 0 
      "9C0141080250320F1802104A08" ;; 1+3 = 2*2 => 1
    )

This is not very efficient, because it copies bitvectors around all the time. More efficient would be to have a view on the bitvectors, since it’s readonly. But at this point I’m happy with the result.

Day 17, Puzzle 1: Aim for the Area

arne@fluss (Dr. Arne Babenhauserheide) — Sat, 12 Jul 2025 00:00:00 +0200

Calculate discrete trajectories to reach as high as possible while touching the target area.

import : only (srfi :9) define-record-type
         only (srfi :26) cut

define : parse-input s
  . "parse an input definition like

target area: x=20..30, y=-10..-5

Returns x-min x-max y-min y-max
"
  map string->number
    string-tokenize s
      char-set-adjoin
        char-set-intersection char-set:ascii char-set:digit
        . #\-

define-record-type 
  make-particle x y dx dy init
  . particle?
  x p-x
  y p-y
  dx p-dx
  dy p-dy
  init p-init ;; initial values for tracing

define : step p
  define dx : p-dx p
  make-particle
    + (p-x p) (p-dx p)
    + (p-y p) (p-dy p)
    if {dx < 0} {dx + 1} : max 0 {dx - 1}
    - (p-dy p) 1
    p-init p

define* : calculate-trajectory particle x-min x-max y-min
  let loop : (points (list particle))
    define p : car points
    define x : p-x p
    define y : p-y p
    define dx : p-dx p
    if : or {y < y-min} {x > x-max} : and {dx = 0} {x < x-min}
       reverse points
       loop : cons (step p) points

define : touches-area? trajectory x-min x-max y-min y-max
  define : in-target? particle
    define x : p-x particle
    define y : p-y particle
    and {x >= x-min} {x <= x-max} {y >= y-min} {y <= y-max}
  not : null? : filter in-target? trajectory

define : max-y trajectory
  apply max : map p-y trajectory


define : velocity-parameter-range x-min x-max y-min
  when {y-min >= 0}
    throw 'arguments-invalid-must-be-smaller-0 y-min
  ;; after coming down, dy is exactly -dy, so it must be at most
  ;; (abs y-min), else the first step below 0 already overshoots.
  define dy-values
     iota : 1+ : * 2 : abs y-min ;; number of steps
       . y-min ;; start: assumption: y-min < 0
       . 1
  ;; dx must be high enough that dx(dx-1)/2 >= x-min
  ;; dx(dx+1) >= 2*x-min
  ;; (dx+1)(dx+1) >= 2*x-min ;; since (x+1)(x+1)>x(x+1)
  ;; dx + 1 >= sqrt(2*x-min)
  ;; dx >= sqrt(2*x-min) - 1
  define dx-start
    inexact->exact
      floor
        1- : sqrt {2 * x-min}
  ;; dx must be at most x-max, else the first step already overshoots.
  define dx-values
    iota (1+ {x-max - dx-start}) dx-start
  apply append
    map : λ (x) : map (cut cons x <>) dy-values
      . dx-values

define : velocities->particle velocities
  make-particle 0 0
    car velocities
    cdr velocities
    . velocities

define : max-heigth-parameters x-min x-max y-min y-max
  car
    sort
      map : λ (t) : cons (max-y t) (p-init (car t))
        filter : cut touches-area? <> x-min x-max y-min y-max
          map : cut calculate-trajectory <> x-min x-max y-min
            map velocities->particle
              velocity-parameter-range x-min x-max y-min
      λ (a b) : > (car a) (car b)

apply max-heigth-parameters
  parse-input "target area: x=20..30, y=-10..-5"

Day 17, Puzzle 2: All the values

arne@fluss (Dr. Arne Babenhauserheide) — Sat, 12 Jul 2025 00:00:00 +0200

The same as before, but count all working initial velocity values.

;; use all from part 1
{{{d17-part-1}}}

define : count-distinct-parameters x-min x-max y-min y-max
  ;; the starting values are already distinct, so we just need to
  ;; count matching values
  length
    map car
      filter : cut touches-area? <> x-min x-max y-min y-max
        map : cut calculate-trajectory <> x-min x-max y-min
          map velocities->particle
            velocity-parameter-range x-min x-max y-min

apply count-distinct-parameters
  parse-input "target area: x=20..30, y=-10..-5"