AoC 2021 (R)
Sonia Mitchell
2022-01-04
2021.RmdDay 1: Sonar Sweep
Day 2: Dive!
Part 1
#' Day 2: Dive!
#' @source <https://adventofcode.com/2021/day/2>
#' @name day2
#'
NULL
#' @rdname day2
#' @param path file path
#' @export
#'
read_day2 <- function(path) {
path |>
read.table() |>
setNames(c("direction", "value"))
}
#' @rdname day2
#' @param dat dat
#' @export
dive <- function(dat) {
summarise_dat <- dat |>
dplyr::group_by(direction) |>
dplyr::summarise(total = sum(value))
horizontal_position <- summarise_dat$total[summarise_dat$direction == "forward"]
depth <- summarise_dat$total[summarise_dat$direction == "down"] -
summarise_dat$total[summarise_dat$direction == "up"]
horizontal_position * depth
}
# Read in data
path <- here("inst", "2021", "day2.txt")
dat <- read_day2(path)
# Calculate the horizontal position and depth and multiply them together
dive(dat)## [1] 16480200.031 sec.
Part 2
#' @rdname day2
#' @param dat dat
#' @export
#'
dive2 <- function(dat) {
# Initialise variables
aim <- 0
horizontal_position <- 0
depth <- 0
# Track aim
for (i in seq_len(nrow(dat))) {
if (dat$direction[i] == "down") {
aim <- aim + dat$value[i]
} else if (dat$direction[i] == "up") {
aim <- aim - dat$value[i]
} else {
horizontal_position <- horizontal_position + dat$value[i]
depth <- depth + (aim * dat$value[i])
}
}
horizontal_position * depth
}
dive2(dat)## [1] 17598185550.016 sec.
Day 3: Binary Diagnostic
Part 1
#' Day 3: Binary Diagnostic
#' @source <https://adventofcode.com/2021/day/3>
#' @name day3
#'
NULL
#' @rdname day3
#' @param path file path
#' @export
#'
read_day3 <- function(path) {
path |>
scan(what = "character")
}
#' @rdname day3
#' @param dat dat
#' @export
#'
power_consumption <- function(dat) {
# Number of bits in each binary number
digits <- nchar(dat[1])
# Calculate gamma and epsilon rates
gamma_binary <- rep(NA, digits)
epsilon_binary <- rep(NA, digits)
for (i in seq_len(digits)) {
# Extract the i[th] character of each string
character <- vapply(dat, function(x) substr(x, i, i), character(1))
# Find most common bit
zeroes <- sum(character == "0")
ones <- sum(character == "1")
gamma_binary[i] <- dplyr::if_else(zeroes > ones, 0, 1)
epsilon_binary[i] <- dplyr::if_else(zeroes < ones, 0, 1)
}
gamma_rate <- strtoi(paste(gamma_binary, collapse = ""), base = 2)
epsilon_rate <- strtoi(paste(epsilon_binary, collapse = ""), base = 2)
# Calculate power consumption
gamma_rate * epsilon_rate
}
# Read in data
path <- here("inst", "2021", "day3.txt")
dat <- read_day3(path)
# Calculate power consumption
power_consumption(dat)## [1] 29546000.046 sec.
Part 2
#' @rdname day3
#' @param dat dat
#' @param type type
#' @export
#'
rating <- function(dat, type) {
# Number of bits in each binary number
digits <- nchar(dat[1])
# For each bit in a binary string
for (i in seq_len(digits)) {
# Extract the i[th] character of each string
character <- vapply(dat, function(x) substr(x, i, i),
character(1))
# Find zeroes and ones
zeroes <- character == "0"
ones <- character == "1"
# Find most common bit
if (sum(zeroes) > sum(ones)) {
bit_criteria <- which(zeroes)
} else if (sum(zeroes) < sum(ones)) {
bit_criteria <- which(ones)
} else {
bit_criteria <- which(ones)
}
# Keep binary strings with most common bit in the ith position
if (type == "oxygen") {
dat <- dat[bit_criteria]
} else if (type == "CO2") {
dat <- dat[-bit_criteria]
}
# If there's only one binary string left, stop
if (length(dat) == 1) break
}
# Return decimal
strtoi(paste(dat, collapse = ""), base = 2)
}
# Calculate oxygen generator and CO2 scrubber ratings
oxygen_generator_rating <- rating(dat, "oxygen")
CO2_scrubber_rating <- rating(dat, "CO2")
# Calculate life support rating
oxygen_generator_rating * CO2_scrubber_rating## [1] 16628460.033 sec.
Day 4: Giant Squid
Part 1
#' Day 4: Giant Squid
#' @source <https://adventofcode.com/2021/day/4>
#' @name day4
#'
NULL
#' @rdname day4
#' @param path file path
#' @export
#'
get_numbers <- function(path) {
path |>
scan(what = "character", n = 1) |>
strsplit(",") |>
unlist() |>
as.numeric()
}
#' @rdname day4
#' @export
#'
get_boards <- function(path) {
raw_boards <- read.table(path, skip = 1)
number_of_boards <- nrow(raw_boards) / 5
lapply(seq_len(number_of_boards), function(x) {
start <- 1 + (5 * (x - 1))
end <- start + 4
raw_boards[start:end, ]
})
}
#' @rdname day4
#' @param numbers numbers
#' @param boards boards
#' @export
#'
play_bingo <- function(numbers, boards) {
# For each number in the bingo call
for (this_number in numbers) {
# Check each board
for (i in seq_along(boards)) {
# If the number is on the board, mark it off (as NA)
boards[[i]] <- update_board(this_number, boards[[i]])
# Check for win
has_won <- check_for_win(boards[[i]])
# If this board has won, calculate the winning score
if (has_won)
return(sum(boards[[i]], na.rm = TRUE) * this_number)
}
}
}
check_for_win <- function(board) {
check_board <- is.na(board)
row_win <- any(rowSums(check_board) == 5)
column_win <- any(colSums(check_board) == 5)
dplyr::if_else(row_win | column_win, TRUE, FALSE)
}
update_board <- function(number, board) {
check_number <- board == number
if (any(check_number, na.rm = TRUE)) {
# Mark the number
find_number <- which(check_number, arr.ind = TRUE)
board[find_number] <- NA
}
board
}
# Read in data
path <- here("inst", "2021", "day4.txt")
numbers <- get_numbers(path)
boards <- get_boards(path)
# Play bingo
play_bingo(numbers, boards)## [1] 314240.425 sec.
Part 2
#' @rdname day4
#' @export
#'
lose_bingo <- function(numbers, boards) {
# Initialise objects
results <- data.frame(number = numeric(), board = numeric(), score = numeric())
remaining_boards <- seq_along(boards)
# For each number in the bingo call
for (this_number in numbers) {
# Check each board
for (i in remaining_boards) {
# If the number is on the board, mark it off (as NA)
boards[[i]] <- update_board(this_number, boards[[i]])
# Check for win
has_won <- check_for_win(boards[[i]])
# If this board has won, calculate the winning score
if (has_won) {
score <- sum(boards[[i]], na.rm = TRUE) * this_number
results <- rbind(results,
data.frame(number = this_number,
board = i,
score = score))
remaining_boards <- remaining_boards[-which(remaining_boards == i)]
}
}
}
results
}
# Play bingo
losers <- lose_bingo(numbers, boards)
tail(losers)## number board score
## 95 43 70 14835
## 96 41 76 11767
## 97 9 15 4599
## 98 9 82 3726
## 99 84 89 36120
## 100 82 16 230421.113 sec.
Day 5: Hydrothermal Venture
Part 1
#' Day 5: Hydrothermal Venture
#' @source <https://adventofcode.com/2021/day/5>
#' @name day5
#'
NULL
#' @rdname day5
#' @param path file path
#' @export
#'
read_day5 <- function(path) {
path |>
read.table() |>
dplyr::select(-V2) |>
tidyr::separate(V1, c("x1", "y1")) |>
tidyr::separate(V3, c("x2", "y2")) |>
dplyr::mutate(dplyr::across(dplyr::everything(), as.numeric))
}
#' @rdname day5
#' @param coordinates coordinates
#' @export
#'
track_vents <- function(coordinates) {
# Initialise object
xlim <- max(c(coordinates$x1, coordinates$x2))
ylim <- max(c(coordinates$y1, coordinates$y2))
grid <- matrix(0, nrow = ylim, ncol = xlim)
# Track horizontal and vertical lines
for (i in seq_len(nrow(coordinates))) {
this_line <- coordinates[i, ]
if (this_line$x1 == this_line$x2) {
# Horizontal line
this_x <- this_line$x1
y_values <- this_line$y1:this_line$y2
# Add one to each point on the line
for (y in y_values) grid[this_x, y] <- grid[this_x, y] + 1
} else if (this_line$y1 == this_line$y2) {
# Vertical line
this_y <- this_line$y1
x_values <- this_line$x1:this_line$x2
# Add one to each point on the line
for (x in x_values) grid[x, this_y] <- grid[x, this_y] + 1
}
}
sum(grid >= 2)
}
path <- here("inst", "2021", "day5.txt")
coordinates <- read_day5(path)
# Find points where at least two lines overlap
track_vents(coordinates)## [1] 65720.105 sec.
Part 2
#' @rdname day5
#' @export
#'
track_vents2 <- function(coordinates) {
# Initialise object
xlim <- max(c(coordinates$x1, coordinates$x2))
ylim <- max(c(coordinates$y1, coordinates$y2))
grid <- matrix(0, nrow = ylim, ncol = xlim)
# Track horizontal, vertical lines, and diagonal lines
for (i in seq_len(nrow(coordinates))) {
this_line <- coordinates[i, ]
if (this_line$x1 == this_line$x2) {
# Horizontal line
this_x <- this_line$x1
y_values <- this_line$y1:this_line$y2
# Add one to each point on the line
for (y in y_values) grid[this_x, y] <- grid[this_x, y] + 1
} else if (this_line$y1 == this_line$y2) {
# Vertical line
this_y <- this_line$y1
x_values <- this_line$x1:this_line$x2
# Add one to each point on the line
for (x in x_values) grid[x, this_y] <- grid[x, this_y] + 1
} else if(abs(this_line$x1 - this_line$x2) ==
abs(this_line$y1 - this_line$y2)) {
# Diagonal line
x_values <- this_line$x1:this_line$x2
y_values <- this_line$y1:this_line$y2
# Add one to each point on the line
for (i in seq_along(x_values))
grid[x_values[i], y_values[i]] <- grid[x_values[i], y_values[i]] + 1
}
}
sum(grid >= 2)
}
# Find points where at least two lines overlap
track_vents2(coordinates)## [1] 214660.088 sec.
Day 6: Lanternfish
Part 1
#' Day 6: Lanternfish
#' @source <https://adventofcode.com/2021/day/6>
#' @name day6
#'
NULL
#' @rdname day6
#' @param path file path
#' @export
#'
read_day6 <- function(path) {
path |>
scan(what = "character", sep = ",") |>
as.numeric()
}
#' @rdname day6
#' @param dat dat
#' @export
#'
simulate_lanternfish <- function(dat) {
# Initialise variables
days <- 80
fish <- dat
# Simulate lanternfish
for (i in seq_len(days)) {
# Find zeroes
zeroes <- which(fish == 0)
# Subtract 1 from all fish
fish <- fish - 1
# Reset zeroes to six
fish[zeroes] <- 6
# Add eights for each zero
fish <- c(fish, rep(8, length(zeroes)))
}
length(fish)
}
# Read in data
path <- here("inst", "2021", "day6.txt")
dat <- read_day6(path)
# How many lanternfish would there be after 80 days?
simulate_lanternfish(dat)## [1] 3909230.066 sec.
Part 2
It takes too much memory to simulate individual fish in a vector, so generate a frequency table instead.
#' @rdname day6
#' @export
#'
simulate_lanternfish2 <- function(dat) {
# Initialise variables
days <- 256
# Generate a frequency table
fish_counts <- data.frame(age = dat) |>
dplyr::count(age) |> # Count fish
tidyr::complete(age = 0:8, fill = list(n = 0)) # Fill in the missing categories
for (i in seq_len(days)) {
# Number of zeroes
n_zeroes <- fish_counts$n[fish_counts$age == 0]
# Subtract 1 from all fish
fish_counts$n[1:(nrow(fish_counts) - 1)] <- fish_counts$n[2:nrow(fish_counts)]
# Reset zeroes to six
age_6 <- which(fish_counts$age == 6)
fish_counts$n[age_6] <- fish_counts$n[age_6] + n_zeroes
# Add eights for each zero
fish_counts$n[which(fish_counts$age == 8)] <- n_zeroes
}
sum(fish_counts$n) |>
format(scientific = FALSE)
}
# How many lanternfish would there be after 256 days?
simulate_lanternfish2(dat)## [1] "1749945484935"0.075 sec.
Day 7: The Treachery of Whales
Part 1
#' Day 7: The Treachery of Whales
#' @source <https://adventofcode.com/2021/day/7>
#' @name day7
#'
NULL
#' @rdname day7
#' @param path file path
#' @export
#'
read_day7 <- function(path) {
path |>
scan(what = "character", sep = ",") |>
as.numeric()
}
#' @rdname day7
#' @param dat dat
#' @export
#'
track_crabs <- function(dat) {
# Initialise objects
xlim <- max(dat)
results <- data.frame(x = 1:xlim, total_fuel_cost = NA)
# Determine the horizontal position that the crabs can align to using the least
# fuel possible
for (position in seq_len(xlim)) {
fuel_cost <- 0
for (crab in dat) {
fuel_cost <- fuel_cost + abs(crab - position)
}
results$total_fuel_cost[position] <- sum(fuel_cost)
}
lowest <- which.min(results$total_fuel_cost)
results$x[lowest]
results$total_fuel_cost[lowest]
}
# Read in data
path <- here("inst", "2021", "day7.txt")
dat <- read_day7(path)
# How much fuel must they spend to align to that position?
track_crabs(dat)## [1] 3569920.282 sec.
Part 2
#' @rdname day7
#' @export
#'
track_crabs2 <- function(dat) {
# Initialise objects
xlim <- max(dat)
results <- data.frame(x = 1:xlim, total_fuel_cost = NA)
# Determine the horizontal position that the crabs can align to using the least
# fuel possible
for (position in seq_len(xlim)) {
fuel_cost <- 0
for (crab in dat) {
distance <- abs(crab - position)
fuel_cost <- fuel_cost + sum(0:distance)
}
results$total_fuel_cost[position] <- sum(fuel_cost)
}
lowest <- which.min(results$total_fuel_cost)
results$x[lowest]
results$total_fuel_cost[lowest]
}
# How much fuel must they spend to align to that position?
track_crabs2(dat)## [1] 1012681101.14 sec.
Day 8: Seven Segment Search
Part 1
#' Day 8: Seven Segment Search
#' @source <https://adventofcode.com/2021/day/8>
#' @name day8
#'
NULL
#' @rdname day8
#' @param path file path
#' @export
#'
read_day8 <- function(path) {
path |>
scan(what = "character", sep = "\n")
}
#' @rdname day8
#' @param dat dat
#' @export
#'
count_digits <- function(dat) {
results <- c()
for (i in seq_along(dat)) {
tmp <- strsplit(dat[i], "\\| ")[[1]][2]
digits <- strsplit(tmp, " ")[[1]]
results[i] <- sum(nchar(digits) %in% c(2, 4, 3, 7))
}
sum(results)
}
# Read in data
path <- here("inst", "2021", "day8.txt")
dat <- read_day8(path)
# How many times do digits 1, 4, 7, or 8 (length 2, 4, 3, and 7) appear?
count_digits(dat)## [1] 3210.019 sec.
Part 2
#' @rdname day8
#' @param dat dat
#' @export
#'
decode_segments <- function(dat) {
# Determine all of the wire/segment connections
results <- c()
for (i in seq_along(dat)) {
segments <- strsplit(dat[i], " \\|")[[1]][1]
segments <- strsplit(segments, " ")[[1]]
# Known
one <- find_digit(segments, 2)
four <- find_digit(segments, 4)
seven <- find_digit(segments, 3)
eight <- find_digit(segments, 7)
# Remaining segments
remaining <- segments[-which(nchar(segments) %in% c(2, 4, 3, 7))]
# six, nine, zero (6)
length_six <- remaining[which(nchar(remaining) == 6)]
six <- contains_subset(length_six, one, FALSE)
nine <- contains_subset(length_six, four, TRUE)
zero <- length_six[!(length_six %in% c(six, nine))]
# two, three, five (5)
length_five <- remaining[which(nchar(remaining) == 5)]
five <- subset_of(length_five, six)
length_five <- length_five[!length_five %in% five]
three <- subset_of(length_five, nine)
two <- length_five[!length_five %in% three]
# Initialise dictionary
dict <- data.frame(number = 0:9,
segments = c(zero, one, two, three, four,
five, six, seven, eight, nine))
# Decode the four-digit output values
digits <- strsplit(dat[i], "\\| ")[[1]][2]
digits <- strsplit(digits, " ")[[1]]
results[i] <- decode(digits, dict)
}
sum(results)
}
#' Find string in `string_vector` of length `num_characters`
#'
find_digit <- function(string_vector, num_characters) {
string_vector[which(nchar(string_vector) == num_characters)]
}
#' Split string into vector of letters
#'
deconstruct <- function(string) {
strsplit(string, "")[[1]]
}
#' contains_subset
#'
#' Find (1) which string in `unknown_vector` contains all segments
#' (characters) in `known_string` or (2) which string is the only one that
#' doesn't
#' @param unknown_vector an unknown vector
#' @param known_string a known string
#' @param contains (optional) default is `TRUE`
#'
contains_subset <- function(unknown_vector, known_string, contains = TRUE) {
results <- c()
for (i in seq_along(unknown_vector)) {
known_segments <- deconstruct(known_string)
unknown_segments <- deconstruct(unknown_vector[i])
if (contains) {
results[i] <- all(known_segments %in% unknown_segments)
} else {
results[i] <- !all(known_segments %in% unknown_segments)
}
}
unknown_vector[which(results)]
}
#' Find the string in `unknown_vector` whose segments (characters) are a
#' subset of `known_string`
#'
subset_of <- function(unknown_vector, known_string) {
results <- c()
for (i in seq_along(unknown_vector)) {
known_segments <- deconstruct(known_string)
unknown_segments <- deconstruct(unknown_vector[i])
results[i] <- all(unknown_segments %in% known_segments)
}
unknown_vector[which(results)]
}
#' Decode each string (digit) in `unknown_vector`
#'
decode <- function(unknown_vector, dictionary) {
code <- c()
for (i in seq_along(unknown_vector)) {
# Check against each dictionary entry
entry <- c()
for (j in seq_len(nrow(dictionary))) {
length_match <- nchar(dictionary$segments[j]) == nchar(unknown_vector[i])
characters_match <- all(deconstruct(dictionary$segments[j]) %in%
deconstruct(unknown_vector[i]))
entry[j] <- length_match && characters_match
}
code[i] <- dictionary$number[which(entry)]
}
as.numeric(paste(code, collapse = ""))
}
# What do you get if you add up all of the output values?
decode_segments(dat)## [1] 10289260.212 sec.
Day 9: Smoke Basin
Part 1
#' Day 9: Smoke Basin
#' @source <https://adventofcode.com/2021/day/9>
#' @name day9
#'
NULL
#' @rdname day9
#' @param path file path
#' @export
#'
read_day9 <- function(path) {
path |>
readLines() |>
strsplit("") |>
do.call(what = "rbind") |>
apply(1, as.numeric)
}
#' @rdname day9
#' @param dat dat
#' @export
#'
low_points <- function(dat) {
# Find all of the low points on the heightmap and calculate risk level
lowest_points <- data.frame(x = numeric(), y = numeric(), risk = numeric())
for (i in seq_len(nrow(dat))) {
for (j in seq_len(ncol(dat))) {
lowest_point <- compare_heights(dat, i, j)
lowest_points <- rbind.data.frame(lowest_points, lowest_point)
}
}
lowest_points
}
#' Find `height` of adjacent points and if it's lower than all
#' `adjacent_points`, return risk level
compare_heights <- function(dat, row, column) {
height <- dat[row, column]
# Extract adjacent heights
adjacent_points <- c()
if (row != 1)
adjacent_points <- c(adjacent_points, dat[row - 1, column]) # above
if (column != ncol(dat))
adjacent_points <- c(adjacent_points, dat[row, column + 1]) # right
if (row != nrow(dat))
adjacent_points <- c(adjacent_points, dat[row + 1, column]) # below
if (column != 1)
adjacent_points <- c(adjacent_points, dat[row, column - 1]) # left
# Compare height to adjacent heights
if (all(height < adjacent_points))
return(data.frame(x = row, y = column, risk = height + 1))
}
# Read in data
path <- here("inst", "2021", "day9.txt")
dat <- read_day9(path)
# What is the sum of the risk levels of all low points on your heightmap?
lowest_points <- low_points(dat)
sum(lowest_points$risk)## [1] 6030.677 sec.
Part 2
#' @rdname day9
#' @param lowest_points lowest_points
#' @export
#'
survey_basins <- function(dat, lowest_points) {
# Find all of the low points on the heightmap and calculate basin size
results <- c()
for (i in seq_len(nrow(lowest_points))) {
# cat("\r", i, "/", nrow(lowest_points))
size <- survey(dat, lowest_points$x[i], lowest_points$y[i])
results <- c(results, size)
}
prod(tail(sort(results), 3))
}
#' For a particular `lowest_point`, survey the basin and return it's size
survey <- function(dat, row, column) {
# Height of lowest point being surveyed
height <- dat[row, column]
# Initialise basin dataframe
basin <- data.frame(row = row, column = column, risk = height + 1)
# Find adjacent points with depth less than 9
neighbours <- check_adjacent(dat, row, column)
# Add them to the basin
tmp <- neighbours |>
dplyr::mutate(risk = height + 1) |>
dplyr::select(-height)
basin <- rbind(basin, tmp)
# Check neighbouring points
continue <- nrow(neighbours) > 0
while(continue) {
more_neighbours <- check_adjacent(dat,
neighbours$row[1],
neighbours$column[1])
# Remove this point from `neighbours`
neighbours <- neighbours[-1, ]
# Remove new neighbours that are already in the basin
more_neighbours <- setdiff(dplyr::select(more_neighbours, -height),
dplyr::select(basin, -risk)) |>
dplyr::left_join(more_neighbours, by = c("row", "column"))
# If any new neighbours are remaining
if (nrow(more_neighbours) > 0) {
# Add them to the basin
tmp <- more_neighbours |>
dplyr::mutate(risk = height + 1) |>
dplyr::select(-height)
basin <- rbind(basin, tmp)
# And add them to `neighbours` (for checking)
neighbours <- rbind(neighbours, more_neighbours)
}
continue <- nrow(neighbours) > 0
}
# Return size of basin
nrow(basin)
}
#' Return neighbouring points that have a height less than 9
check_adjacent <- function(dat, row, column) {
# Find height of adjacent points
adjacent_points <- data.frame(row = numeric(), column = numeric(),
height = numeric())
if (row != 1) # Above
adjacent_points <- rbind(adjacent_points, check_height(dat, row - 1, column))
if (column != ncol(dat)) # Right
adjacent_points <- rbind(adjacent_points, check_height(dat, row, column + 1))
if (row != nrow(dat)) # Below
adjacent_points <- rbind(adjacent_points, check_height(dat, row + 1, column))
if (column != 1) # Left
adjacent_points <- rbind(adjacent_points, check_height(dat, row, column - 1))
# Return neibouring points that should be checked
adjacent_points |>
dplyr::filter(height != 9)
}
#' Check height is less than 9
check_height <- function(dat, row, column) {
if (dat[row, column] < 9)
return(data.frame(row = row, column = column, height = dat[row, column]))
}
# Multiply together the sizes of the three largest basins
survey_basins(dat, lowest_points)## [1] 78678057.328 sec.
Day 10: Syntax Scoring
Part 1
#' Day 10: Syntax Scoring
#' @source <https://adventofcode.com/2021/day/10>
#' @name day10
#'
NULL
#' @rdname day10
#' @param path file path
#' @export
#'
read_day10 <- function(path) {
path |>
readLines()
}
#' @rdname day10
#' @param dat dat
#' @export
#'
syntax_score <- function(dat) {
total <- 0
remove_lines <- c()
for (i in seq_along(dat)){
expecting <- c()
points <- NA
check_this <- strsplit(dat[i], "")[[1]]
for (j in seq_along(check_this)) {
if (check_this[j] == "("){
expecting <- c(expecting, ")")
} else if (check_this[j] == "[") {
expecting <- c(expecting, "]")
} else if (check_this[j] == "{") {
expecting <- c(expecting, "}")
} else if (check_this[j] == "<") {
expecting <- c(expecting, ">")
} else {
# If `check_this` matches the last expected value, remove it
if (check_this[j] == tail(expecting, 1)) {
expecting <- expecting[-length(expecting)]
} else if (is.na(points)) {
# Otherwise add the score to `total`
points <- corrupted_score(check_this[j])
total <- total + points
remove_lines <- c(remove_lines, i)
break
}
}
}
}
list(total = total,
remove_lines = remove_lines)
}
corrupted_score <- function(character) {
score_table <- data.frame(char = c(")", "]", "}", ">"),
val = c(3, 57, 1197, 25137))
score_table$val[which(score_table$char == character)]
}
# Read in data
path <- here("inst", "2021", "day10.txt")
dat <- read_day10(path)
# Find the first illegal character in each corrupted line of the navigation
# subsystem. What is the total syntax error score for those errors?
tmp <- syntax_score(dat)
tmp$total## [1] 2965350.066 sec.
Part 2
#' @rdname day10
#' @export
#'
syntax_score2 <- function(dat, remove_lines) {
# Remove corrupted lines
incomplete_lines <- dat[-remove_lines]
results <- c()
for (i in seq_along(incomplete_lines)){
expecting <- c()
check_this <- strsplit(incomplete_lines[i], "")[[1]]
points <- 0
for (j in seq_along(check_this)) {
if (check_this[j] == "("){
expecting <- c(expecting, ")")
} else if (check_this[j] == "[") {
expecting <- c(expecting, "]")
} else if (check_this[j] == "{") {
expecting <- c(expecting, "}")
} else if (check_this[j] == "<") {
expecting <- c(expecting, ">")
} else {
# If `check_this` matches the last expected value, remove it
if (check_this[j] == tail(expecting, 1)) {
expecting <- expecting[-length(expecting)]
}
}
}
expecting <- rev(expecting)
# Calculate score
for (k in seq_along(expecting)) {
points <- (points * 5) + incomplete_score(expecting[k])
}
results <- c(results, points)
}
index <- ceiling(length(results) / 2)
value <- sort(results)[index]
format(value, scientific = FALSE)
}
incomplete_score <- function(character) {
score_table <- data.frame(char = c(")", "]", "}", ">"),
val = c(1, 2, 3, 4))
score_table$val[which(score_table$char == character)]
}
# Find the completion string for each incomplete line, score the completion
# strings, and sort the scores. What is the middle score?
remove_lines <- tmp$remove_lines
syntax_score2(dat, remove_lines)## [1] "4245130838"0.148 sec.
Day 11: Dumbo Octopus
Part 1
#' Day 11: Dumbo Octopus
#' @source <https://adventofcode.com/2021/day/11>
#' @name day11
#'
NULL
#' @rdname day11
#' @param path file path
#' @export
#'
read_day11 <- function(path) {
path |>
scan(what = "character") |>
strsplit("") |>
do.call(what = rbind) |>
apply(1, as.numeric)
}
#' @rdname day11
#' @param octopus octopus
#' @export
#'
simulate_octopus <- function(octopus) {
count <- 0
for (i in 1:100) {
# cat("\r", i, "of 100")
data <- timestep(octopus)
octopus <- data$octopus
count <- count + data$latest_flashes
}
count
}
timestep <- function(octopus) {
# Increases the energy level of each octopus by 1
octopus <- octopus + 1
done <- matrix(nrow = 0, ncol = 2)
# Octopi with energy levels > 9 flash and their energy levels reset to 0,
# the energy level of all adjacent octopuses increases by 1. If this causes
# an octopus to have an energy level > 9, it also flashes
while (any(octopus > 9)) {
flash <- which(octopus > 9, arr.ind = T) # if energy is > 9
done <- rbind(done, flash) # flash
octopus[flash] <- 0 # and reset energy level
# For each flashing octopus, find neighbouring octopi, and increase their
# energy levels by 1
for (j in seq_len(nrow(flash))) {
x <- unname(flash[j, "row"])
y <- unname(flash[j, "col"])
neighbours <- find_neighbours(x, y, flash, done, octopus)
octopus[neighbours] <- octopus[neighbours] + 1
}
}
# Latest flashes
list(octopus = octopus, latest_flashes = nrow(done))
}
find_neighbours <- function(x, y, flashing_now, flashed_previously, octopus) {
# Index neighbours
tmp <- rbind(data.frame(row = x - 1, col = (y - 1):(y + 1)), # above
data.frame(row = x, col = c(y - 1, y + 1)), # sides
data.frame(row = x + 1, col = (y - 1):(y + 1))) # below
# Remove invalid coordinates
xlim <- ncol(octopus) + 1
ylim <- nrow(octopus) + 1
tmp <- dplyr::filter(tmp, row != 0, col != 0, row != xlim, col != ylim)
# Add to `neighbours`, remove duplicates, and remove those that are flashing
# now or have flashed previously
tmp |>
unique() |>
dplyr::anti_join(data.frame(flashing_now), by = c("row", "col")) |>
dplyr::anti_join(data.frame(flashed_previously), by = c("row", "col")) |>
as.matrix()
}
# Read in data
test <- here("inst", "2021", "day11-test.txt")
path <- here("inst", "2021", "day11.txt")
test_dat <- read_day11(test)
dat <- read_day11(path)
# Test simulation
assertthat::assert_that(simulate_octopus(test_dat) == 1656)## [1] TRUE
# Given the starting energy levels of the dumbo octopuses in your cavern,
# simulate 100 steps. How many total flashes are there after 100 steps?
simulate_octopus(dat)## [1] 17437.496 sec.
Part 2
#' @rdname day11
#' @export
#'
simulate_octopus2 <- function(octopus) {
count <- 1
# What is the first step during which all octopuses flash?
while (sum(octopus) != 0) {
# cat("\r", count)
data <- timestep(octopus)
octopus <- data$octopus
count <- count + 1
}
count
}
# What is the first step during which all octopuses flash?
simulate_octopus2(dat)## [1] 36525.377 sec.
Day 12: Passage Pathing
Part 1
#' Day 12: Passage Pathing
#' @source <https://adventofcode.com/2021/day/12>
#' @name day12
#'
NULL
#' @rdname day12
#' @param path file path
#' @export
#'
read_day12 <- function(path) {
dat <- path |>
read.table(sep = "-")
rbind(dat, dplyr::rename(dat, V1 = V2, V2 = V1)) |>
dplyr::rename(from = V1,
to = V2) |>
dplyr::filter(from != "end",
to != "start")
}
#' @rdname day12
#' @param dat data
#' @export
#'
cave_routes <- function(dat) {
# Initialise routes
completed_routes <- list()
unfinished_routes <- dplyr::filter(dat, from == "start")
unfinished_routes <- lapply(seq_len(nrow(unfinished_routes)),
function(x) unname(unlist(unfinished_routes[x,])))
# Plot routes through cave system
while (length(unfinished_routes) > 0) {
this_route <- unfinished_routes[[1]]
this_cave <- tail(this_route, 1)
# Record next step(s) of the route
next_steps <- dplyr::filter(dat, from == this_cave, to != "start")$to
# If the exit has been found, move the route to `completed_routes`
if ("end" %in% next_steps) {
completed_routes <- c(completed_routes, list(c(this_route, "end")))
next_steps <- setdiff(next_steps, "end")
}
# If the cave is small and has already been visited, ignore it
small <- next_steps[vapply(next_steps, function(x)
grepl("^[[:lower:]]+$", x), logical(1))]
big <- setdiff(next_steps, small)
next_steps <- c(setdiff(small, this_route), big)
# Record next step(s) of the route
add_these <- lapply(next_steps, function(x) c(this_route, x))
# Record steps and tidy up
unfinished_routes <- c(unfinished_routes, add_these)
unfinished_routes <- unfinished_routes[-1]
}
length(completed_routes)
}
# Read in data
path <- here("inst", "2021", "day12.txt")
dat <- read_day12(path)
# How many paths through this cave system are there that visit small caves at
# most once?
cave_routes(dat)## [1] 388710.912 sec.
Part 2
We have to use a different method for Part 2, since it takes too long to calculate the number of routes.
#' @rdname day12
#' @export
#'
cave_routes2 <- function(dat) {
# Initialise routes
unfinished <- dplyr::filter(dat, from == "start")
complete <- data.frame()
last_step <- "to"
# Plot routes through cave system
while (nrow(unfinished) != 0) {
# Record next step(s) of the route
unfinished <- dplyr::left_join(unfinished, dat,
by = setNames("from", last_step))
# Extract column name of the last step
last_step <- tail(names(unfinished), 1)
# For each unfinished route, count the number of small caves that were
# visited more than once
test <- apply(unfinished, 1, function(x) {
duplicates <- x[duplicated(unlist(x))]
islower <- grepl("^[[:lower:]]+$", duplicates)
sum(islower)})
# Remove routes where more than one small cave was visited more than once
index <- which(test > 1)
if (length(index) > 0)
unfinished <- unfinished[-index, ]
# Add completed routes to `complete`
complete <- dplyr::bind_rows(complete,
dplyr::filter(unfinished,
get(last_step) == "end"))
# Remove completed routes from `unfinished`
unfinished <- dplyr::filter(unfinished, get(last_step) != "end")
}
nrow(complete)
}
# If we visit a single small cave twice, how many paths through this cave
# system are there?
cave_routes2(dat)## [1] 10483415.743 sec.
Day 13: Transparent Origami
Part 1
#' Day 13: Transparent Origami
#' @source <https://adventofcode.com/2021/day/13>
#' @name day13
#'
NULL
#' @rdname day13
#' @param path file path
#' @export
#'
read_day13 <- function(path) {
read.table(path, sep = "-")
}
#' @rdname day13
#' @param dat dat
#' @export
#'
origami_instructions <- function(dat) {
dplyr::filter(dat, grepl("^fold", V1)) |>
dplyr::mutate(V1 = gsub("^.*([a-z]=[0-9]*)$", "\\1", V1)) |>
tidyr::separate(V1, c("axis", "value")) |>
dplyr::mutate(value = as.numeric(value) + 1)
}
#' @rdname day13
#' @export
#'
origami_paper <- function(dat) {
dots <- dat |>
dplyr::filter(!grepl("^fold", V1)) |>
tidyr::separate(V1, c("y", "x"), convert = TRUE) |>
dplyr::mutate(x = x + 1,
y = y + 1) |>
dplyr::select(x, y)
xlim <- max(dots$x)
ylim <- max(dots$y)
# Generate grid of dots
paper <- matrix(FALSE, nrow = xlim, ncol = ylim)
for (i in seq_len(nrow(dots)))
paper[dots$x[i], dots$y[i]] <- TRUE
paper
}
#' @rdname day13
#' @param grid grid
#' @param value value
#' @export
#'
fold_left <- function(grid, value) {
left <- grid[, 1:(value - 1)]
right <- grid[, (value + 1):ncol(grid)]
pad <- matrix(0, nrow = nrow(grid), ncol = abs(ncol(left) - ncol(right)))
if (ncol(right) < ncol(left)) {
right <- cbind(right, pad)
} else if (ncol(right) > ncol(left)) {
left <- cbind(pad, left)
}
left | right[, ncol(right):1]
}
# Read in data
path <- here("inst", "2021", "day13.txt")
dat <- read_day13(path)
paper <- origami_paper(dat)
instructions <- origami_instructions(dat)
# How many dots are visible after completing just the first fold instruction on
# your transparent paper?
result <- fold_left(paper, instructions[1,]$value)
sum(result > 0)## [1] 8470.059 sec.
Part 2
#' @rdname day13
#' @param paper paper
#' @export
#'
simulate_origami <- function(paper, instructions) {
# Finish folding the transparent paper according to the instructions. The
# manual says the code is always eight capital letters.
for (i in seq_len(nrow(instructions))) {
if (instructions$axis[i] == "x") {
paper <- fold_left(paper, instructions$value[i])
} else if(instructions$axis[i] == "y") {
paper <- fold_up(paper, instructions$value[i])
}
}
coords <- which(paper, arr.ind = TRUE) |>
as.data.frame() |>
dplyr::mutate(value = 1,
row = max(row) - row)
ggplot2::ggplot(coords, ggplot2::aes(x = col, y = row, fill = value)) +
ggplot2::geom_tile(fill = "goldenrod2") +
ggplot2::coord_fixed() +
ggplot2::theme_void() +
ggplot2::theme(legend.position = "none")
}
#' @description Make a horizontal fold
#' @rdname day13
#' @export
#'
fold_up <- function(grid, value) {
upper <- grid[1:(value - 1), ]
lower <- grid[(value + 1):nrow(grid), ]
pad <- matrix(FALSE, nrow = abs(nrow(upper) - nrow(lower)), ncol = ncol(upper))
if (nrow(upper) < nrow(lower)) {
upper <- rbind(pad, upper)
} else if (nrow(upper) > nrow(lower)) {
lower <- rbind(lower, pad)
}
upper | lower[nrow(lower):1, ]
}
# What code do you use to activate the infrared thermal imaging camera system?
simulate_origami(paper, instructions)
0.19 sec.
Day 14: Extended Polymerization
Part 1
#' Day 14: Extended Polymerization
#' @source <https://adventofcode.com/2021/day/14>
#' @name day14
#'
NULL
#' @rdname day14
#' @param path file path
#' @export
#'
get_template <- function(path) {
strsplit(readLines(path, n = 1), "") |>
unlist()
}
#' @rdname day14
#' @export
#'
get_rules <- function(path) {
tmp <- read.table(path, skip = 1)
data.frame(first = substr(tmp[, 1], 1, 1),
last = substr(tmp[, 1], 2, 2),
insert = tmp[, 3])
}
#' @rdname day14
#' @param template template
#' @param rules rules
#' @param n n
#' @export
#'
polymerization <- function(template, rules, n) {
for (i in seq_len(n)) {
tmp <- convert_template(template) |>
dplyr::left_join(rules, by = c("first", "last"))
template <- tmp |> dplyr::select(insert, last) |>
t() |>
as.vector() |>
append(tmp$first[1], 0)
}
freq <- table(template)
max(freq) - min(freq)
}
convert_template <- function(template) {
data.frame(first = head(template, -1),
last = tail(template, -1))
}
# Read in data
test <- here("inst", "2021", "day14-test.txt")
path <- here("inst", "2021", "day14.txt")
# Read in polymer template
test_template <- get_template(test)
template <- get_template(path)
# Read in pair insertion rules
test_rules <- get_rules(test)
rules <- get_rules(path)
# Run simulation
assertthat::assert_that(polymerization(test_template, test_rules, 10) == 1588)## [1] TRUE0.073 sec.
# What do you get if you take the quantity of the most common element and
# subtract the quantity of the least common element?
polymerization(template, rules, 10)## [1] 20270.041 sec.
Part 2
The second part asks for 40 iterations, which would take far too long using the same method used in part 1 (keeping track of an ever-growing string). So instead, we count the frequency of each pair.
#' @rdname day14
#' @export
#'
polymerization2 <- function(template, rules, n) {
first <- template[1]
template <- convert_template(template) |>
dplyr::mutate(count = 1)
for (i in seq_len(n)) {
tmp <- dplyr::left_join(template, rules, by = c("first", "last"))
set1 <- tmp |> dplyr::select(-last) |> dplyr::rename(last = insert)
set2 <- tmp |> dplyr::select(-first) |> dplyr::rename(first = insert)
pairs <- rbind(set1, set2)
counts <- pairs |>
dplyr::group_by(first, last) |>
dplyr::summarise(count = sum(count), .groups = "drop")
template <- counts
}
# Final count
total <- template |>
dplyr::select(-first) |>
dplyr::group_by(last) |>
dplyr::summarise(count = sum(count)) |>
dplyr::mutate(count = dplyr::case_when(last == first ~ count + 1,
TRUE ~ count))
max(total$count) - min(total$count)
}
# Apply 40 steps of pair insertion to the polymer template and find the
# most and least common elements in the result
assertthat::assert_that(
polymerization2(test_template, test_rules, 40) == 2188189693529)## [1] TRUE
# What do you get if you take the quantity of the most common element
# and subtract the quantity of the least common element?
polymerization2(template, rules, 40) |>
format(scientific = FALSE)## [1] "2265039461737"0.424 sec.
Day 15: Chiton
Day 16: Packet Decoder
Day 17: Trick Shot
Part 1
#' Day 17: Trick Shot
#' @source <https://adventofcode.com/2021/day/17>
#' @name day17
#'
NULL
#' @rdname day17
#' @param path file path
#' @export
#'
read_day17 <- function(path) {
dat <- path |>
readLines()
# Extract target coordinates
xrange <- gsub("^.*x=(.*)\\.\\.(.*),.*$", "\\1 \\2", dat) |>
strsplit(" ") |>
unlist() |>
as.numeric()
yrange <- gsub("^.*y=(.*)\\.\\.(.*)$", "\\1 \\2", dat) |>
strsplit(" ") |>
unlist() |>
as.numeric()
list(xrange = xrange, yrange = yrange)
}
#' @rdname day17
#' @param xrange xrange
#' @param yrange yrange
#' @export
#'
simulate_launch <- function(xrange, yrange) {
start <- c(0, 0)
velocity <- c(0, 1)
n <- 1
results <- data.frame()
for (i in 1:120) {
trial <- data.frame(trial = n,
step = 0,
x = start[1],
y = start[2],
vx = velocity[1],
vy = velocity[2])
results <- rbind(results, launch(trial, n, xrange, yrange))
n <- n + 1
if (tail(results, 1)$x < xrange[1]) {
velocity[1] <- velocity[1] + 1
} else if (tail(results, 1)$x > xrange[2]) {
velocity[1] <- velocity[1] - 1
} else {
velocity[2] <- velocity[2] + 1
}
}
this_trial <- results |>
dplyr::filter(hit == T) |>
dplyr::filter(y == max(y)) |>
dplyr::pull(trial) |>
unique()
# Initial y velocity
results |>
dplyr::filter(trial == this_trial,
step == 0) |>
dplyr::pull(vy)
# What is the highest y position it reaches on this trajectory?
results |>
dplyr::filter(trial == this_trial) |>
dplyr::filter(y == max(y)) |>
dplyr::pull(y) |>
unique()
}
#' @description Move one step
#' @rdname day17
#' @param status last step
#'
move <- function(status) {
x <- status$x + status$vx
y <- status$y + status$vy
vx <- status$vx
vy <- status$vy
vx <- dplyr::if_else(vx > 0, vx - 1,
dplyr::if_else(vx < 0, vx + 1, vx))
vy <- vy - 1
data.frame(x = x, y = y, vx = vx, vy = vy)
}
#' @description Launch probe until target is hit or overshot
#' @rdname day17
#'
launch <- function(df, trial, xrange, yrange) {
continue <- TRUE
step <- 1
while (continue) {
update <- move(tail(df, 1))
df <- rbind(df, mutate(trial = trial, step = step, update))
foundtarget <- dplyr::if_else(
update$x >= xrange[1] & update$x <= xrange[2] &
update$y >= yrange[1] & update$y <= yrange[2],
TRUE, FALSE)
overshot <- dplyr::if_else(update$x > xrange[2] | update$y < yrange[2],
TRUE, FALSE)
continue <- dplyr::if_else(foundtarget | overshot, FALSE, TRUE)
step <- step + 1
}
mutate(df, hit = foundtarget)
}
# Read in data
path <- here("inst", "2021", "day17.txt")
dat <- read_day17(path)
xrange <- dat$xrange
yrange <- dat$yrange
# Find the initial velocity that causes the probe to reach the highest y
# position and still eventually be within the target area after any step
simulate_launch(xrange, yrange)## [1] 316018.235 sec.
Part 2
#' @rdname day17
#' @export
#'
find_possibilities <- function(xrange, yrange) {
# Minimum x_velocity (when x_velocity = i, distance in x axis = cumsum(1:i))
xv_min <- optimize(function(x) abs(max(cumsum(1:x)) - xrange[1]), 1:10) |>
purrr::pluck("minimum") |> round()
# Which velocities might hit the target?
poss_xv <- possible_x(range = xrange,
min_v = xv_min,
max_v = 500)
poss_yv <- possible_y(range = yrange,
min_v = -2500,
max_v = 500)
expand.grid(poss_xv, poss_yv) |>
dplyr::rename(xv = Var1, yv = Var2)
}
#' @rdname day17
#' @param velocities velocities
#' @export
#'
simulate_launch2 <- function(velocities, xrange, yrange) {
lapply(seq_len(nrow(velocities)), function(i) {
# Extract velocities
xv <- velocities$xv[i]
yv <- velocities$yv[i]
# Calculate trajectory
z <- max(abs(yrange))
if (yv > 0) {
y <- c(0, cumsum(seq(yv, 1, -1)))
y <- c(y, rev(y), -cumsum((yv + 1):(yv * z)))
} else if (yv < 0) {
y <- c(0, cumsum(yv:(yv * z)))
} else {
y <- c(0, 0)
subtract <- 1
while (min(y) > yrange[1]) {
y <- c(y, (tail(y, 1) - subtract))
subtract <- subtract + 1
}
}
x <- c(0, cumsum(seq(xv, 1, -1)))
if (length(x) > length(y)) {
y <- c(y, rep(tail(y, 1), length(x) - length(y)))
} else {
x <- c(x, rep(tail(x, 1), length(y) - length(x)))
}
# Paste coordinates together
trajectory <- cbind.data.frame(x = x, y = y)
# Check whether points have hit the target
hit <- trajectory |>
dplyr::filter(between(x, xrange[1], xrange[2]),
between(y, yrange[1], yrange[2]))
if (nrow(hit) != 0) {
out <- data.frame(xv = xv,
yv = yv,
y_max = max(trajectory$y))
} else {
out <- NULL
}
out
}) |>
do.call(what = rbind)
}
#' @description Test which velocities might hit the target
#' @rdname day17
#' @param range range of target
#' @param min_v minimum velocity to try
#' @param max_v maximum velocity to try
possible_x <- function(range, min_v, max_v) {
output <- c()
for (v in min_v:max_v) {
# Calculate position of points
points <- cumsum(seq(v, 1, -1))
# Check if any points hit the target zone
if (any(between(points, min(range), max(range))))
output <- c(output, v)
}
output
}
#' @description Test which velocities might hit the target
#' @rdname day17
possible_y <- function(range, min_v, max_v) {
output <- c()
for (v in min_v:max_v) {
z <- max(abs(range))
# Calculate position of points below the x axis
if (v > 0) {
points <- -cumsum((v + 1):(v * z))
} else if (v < 0) {
points <- cumsum(seq(v, (v * z), -1))
} else {
points <- 0
subtract <- 1
while (min(points) > range[1]) {
points <- c(points, (tail(points, 1) - subtract))
subtract <- subtract + 1
}
}
# Check if any points hit the target zone
if (any(between(points, min(range), max(range))))
output <- c(output, v)
}
output
}
velocities <- find_possibilities(xrange, yrange)
results <- simulate_launch2(velocities, xrange, yrange)
# Find the initial velocity that causes the probe to reach the highest y
# position and still eventually be within the target area after any step
results |>
dplyr::filter(y_max == max(y_max))## xv yv y_max
## 1 24 79 3160
# What is the highest y position it reaches on this trajectory?
results |>
dplyr::filter(y_max == max(y_max)) |>
dplyr::pull(y_max) |>
unique()## [1] 3160
# How many distinct initial velocity values cause the probe to be within the
# target area after any step?
results |>
dplyr::select(xv, yv) |>
unique() |>
nrow()## [1] 192827.904 sec.
Day 18: Snailfish
Part 1
#' Day 18: Snailfish
#' @source <https://adventofcode.com/2021/day/18>
#' @name day18
#'
NULL
#' @rdname day18
#' @param path file path
#' @export
#'
read_day18 <- function(path) {
path |>
readLines()
}
#' @rdname day18
#' @param dat dat
#' @export
#'
snailfish_maths <- function(dat) {
first <- dat[1]
for (i in tail(seq_along(dat), -1)) {
result <- add_snailfish(first, dat[i])
first <- result
}
check_magnitude(result)
}
# Function to check magnitude of answer
check_magnitude <- function(answer) {
while(length(answer) != 1) {
count <- 1
depth <- 1
for (i in tail(seq_along(answer), -1)) {
if (answer[i] == "[") {
count <- count + 1
} else if (answer[i] == "]") {
count <- count - 1
}
depth[i] <- count
}
deepest <- which(depth == max(depth))
index <- R.utils::seqToIntervals(deepest) |>
data.frame() |>
dplyr::pull(from) |>
rev() + 1
for (j in index) {
first <- 3 * as.numeric(answer[j])
second <- 2 * as.numeric(answer[j + 2])
answer <- answer[-c(j:(j + 3))]
answer[j - 1] <- first + second
}
}
return(as.numeric(answer))
}
# Add snailfish numbers
add_snailfish <- function(first, second) {
if (length(first) > 1)
first <- paste(first, collapse = "")
paste0("[", first, ",", second, "]") |>
strsplit("") |>
unlist() |>
reduce_snailfish()
}
# Function to reduce a snailfish number
reduce_snailfish <- function(dat) {
try_this <- dat
continue <- TRUE
it_split <- FALSE
while (continue) {
result <- explode(try_this)
it_exploded <- !all(is.na(result))
if (it_exploded) {
try_this <- result
it_split <- FALSE
} else {
result <- split(try_this)
it_split <- !all(is.na(result))
if (!it_exploded & !it_split) {
return(try_this)
} else {
try_this <- result
}
}
}
}
# Function to check for and carry out explosion
explode <- function(dat) {
count <- 0
i <- 1
left <- NA
right <- NA
# Check for explosion
while(i != length(dat)) {
if (dat[i] == "[") {
count <- count + 1
} else if (grepl("[0-9]", dat[i])) {
if (dat[i + 1] == "," & grepl("[0-9]", dat[i + 2]) & count > 4) {
right <- head(grep("[0-9]", dat[(i + 3):length(dat)]), 1) + i + 2
if (length(right) == 0) right <- NA
left <- tail(grep("[0-9]", dat[1:(i - 1)]), 1)
if (length(left) == 0) left <- NA
break
}
} else if (dat[i] == "]") {
count <- count - 1
}
i <- i + 1
}
# Explode
if (is.na(left) & is.na(right)) {
return(NA)
} else if (is.na(left)) {
tmp <- dat
tmp[right] <- as.numeric(dat[right]) + as.numeric(dat[i + 2])
tmp <- tmp[-c(i:(i + 3))]
tmp[i - 1] <- 0
return(tmp)
} else if (is.na(right)) {
tmp <- dat[-c(i:(i + 3))]
tmp[i - 3] <- as.numeric(dat[left]) + as.numeric(dat[i])
tmp[i - 1] <- 0
return(tmp)
} else {
tmp <- dat
tmp[left] <- as.numeric(dat[left]) + as.numeric(dat[i])
tmp[right] <- as.numeric(dat[right]) + as.numeric(dat[i + 2])
tmp <- tmp[-c(i:(i + 3))]
tmp[i - 1] <- 0
return(tmp)
}
}
# Function to check for and carry out split
split <- function(dat) {
# Check for split
index <- NA
for (i in seq_along(dat)) {
if (grepl("[0-9]", dat[i]) && as.numeric(dat[i]) >= 10) {
index <- i
break
}
}
# Split
if (is.na(index)) {
return(NA)
} else {
left <- dat[1:(index - 1)]
right <- dat[(index + 1):length(dat)]
tmp <- as.numeric(dat[index])
tmp <- c("[", floor(tmp / 2), ",", ceiling(tmp / 2), "]")
return(c(left, tmp, right))
}
}
path <- here("inst", "2021", "day18.txt")
dat <- read_day18(path)
# Add up all of the snailfish numbers from the homework assignment in the
# order they appear. What is the magnitude of the final sum?
snailfish_maths(dat)## [1] 41164.849 sec.
Part 2
#' @rdname day11
#' @param dat dat
#' @export
#'
snailfish_maths2 <- function(dat) {
n <- length(dat)
combinations <- expand.grid(1:n, 1:n) |>
dplyr::filter(Var1 != Var2)
results <- c()
for (i in seq_len(nrow(combinations))) {
# cat("\r", i, "of", nrow(combinations))
first <- combinations$Var1[i]
second <- combinations$Var2[i]
results[i] <- add_snailfish(dat[first], dat[second]) |>
check_magnitude()
}
max(results)
}
# What is the largest magnitude of any sum of two different snailfish numbers
# from the homework assignment?
snailfish_maths2(dat)## [1] 463893.588 sec.
Day 19: Beacon Scanner
Part 1
#' Day 19: Beacon Scanner
#' @source <https://adventofcode.com/2021/day/19>
#' @name day19
#'
NULL
#' @rdname day19
#' @param path file path
#' @export
#'
read_day19 <- function(path) {
dat <- path |>
readLines() |>
data.frame() |>
setNames("data")
start <- grep("scanner", dat$data)
end <- c(tail(start - 1, -1), nrow(dat))
lapply(seq_along(start), function(x) {
tmp <- dat[start[x]:end[x], ]
tmp <- tmp[-1]
index <- which(tmp == "")
if (length(index) != 0)
tmp <- tmp[-index]
out <- data.frame(data = tmp) |>
tidyr::separate(col = data, into = c("d1", "d2", "d3"), sep = ",") |>
dplyr::mutate_if(is.character, as.numeric) |>
as.matrix()
colnames(out) <- NULL
out
})
}
#' @rdname day19
#' @param scans scans
#' @export
#'
assemble_map <- function(scans) {
transformations <- get_combinations(1:3)
scanners <- data.frame(scanner = 0, x = 0, y = 0, z = 0)
while(nrow(scanners) != length(scans)) {
results <- list()
# Compare each scanner output to that of scanner 0
for (i in tail(seq_along(scans), -1)) {
# cat("\r", i, "of", length(scans), "-",
# length(scans) - nrow(scanners), "left to find...")
if ((i - 1) %in% scanners$scanner) next
scanner_zero <- scans[[1]]
scanner_i <- scans[[i]]
for (j in seq_len(nrow(transformations))) {
this_transformation <- transformations[j, ]
# Transform `scanner_i` by `this_transformation`
transformed_scanner <- transform_all(scanner_i, this_transformation)
# Try subtracting each beacon coordinate in `scanner_zero` from each
# beacon coordinate in `transformed_scanner` (transformation of
# `scanner_i`)
subtract <- lapply(seq_len(nrow(scanner_zero)), function(x)
apply(transformed_scanner, 1, function(y) y - scanner_zero[x, ]) |>
t()) |>
do.call(what = rbind.data.frame) |>
tidyr::unite(unscramble) |>
dplyr::group_by(unscramble) |>
dplyr::summarize(n = dplyr::n())
# If 12 or more matches are found, record the scanner position
if (max(subtract$n) >= 12) {
this_coordinate <- subtract |>
dplyr::filter(n == max(n)) |>
tidyr::separate(unscramble, c("x", "y", "z"), sep = "_") |>
dplyr::select(-n) |>
data.frame() |>
dplyr::mutate_if(is.character, as.numeric)
colnames(this_coordinate) <- c("x", "y", "z")
scanners <- rbind(scanners,
cbind(scanner = i - 1, this_coordinate))
results[[i]] <- list(scanner1 = 0,
scanner2 = i - 1,
beacon = this_coordinate,
transformation = this_transformation)
break
}
}
}
# Which beacons can see each other?
relatives <- lapply(seq_along(results), function(x)
if (is.null(results[[x]])) {
NA
} else {
data.frame(from = results[[x]]$scanner1,
to = results[[x]]$scanner2)
}
) |>
do.call(what = rbind)
# Append new beacon coordinates to scanner outputs
for (k in seq_len(nrow(relatives))) {
if (all(is.na(relatives[k,]))) next
tmp <- results[[k]]
from <- relatives$from[k] + 1
to <- relatives$to[k] + 1
# Transform `to` scanner coordinates relative to `from` scanner coordinates
transformed_to <- transform_all(scans[[to]], tmp$transformation) |>
apply(1, function(x) x - tmp$beacon) |>
do.call(what = rbind)
colnames(transformed_to) <- c("X1", "X2", "X3")
# Add beacon coordinates to `from` scanner
scans[[from]] <- transformed_to |>
dplyr::anti_join(data.frame(scans[[from]]),
by = c("X1", "X2", "X3")) |>
as.matrix() |>
rbind(scans[[from]]) |>
unique()
}
}
list(scanners = scanners, scans = scans)
}
get_combinations <- function(x) {
x |> spin_and_flip() |>
reorient() |>
spin_and_flip() |>
reorient() |>
spin_and_flip()
}
spin_and_flip <- function(x) {
x |> spin() |> flip() |> spin()
}
# Spin around an axis
spin <- function(x) {
vec <- if(is.vector(x)) x else tail(x, 1)
for (i in 1:3) {
vec <- c(vec[3], vec[2], -vec[1])
x <- rbind(x, vec)
}
unname(x)
}
# Turn upside down
flip <- function(x) {
vec <- if(is.vector(x)) x else tail(x, 1)
vec <- c(-vec[1], -vec[2], vec[3])
rbind(x, vec) |>
unname()
}
# Take the next axis as up
reorient <- function(x) {
vec <- if(is.vector(x)) x else tail(x, 1)
vec <- c(vec[3], vec[1], vec[2])
rbind(x, vec) |>
unname()
}
transform_all <- function(scanner_output, transformation) {
lapply(seq_len(nrow(scanner_output)), function(x)
transform(scanner_output[x, ], transformation)) |>
do.call(what = rbind)
}
transform <- function(coordinate, transformation) {
index <- abs(transformation)
sign <- vapply(transformation, function(x) if (x > 0) 1 else -1, numeric(1))
reindex <- c(coordinate[index[1]], coordinate[index[2]], coordinate[index[3]])
reindex * sign
}
path <- here("inst", "2021", "day19.txt")
scans <- read_day19(path)
# How many beacons are there?
tmp <- assemble_map(scans)
scans <- tmp$scans
scans[[1]] |>
unique() |>
nrow()## [1] 330161.047 sec.
Part 2
#' @rdname day11
#' @param scanners scanners
#' @export
#'
dist_scanners <- function(scanners) {
index <- seq_len(nrow(scanners)) - 1
combinations <- t(combn(index, 2))
res <- lapply(seq_len(nrow(combinations)), function(x) {
first <- combinations[x, 1]
second <- combinations[x, 2]
a <- scanners |>
dplyr::filter(scanner == first) |>
dplyr::select(-scanner) |> unlist()
b <- scanners |>
dplyr::filter(scanner == second) |>
dplyr::select(-scanner) |> unlist()
manhattan(a, b)
}) |> unlist()
max(res)
}
manhattan <- function(a, b) {
abs(a - b) |>
sum()
}
# What is the largest Manhattan distance between any two scanners?
scanners <- tmp$scanners
dist_scanners(scanners)## [1] 96341.543 sec.
Day 20: Trench Map
Part 1
#' Day 20: Trench Map
#' @source <https://adventofcode.com/2021/day/20>
#' @name day20
#'
NULL
#' @rdname day20
#' @param path file path
#' @export
#'
get_algorithm <- function(path) {
path |>
readLines(n = 1) |>
strsplit("") |>
unlist()
}
#' @rdname day20
#' @export
#'
get_input <- function(path) {
path |>
scan(what = "character", skip = 2) |>
vapply(function(x) as.data.frame(strsplit(x, "")[[1]]),
data.frame(1)) |>
do.call(what = rbind) |>
unname()
}
#' @rdname day20
#' @param img img
#' @export
#'
view_image <- function(img) {
expand.grid(seq_len(nrow(img)), seq_len(nrow(img))) |>
setNames(c("row", "col")) |>
dplyr::left_join(which(img == "#", arr.ind = TRUE) |>
cbind.data.frame(what = "hash"), by = c("row", "col")) |>
dplyr::mutate(what = dplyr::case_when(is.na(what) ~ "dot",
TRUE ~ what)) |>
ggplot2::ggplot() + ggplot2::theme_void() +
ggplot2::geom_tile(ggplot2::aes(x = row, y = col, fill = what)) +
ggplot2::scale_fill_manual(values = setNames(c("black", "white"),
c("hash", "dot"))) +
ggplot2::coord_fixed() +
ggplot2::theme(legend.position = "none")
}
#' @rdname day20
#' @param input input
#' @param n n
#' @param algorithm algorithm
#' @export
#'
enhance_image <- function(input, n, algorithm) {
img <- input
odd <- TRUE
first <- head(algorithm, 1)
second <- tail(algorithm, 1)
# When the first element of the algorithm doesn't match the last one, change
# the composition of the image border with each iteration
correction <- first != second
for (i in seq_len(n)) {
if (correction)
pad <- ifelse(odd, second, first)
img <- img |>
scan_input(pad) |>
output_pixel(algorithm) |>
generate_image()
odd <- !odd
}
img
}
scan_input <- function(input, pad) {
with_buffer <- rbind(pad, pad, input, pad, pad)
with_buffer <- cbind(pad, pad, with_buffer, pad, pad) |> unname()
index <- 2:(ncol(with_buffer) - 1)
input_coords <- lapply(index, function(x) cbind(x = x, y = index)) |>
do.call(what = rbind.data.frame)
lapply(seq_len(nrow(input_coords)), function(x) {
index <- with_buffer |>
get_pixels(unlist(input_coords[x, ])) |>
pix2bin()
data.frame(index = index,
x = input_coords$x[x] - 1,
y = input_coords$y[x] - 1)
}) |>
do.call(what = rbind)
}
output_pixel <- function(values, algorithm) {
values |>
dplyr::rowwise() |>
dplyr::mutate(pixel = dplyr::nth(algorithm, index + 1)) |>
dplyr::select(-index) |>
data.frame()
}
generate_image <- function(values) {
matrix(values$pixel, ncol = max(values$y), nrow = max(values$x),
byrow = TRUE)
}
get_pixels <- function(input, coord) {
rows <- (coord[1] - 1):(coord[1] + 1)
cols <- (coord[2] - 1):(coord[2] + 1)
input[rows, cols]
}
# Convert matrix of input pixels into a decimal number
pix2bin <- function(pixels) {
tmp <- pixels |>
t() |>
matrix(nrow = 1)
as.numeric(tmp == "#") |>
paste(collapse = "") |>
strtoi(base = 2)
}
# Start with the original input image and apply the image enhancement
# algorithm twice, being careful to account for the infinite size of the
# images
path <- here("inst", "2021", "day20.txt")
input <- get_input(path)
algorithm <- get_algorithm(path)
img <- enhance_image(input, 2, algorithm)
view_image(img)
# How many pixels are lit in the resulting image?
sum(img == "#")## [1] 56637.835 sec.
Part 2
# Start again with the original input image and apply the image enhancement algorithm 50 times
img <- enhance_image(input, 50, algorithm)
# How many pixels are lit in the resulting image?
sum(img == "#")## [1] 19638405.446 sec.
Day 21: Dirac Dice
Part 1
#' Day 21: Dirac Dice
#' @source <https://adventofcode.com/2021/day/21>
#' @name day21
#'
NULL
#' @rdname day21
#' @param path file path
#' @export
#'
read_day21 <- function(path) {
path |>
readLines()
}
#' @rdname day21
#' @param dat dat
#' @export
#'
deterministic <- function(dat) {
start <- dat |>
vapply(function(x) gsub(".*([0-9])$", "\\1", x),
character(1)) |>
as.numeric()
pos1 <- start[1]
pos2 <- start[2]
score1 <- 0
score2 <- 0
i <- 0
while (all(c(score1, score2) < 1000)) {
i <- i + 1
if (i%%2 != 0) {
pos1 <- pos1 + sum(((i * 3) - 2):(i * 3))
pos1 <- dplyr::if_else(pos1 > 10, pos1%%10, pos1)
pos1 <- dplyr::if_else(pos1 == 0, 10, pos1) # since pos1 = 100 returns 0
score1 <- score1 + pos1
} else {
pos2 <- pos2 + sum(((i * 3) - 2):(i * 3))
pos2 <- dplyr::if_else(pos2 > 10, pos2%%10, pos2)
pos2 <- dplyr::if_else(pos2 == 0, 10, pos2)
score2 <- score2 + pos2
}
}
min(score1, score2) * i * 3
}
# Play a practice game using the deterministic 100-sided die
path <- here("inst", "2021", "day21.txt")
dat <- read_day21(path)
# The moment either player wins, what do you get if you multiply the score of
# the losing player by the number of times the die was rolled during the game?
deterministic(dat)## [1] 5984160.041 sec.
Day 22: Reactor Reboot
Part 1
#' Day 22: Reactor Reboot
#' @source <https://adventofcode.com/2021/day/22>
#' @name day22
#'
NULL
#' @rdname day22
#' @param path file path
#' @export
#'
read_day22 <- function(dat, limit) {
regex <- paste0("(\\D*)\\sx=(-?\\d*)..(-?\\d*),y=(-?\\d*)..(-?\\d*),",
"z=(-?\\d*)..(-?\\d*)")
out <- dat |> data.frame() |>
setNames("x") |>
tidyr::extract(x, c("on", "x1", "x2", "y1", "y2", "z1", "z2"),
regex) |>
dplyr::mutate(on = dplyr::if_else(on == "on", TRUE, FALSE)) |>
dplyr::mutate_if(is.character, as.numeric)
if(missing(limit)) {
limit <- max(max(out), abs(min(out)))
}
# Reset minimum to 1
dplyr::mutate_if(out, is.numeric, \(z) z + limit + 1)
}
#' @rdname day22
#' @param dat dat
#' @export
#'
reboot <- function(dat) {
reactor <- array(FALSE, dim = c(101, 101, 101))
for (i in seq_len(nrow(dat))) {
# Are any coordintes outside the range?
test <- dat[i, ] |>
unlist() |>
tail(-1) |>
{\(x) dplyr::between(x, 1, max(dim(reactor)))}() |>
all()
if (test) {
reactor <- get_indices(dat[i, ], reactor)
} else {
next
}
}
sum(reactor)
}
get_indices <- function(df, reactor) {
reactor[df$x1:df$x2, df$y1:df$y2, df$z1:df$z2] <- df$on
reactor
}
# Read in data
test <- here("inst", "2021", "day22-test.txt")
path <- here("inst", "2021", "day22.txt")
test_dat <- readLines(test) |> read_day22(50)
dat <- readLines(path) |> read_day22(50)
# Execute the reboot steps
assertthat::assert_that(reboot(test_dat) == 590784)## [1] TRUE
# Considering only cubes in the region x=-50..50,y=-50..50,z=-50..50, how many
# cubes are on?
reboot(dat)## [1] 6442570.145 sec.
Day 23: Amphipod
Day 24: Arithmetic Logic Unit
Day 25: Sea Cucumber
Part 1
#' Day 25: Sea Cucumber
#' @source <https://adventofcode.com/2021/day/25>
#' @name day25
#'
NULL
#' @description Read in cucumber positions
#' @rdname day25
#' @param path file path
#' @export
#'
read_day25 <- function(path) {
path |>
readLines() |>
strsplit("") |>
do.call(what = rbind)
}
#' @rdname day25
#' @param dat dat
#' @export
#'
get_cucumbers <- function(dat) {
east_cucumbers <- which(dat == ">", arr.ind = TRUE) |>
data.frame() |>
dplyr::mutate(type = "east")
south_cucumbers <- which(dat == "v", arr.ind = TRUE) |>
data.frame() |>
dplyr::mutate(type = "south")
rbind(east_cucumbers, south_cucumbers) |>
dplyr::mutate_if(is.numeric, as.double)
}
#' @rdname day25
#' @param dat dat
#' @param cucumbers cucumbers
#' @export
#'
simulate_cucumbers <- function(dat, cucumbers) {
# Initialise variables
track_cucumbers <- sea_cucumbers$new(dat, cucumbers)
continue <- TRUE
i <- 0
# Find somewhere safe to land your submarine
while (continue) {
i <- i + 1
# cat("\r", i)
track_cucumbers$move_east()
track_cucumbers$move_south()
continue <- track_cucumbers$continue_east | track_cucumbers$continue_south
}
i
}
sea_cucumbers <- R6::R6Class("cucumbers", list(
dat = NULL,
cucumbers = NULL,
continue_east = NULL,
continue_south = NULL,
plot = NULL,
initialize = function(dat, cucumbers) {
self$dat <- dat
self$cucumbers <- dplyr::mutate(cucumbers, id = dplyr::row_number())
self$continue_east <- TRUE
self$continue_south <- TRUE
invisible(self)
},
print = function(...) {
cat("\n")
for (i in seq_len(nrow(self$dat))) {
cat(self$dat[i, ], "\n")
}
invisible(self)
},
move_east = function() {
dat <- self$dat
cucumbers <- self$cucumbers
boundary <- ncol(dat) + 1
# Determine which cucumbers move
tmp <- cucumbers |>
dplyr::mutate(prev = col,
col = dplyr::case_when(type == "east" ~ col + 1,
TRUE ~ col)) |>
dplyr::mutate(col = dplyr::case_when(col == boundary ~ 1,
TRUE ~ col))
# These do
moved <- tmp |>
dplyr::filter(type == "east") |>
dplyr::anti_join(cucumbers, by = c("row", "col"))
# These don't
stationary <- dplyr::anti_join(cucumbers,
dplyr::select(moved, -prev), by = c("id"))
# Move cucumbers east
dat[as.matrix(dplyr::select(moved, row, col))] <- ">"
# Place a dot in their previous position
prev <- dplyr::select(moved, row, prev)
dat[as.matrix(prev)] <- "."
# Update the cucumber list
self$cucumbers <- moved |>
dplyr::select(-prev) |>
rbind(stationary)
# Update objects
self$dat <- dat
self$continue_east <- nrow(moved) > 0
invisible(self)
},
move_south = function(display = FALSE) {
dat <- self$dat
cucumbers <- self$cucumbers
boundary <- nrow(dat) + 1
# Determine which cucumbers move
tmp <- cucumbers |>
dplyr::mutate(prev = row,
row = dplyr::case_when(type == "south" ~ row + 1,
TRUE ~ row)) |>
dplyr::mutate(row = dplyr::case_when(row == boundary ~ 1,
TRUE ~ row))
# These do
moved <- tmp |>
dplyr::filter(type == "south") |>
dplyr::anti_join(cucumbers, by = c("row", "col"))
# These don't
stationary <- dplyr::anti_join(cucumbers,
dplyr::select(moved, -prev), by = c("id"))
# Move cucumbers south
dat[as.matrix(dplyr::select(moved, row, col))] <- "v"
# Place a dot in their previous position
prev <- dplyr::select(moved, prev, col)
dat[as.matrix(prev)] <- "."
# Update the cucumber list
self$cucumbers <- moved |>
dplyr::select(-prev) |>
rbind(stationary)
# Update objects
self$dat <- dat
self$continue_south <- nrow(moved) > 0
# Print to console
if (display) print(self)
invisible(self)
},
gg_cucumbers = function() {
rows <- seq_len(nrow(self$dat))
cols <- seq_len(ncol(self$dat))
fill <- c("#489FB5", "#EDE7E3", "#FFA62B")
self$cucumbers |>
dplyr::select(-id) |>
tidyr::complete(row = rows, col = cols,
fill = list(type = "empty")) |>
dplyr::mutate(text = dplyr::case_when(type == "south" ~ "v",
type == "east" ~ ">",
TRUE ~ "")) |>
ggplot2::ggplot(ggplot2::aes(x = col, y = row, fill = type)) +
ggplot2::theme_void() + ggplot2::coord_fixed() +
ggplot2::scale_y_reverse() +
ggplot2::scale_fill_manual(values = fill) +
ggplot2::geom_tile() +
ggplot2::geom_text(ggplot2::aes(label = text)) +
ggplot2::theme(legend.position = "none")
}
))
# Read in data
path <- here("inst", "2021", "day25.txt")
dat <- read_day25(path)
cucumbers <- get_cucumbers(dat)
# What is the first step on which no sea cucumbers move?
simulate_cucumbers(dat, cucumbers)## [1] 53014.852 sec.
