UP | HOME

Advent of Wisp Code 2021

Taking part in the advent of code to relax as much as I find time to do. I’ll use Wisp.

Check the RSS-Feed to get informed when I solve puzzles.

I will most likely do them with one day delay, because I want to post the solutions here, and because I work during the day and have family.

advent-of-squid.png

PDF (drucken)

Day 1, puzzle 1: Sweep the deep

Count how often the depths 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

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

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

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

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

Example Input:

00100
11110
10110
10111
10101
01111
00111
11100
10000
11001
00010
01010
import : only (ice-9 rdelim) read-line

define : split-line-into-numbers line
  map string->number : map string : string->list 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

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 γ
  string->number : apply string most-common
                 . 2
define ε
  string->number : apply string : map (λ(x) (if (equal? x #\1) #\0 #\1)) most-common
                 . 2
display {γ * ε}

This is more complex than I’d like it to be. The most important missing piece is “read all lines”.

Day 3, Puzzle 2: Diagnose for Life

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.

00100
11110
10110
10111
10101
01111
00111
11100
10000
11001
00010
01010
import : only (ice-9 rdelim) read-line
         srfi :9 records
         only (srfi :26) cut

define : split-line-into-numbers line
  map string->number : map string : string->list 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

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

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 : list->decimal list-of-numbers
  string->number
    string-join 
      map number->string list-of-numbers
      . ""
    . 2

define oxygen : select most-common
define co2scrub : select least-common

display
  * : list->decimal oxygen
      list->decimal co2scrub

Day 4, Puzzle 1: Cheat the Squid

A squid attached to the ship. We 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

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

define-record-type <bingo>
  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

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

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

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

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

define-record-type <bingo>
  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

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 (cut equal? <> #t) result
        let : : winner : list-ref played 0 ;; just choose the first of the last winners
          * : 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 (cut equal? <> #t) result and
  • always take the first of the last winners.

Day 5, Puzzle 1: Sidestep the vents

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

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 
      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

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
import : only (srfi :1) fold
         only (ice-9 rdelim) read-line

define input
  let : : port : open-input-file "advent-of-wisp-code-2021-d6p1-example-input.dat"
    define res : map string->number : string-split (read-line port) #\,
    close port
    . res

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

OK, 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

define input
  let : : port : open-input-file "advent-of-wisp-code-2021-d6p1-example-input.dat"
    define res : map string->number : string-split (read-line port) #\,
    close port
    . res

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

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

define crabs
  let : : port : open-input-file "advent-of-wisp-code-2021-d7p1-example-input.dat"
    define line : read-line port
    close port
    map string->number : string-split line #\,

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

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

define crabs
  let : : port : open-input-file "advent-of-wisp-code-2021-d7p1-example-input.dat"
    define line : read-line port
    close port
    map string->number : string-split line #\,

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?

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
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

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

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?

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 #\|

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

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

Find low points in height-map.

2199943210
3987894921
9856789892
8767896789
9899965678
import : only (ice-9 rdelim) read-line
         only (ice-9 pretty-print) pretty-print
         only (srfi :1) fold

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

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

define max-y : 1- : vector-length input
define max-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 < max-y} {y + 1}
  define left : and {x > 0} {x - 1}
  define right : and {x < max-x} {x + 1}
  define val : at input x y
  and : if up (< val (at input x up)) #t
        if down (< val (at input x down)) #t
        if left (< val (at input left y)) #t
        if right (< val (at input right y)) #t


define risk-levels
 map
  λ(y)
    map : λ(x) : if (low-point? input x y) (+ 1 (at input x y)) 0
             iota : + 1 max-x
  iota : + 1 max-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

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

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

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

define max-y : 1- : vector-length input
define max-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 < max-y} {y + 1}
  define left : and {x > 0} {x - 1}
  define right : and {x < max-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 identity
      map : λ(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 max-x
        iota : + 1 max-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 max-x
  iota : + 1 max-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

Input:

[({(<(())[]>[[{[]{<()<>>
[(()[<>])]({[<{<<[]>>(
{([(<{}[<>[]}>{[]{[(<()>
(((({<>}<{<{<>}{[]{[]{}
[[<[([]))<([[{}[[()]]]
[{[{({}]{}}([{[{{{}}([]
{<[[]]>}<{[{[{[]{()[[[]
[<(<(<(<{}))><([]([]()
<{([([[(<>()){}]>(<<{{
<{([{{}}[<[[[<>{}]]]>[]]
import : only (ice-9 rdelim) read-line
         only (ice-9 pretty-print) pretty-print
         only (srfi :26) cut

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

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

define opening : string->char-set "([{<"
define paired
  '
    #\( . #\)
    #\[ . #\]
    #\{ . #\}
    #\< . #\>
define error-values
  '
    #\) . 3
    #\] . 57
    #\} . 1197
    #\> . 25137

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

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 <>)
      filter identity
        map find-syntax-error input

Day 10, Puzzle 2: Cleanly close closables

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

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

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

define opening : string->char-set "([{<"
define paired
  '
    #\( . #\)
    #\[ . #\]
    #\{ . #\}
    #\< . #\>
define closing-values
  '
    #\) . 1
    #\] . 2
    #\} . 3
    #\> . 4

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

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 : filter identity : map find-syntax-error input
    list-ref (sort res <) : floor/ (length res) 2

Day 11, Puzzle 1: Flashing Octopuses

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.

5483143223
2745854711
5264556173
6141336146
6357385478
4167524645
2176841721
6882881134
4846848554
5283751526
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

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

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
  map : λ (x) : map 1+ x
      . arr

define : flash-indizes arr
  define : flash y
    define L : list-ref arr y
    map : cut cons y <>
      filter : λ (x) x
        ;; use 99 as flash-value
        map : λ(idx) : let ((num (list-ref L idx))) : and {num > 9} {num < 99} idx
            iota : length L
  apply append : map flash : iota : length arr

define : flash arr
  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
      define around
        filter : λ (x) x
          list
             if (not {x > 0}) #f
                cons {x - 1} y
             if (not {x < len-line-1}) #f
                cons {x + 1} y
             if (not {y < len-arr-1}) #f
                cons x {y + 1}
             if (not (and {y < len-arr-1} {x > 0})) #f
                cons {x - 1} {y + 1}
             if (not (and {y < len-arr-1} {x < len-line-1})) #f
                cons {x + 1} {y + 1}
             if (not {y > 0}) #f
                cons x {y - 1}
             if (not (and {y > 0} {x > 0})) #f
                cons {x - 1} {y - 1}
             if (not (and {y > 0} {x < len-line-1})) #f
                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
      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

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

Find the step where all flashh together.

Use a local return to stop the fold when we 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

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

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
  map : λ (x) : map 1+ x
      . arr

define : flash-indizes arr
  define : flash y
    define L : list-ref arr y
    map : cut cons y <>
      filter : λ (x) x
        ;; use 99 as flash-value
        map : λ(idx) : let ((num (list-ref L idx))) : and {num > 9} {num < 99} idx
            iota : length L
  apply append : map flash : iota : length arr

define : flash arr
  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
      define around
        filter : λ (x) x
          list
             if (not {x > 0}) #f
                cons {x - 1} y
             if (not {x < len-line-1}) #f
                cons {x + 1} y
             if (not {y < len-arr-1}) #f
                cons x {y + 1}
             if (not (and {y < len-arr-1} {x > 0})) #f
                cons {x - 1} {y + 1}
             if (not (and {y < len-arr-1} {x < len-line-1})) #f
                cons {x + 1} {y + 1}
             if (not {y > 0}) #f
                cons x {y - 1}
             if (not (and {y > 0} {x > 0})) #f
                cons {x - 1} {y - 1}
             if (not (and {y > 0} {x < len-line-1})) #f
                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
      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

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

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

We enter at start, we exit at end, we’re 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

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

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 : 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

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

We enter at start, we exit at end, we’re 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

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

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 : 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  <current input>:50:39
  8.82      0.62      0.05  <current input>:31:38:loop
  8.82      0.07      0.05  <current input>: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!

ArneBab 2021-12-01 Mi 00:00 - Impressum - GPLv3 or later (code), cc by-sa (rest)