Add 2025 day 25.

We want to change Aoc.main to take a single printer parameter to
simplify the run process.

.ocamlformat

@@ -1 +1,2 @@
-version = 0.26.2
+version = 0.27.0
+exp-grouping = preserve

bin/day2401.ml

@@ -1,12 +1,12 @@
-(** [pair_nums_from_string s] takes a string of two numbers separated by 
+(** [pair_nums_from_string s] takes a string of two numbers separated by
     whitespace and returns the pair of the numbers *)
 let pair_ints_of_string s =
-  match Aoc.ints_of_string s with
+  match Aoc.ints_of_string ~sep:" " s with
   | [ h; h' ] -> (h, h')
   | _ -> raise (Invalid_argument "pair_nums_from_string")
 
-(** [rev_split lst] takes a list of pairs and returns a pair of lists.  Is 
+(** [rev_split lst] takes a list of pairs and returns a pair of lists. Is
-    equivalent to List.split (List.rev lst) but more efficient (and tail 
+    equivalent to List.split (List.rev lst) but more efficient (and tail
     recursive). *)
 let rev_split lst =
   let rec impl acc acc' = function
@@ -16,7 +16,7 @@ let rev_split lst =
   impl [] [] lst
 
 (** [count lst n] counts the number of times [n] appears as an element in [lst].
-    *)
+*)
 let count lst n =
   List.fold_left (fun acc x -> if x = n then acc + 1 else acc) 0 lst
 

bin/day2405.ml

@@ -1,23 +1,20 @@
 module IntSet = Set.Make (Int)
-module IntMap = Map.Make (Int)
 
 (** [add_rule a b m] adds the rule that [a] must appear before [b] to the rule
-    map [m]. *)
+    map [m]. Returns the updated map [m] *)
-let add_rule a b =
+let add_rule a b m =
-  let update_rule = function
+  match Hashtbl.find_opt m a with
-    | None -> Some (IntSet.singleton b)
+  | None -> Hashtbl.add m a (IntSet.singleton b)
-    | Some s -> Some (IntSet.add b s)
+  | Some s -> Hashtbl.replace m a (IntSet.add b s)
-  in
-  IntMap.update a update_rule
 
 (** [find_rule a b m] returns [true] if the rule map [m] says that [a] should
     appear before [b]. *)
 let find_rule a b m =
-  match IntMap.find_opt a m with
+  match Hashtbl.find_opt m a with
   | Some s -> ( match IntSet.find_opt b s with Some _ -> true | None -> false)
   | None -> false
 
-(** [compare m a b] is a total ordering on pages in the rule map [m].  Returns
+(** [compare m a b] is a total ordering on pages in the rule map [m]. Returns
     [-1] if [a] should appear before [b], [0] if [a = b], and [1] if [b] should
     appear before [a]. *)
 let compare m a b =
@@ -38,27 +35,28 @@ let rec is_page_order_valid m pages =
   in
   match pages with h :: t -> impl h t && is_page_order_valid m t | [] -> true
 
-(** [parse_rules lst] parses the rules in the list [lst] stopping when 
+(** [parse_rules lst] parses the rules in the list [lst] stopping when
-    encountering an empty line.  Returns a pair [(rule_map, tail)]. 
+    encountering an empty line. Returns a pair [(rule_map, tail)]. [tail] starts
-    [tail] starts the line after the empty line. *)
+    the line after the empty line. *)
 let parse_rules =
-  let re = Str.regexp_string "|" in
+  let m = Hashtbl.create 17 in
-  let rec impl acc = function
+  let rec impl = function
-    | "" :: t -> (acc, t)
+    | "" :: t -> (m, t)
     | [] -> failwith "parse_rules.impl"
     | h :: t -> (
-        match List.map int_of_string (Str.split re h) with
+        match Aoc.ints_of_string ~sep:"|" h with
-        | [ a; b ] -> impl (add_rule a b acc) t
+        | [ a; b ] ->
+            add_rule a b m;
+            impl t
         | _ -> failwith "parse_rules.impl")
   in
-  impl IntMap.empty
+  impl
 
-(** [parse_page_orders lst] parses a list of page orders.  *)
+(** [parse_page_orders lst] parses a list of page orders. *)
 let parse_page_orders =
-  let re = Str.regexp_string "," in
   let rec impl acc = function
     | [] -> acc
-    | h :: t -> impl (List.map int_of_string (Str.split re h) :: acc) t
+    | h :: t -> impl (Aoc.ints_of_string ~sep:"," h :: acc) t
   in
   impl []
 

bin/day2406.ml

@@ -0,0 +1,80 @@
+(** [find_start strs] returns the location [(x, y)] of the starting position. *)
+let find_start map =
+  match Aoc.Grid.idx_from_opt map 0 '^' with
+  | Some i -> Aoc.Grid.pos_of_idx map i
+  | None -> failwith "find_start"
+
+(** [read_file fname] reads the input map from [fname]. It returns a
+    [(map, pos, vel)] tuple, consisting of the obsticle map, initial position,
+    and initial velocity. *)
+let read_file fname =
+  let map = Aoc.Grid.of_file fname in
+  let pos = find_start map in
+  (map, pos, (0, -1))
+
+(** [is_block map pos] returns [true] iff the location [pos] is a blockages in
+    [map]. *)
+let is_block map pos =
+  if Aoc.Grid.pos_is_valid map pos then Aoc.Grid.get_by_pos map pos = '#'
+  else false
+
+(** [insert_block map pos] inserts a blockage at [pos] into [map] and returns
+    the new map. *)
+let insert_block map pos = Aoc.Grid.update_pos map pos '#'
+
+(** [move map (pos, vel)] moves [pos] one step forward on the [map]. [vel] gives
+    the movement vector. If the movement will cause an obstacle to be hit then
+    [vel] is rotated right by 90 degrees and we move in that direction. Returns
+    the updated [(pos, vel)] pair. *)
+let rec move map ((x, y), (dx, dy)) =
+  let x', y' = (x + dx, y + dy) in
+  if is_block map (x', y') then move map ((x, y), (-dy, dx))
+  else ((x', y'), (dx, dy))
+
+(** [walk_map map (pos, vel)] walks around [map] starting at [pos] moving in the
+    direction [vel]. It returns a list of all positions visited before falling
+    off one of the sides. *)
+let walk_map map (pos, vel) =
+  let rec impl acc (pos, vel) =
+    if Aoc.Grid.pos_is_valid map pos then
+      impl (pos :: acc) (move map (pos, vel))
+    else acc
+  in
+  impl [] (pos, vel)
+
+(** [has_cycles map (pos, vel)] returns true if walking around [map] starting at
+    [pos] going in [vel] direction will end up in a never ending cycle.*)
+let has_cycles map start =
+  (* We detect a cycle by walking two 'agents' around the map from the same
+     starting position.  Agent 1 moves 1 step at a time, agent 2 moves 2.  If
+     the agents ever end up on the same square facing the same direction we have
+     a cycle.  This works even if the cycle doesn't start immediately. *)
+  let rec impl agent1 ((pos', _) as agent2) =
+    (* Only need to check pos' for validity because if pos is not valid then
+       pos' must also be invalid, and have been invalid before this. *)
+    if not (Aoc.Grid.pos_is_valid map pos') then false
+    else if agent1 = agent2 then true
+    else impl (move map agent1) (move map (move map agent2))
+  in
+  (* Start Agent 2 a step ahead of Agent 1 so we don't fail at the start 
+     position. *)
+  impl start (move map start)
+
+(** [walk_block map (pos, vel) bpos] adds a block to the map [map] at [bpos] and
+    then sees if walking the map starting with [(pos, vel)] has a cycle. *)
+let walk_block map (pos, vel) bpos =
+  if bpos = pos then false
+  else
+    let map' = insert_block map bpos in
+    has_cycles map' (pos, vel)
+
+let part1 (map, pos, vel) =
+  walk_map map (pos, vel) |> List.sort_uniq Aoc.IntPair.compare |> List.length
+
+let part2 (map, pos, vel) =
+  walk_map map (pos, vel)
+  |> List.sort_uniq Aoc.IntPair.compare
+  |> List.filter (walk_block map (pos, vel))
+  |> List.length
+
+let _ = Aoc.main read_file [ (string_of_int, part1); (string_of_int, part2) ]

bin/day2407.ml

@@ -0,0 +1,63 @@
+let ints_of_file fname =
+  Aoc.strings_of_file fname |> List.map (Aoc.ints_of_string ~sep:"[: ]+")
+
+(** [check_add tgt v] Check to see if [X + v = tgt] is a valid operation. If not
+    returns [None] otherwise returns [Some X]. *)
+let check_add tgt v = if v > tgt then None else Some (tgt - v)
+
+(** [check_mul tgt v] Check to see if [X * v = tgt] is a valid operation. If not
+    returns [None] otherwise returns [Some X]. *)
+let check_mul tgt v = if tgt mod v = 0 then Some (tgt / v) else None
+
+(** [check_cat tgt v] Check to see if [X || v = tgt] is a valid operation. If
+    not returns [None] otherwise returns [Some X]. *)
+let check_cat tgt v =
+  let p = Aoc.pow10 (Aoc.digits10 v) in
+  if tgt mod p = v then Some (tgt / p) else None
+
+(** [is_valid_target tgt nums ops] returns [true] if we can reach [tgt] from
+    [nums] using [ops]. [nums] is in reverse order. *)
+let is_valid_target tgt nums ops =
+  (* We work backwards from the target and note that:
+     - if we ever go negative then the route we have taken is invalid
+     - we can only multiply if dividing the tgt by a number results in no
+        remainder.
+     - We can concat if the last digits of tgt match the number being checked.
+
+    The recursion in impl takes in a list of current target values and the list
+    of numbers.  It attempts every op on every potential current target with the
+    head of the nums list.  After filtering out those ops which do not produce
+    a valid target we recurse to the next number, with a new list of target
+    numbers.
+  *)
+  let rec impl tgts nums =
+    match nums with
+    | [] -> List.exists (( = ) 0) tgts
+    | h :: t ->
+        impl
+          (List.map (fun tgt -> List.filter_map (fun op -> op tgt h) ops) tgts
+          |> List.concat)
+          t
+  in
+  impl [ tgt ] nums
+
+(** [check_target checkers lst] returns [true] iff the given target can be
+    reached from its numbers. [checkers] is the list of operations that can be
+    used. *)
+let check_target checkers = function
+  | [] -> false
+  | h :: t -> is_valid_target h (List.rev t) checkers
+
+(** [part checkers lst] Gets the some of the targets in the list [lst] which can
+    be made given the input numbers. [checkers] are the operations that are
+    valid to be used.*)
+let part checkers lst =
+  List.filter (check_target checkers) lst
+  |> List.map List.hd |> List.fold_left ( + ) 0
+
+let _ =
+  Aoc.main ints_of_file
+    [
+      (string_of_int, part [ check_add; check_mul ]);
+      (string_of_int, part [ check_add; check_mul; check_cat ]);
+    ]

bin/day2408.ml

@@ -0,0 +1,72 @@
+module CharMap = Map.Make (Char)
+
+(** [get_station_indices map] returns a list of pairs mapping station ID to the
+    indices in [map] where there is a station with that ID. *)
+let get_station_indices map =
+  let rec impl acc idx =
+    if idx >= Aoc.Grid.length map then acc
+    else if Aoc.Grid.get_by_idx map idx = '.' then impl acc (idx + 1)
+    else
+      let station = Aoc.Grid.get_by_idx map idx in
+      let update_fn lst =
+        match lst with None -> Some [ idx ] | Some t -> Some (idx :: t)
+      in
+      impl (CharMap.update station update_fn acc) (idx + 1)
+  in
+  impl CharMap.empty 0 |> CharMap.to_list
+
+(** Generate antinodes for part 1. *)
+let get_antinodes1 acc _ (px, py) (px', py') =
+  let dx = px' - px in
+  let dy = py' - py in
+  (px - dx, py - dy) :: (px' + dx, py' + dy) :: acc
+
+(** [add_antinodes lst map pos vel] adds antinodes at [pos + n * vel] to [lst]
+    for all non-negative [n] that are valid positions in [map]. *)
+let rec add_antinodes lst map (x, y) (dx, dy) =
+  if Aoc.Grid.pos_is_valid map (x, y) then
+    add_antinodes ((x, y) :: lst) map (x + dx, y + dy) (dx, dy)
+  else lst
+
+(** Generate antinodes for part 2. *)
+let get_antinodes2 acc map (px, py) (px', py') =
+  let dx = px' - px in
+  let dy = py' - py in
+  let acc' = add_antinodes acc map (px, py) (dx, dy) in
+  let acc'' = add_antinodes acc' map (px, py) (-dx, -dy) in
+  acc''
+
+(** [process_stations map fn stations] generates a list of all antinodes for the
+    stations in [stations] on the map [map]. [fn acc map p p'] is called to
+    generate the antinode list for each pair of stations [p] and [p']. It should
+    add the positions of antinodes to the list [acc]. *)
+let process_stations map fn stations =
+  let rec impl2 acc p t =
+    match t with
+    | [] -> acc
+    | h :: t -> impl2 (fn acc map p (Aoc.Grid.pos_of_idx map h)) p t
+  in
+  let rec impl acc = function
+    | [] -> acc
+    | h :: t -> impl (impl2 acc (Aoc.Grid.pos_of_idx map h) t) t
+  in
+  List.map (impl []) stations
+
+(** [part antifn map station_indices] process all the stations in
+    station_indices calling [antifn acc map p p'] on all stations. Here [acc] is
+    a list of antinodes which [antifn] should update and return, [p] and [p']
+    are positions of stations to generate antinodes for. *)
+let part antifn map =
+  get_station_indices map
+  |> List.map snd (* we do not care about the station IDs *)
+  |> process_stations map antifn
+  |> List.concat
+  |> List.filter (Aoc.Grid.pos_is_valid map)
+  |> List.sort_uniq Stdlib.compare
+  |> List.length
+
+let _ =
+  Aoc.main Aoc.Grid.of_file
+    [
+      (string_of_int, part get_antinodes1); (string_of_int, part get_antinodes2);
+    ]

bin/day2409.ml

@@ -0,0 +1,149 @@
+let load_file fname =
+  match In_channel.with_open_text fname In_channel.input_line with
+  | Some x -> x
+  | None -> failwith "load_file"
+
+(** [disk_size disk_str] returns the size of the disk represented by the string
+    [disk_str]. See AoC 2024 day 9 for description of string format. *)
+let disk_size disk_str =
+  let rec impl acc disk_str =
+    match String.length disk_str with
+    | 0 -> acc
+    | len ->
+        let h = int_of_string (String.sub disk_str 0 1) in
+        let t = String.sub disk_str 1 (len - 1) in
+        impl (acc + h) t
+  in
+  impl 0 disk_str
+
+(** [disk_init disk_str] returns a disk which represents the description given
+    by [disk_str]. The returned disk is a mutable array with elements being [-1]
+    for free space and [id >= 0] for file with the given ID. *)
+let disk_init disk_str =
+  let size = disk_size disk_str in
+  let disk = Array.make size (-1) in
+  let rec add_id offset id = function
+    | 0 -> offset
+    | x ->
+        disk.(offset) <- id;
+        add_id (offset + 1) id (x - 1)
+  in
+  let rec impl offset id disk_str =
+    match String.length disk_str with
+    | 0 -> ()
+    | 1 ->
+        let _ = add_id offset id (int_of_string (String.sub disk_str 0 1)) in
+        ()
+    | str_len ->
+        let len = int_of_string (String.sub disk_str 0 1) in
+        impl
+          (add_id offset id len + int_of_string (String.sub disk_str 1 1))
+          (id + 1)
+          (String.sub disk_str 2 (str_len - 2))
+  in
+  impl 0 0 disk_str;
+  disk
+
+(** [disk_defrag disk] defrags [disk] given 2024/09/part 1 rules. Updates disk
+    in place. *)
+let disk_defrag disk =
+  let rec impl front back =
+    if front >= back then ()
+    else if disk.(front) <> -1 then impl (front + 1) back
+    else if disk.(back) = -1 then impl front (back - 1)
+    else (
+      disk.(front) <- disk.(back);
+      disk.(back) <- -1;
+      impl (front + 1) (back - 1))
+  in
+  impl 0 (Array.length disk - 1);
+  disk
+
+(** [find_largest_id disk] returns the largest ID on a fragmented disk [disk].
+*)
+let find_largest_id disk =
+  let rec impl pos =
+    if pos = -1 then failwith "find_largest_id.impl"
+    else if disk.(pos) = -1 then impl (pos - 1)
+    else disk.(pos)
+  in
+  impl (Array.length disk - 1)
+
+(** [find_id disk id search_pos] returns a pair [(start, length)] of the file
+    [id] on [disk]. We only look backwards from [search_pos]. *)
+let rec find_id disk id search_pos =
+  let rec count_length len pos =
+    if pos < 0 then (pos, len)
+    else if disk.(pos) <> id then (pos + 1, len)
+    else count_length (len + 1) (pos - 1)
+  in
+  if search_pos < 0 then failwith "find_id"
+  else if disk.(search_pos) <> id then find_id disk id (search_pos - 1)
+  else count_length 0 search_pos
+
+(** [find_space disk len] finds [len] elements of free space on [disk] starting
+    from 0. Returns [None] if no free-space found, or [Some pos] giving the
+    position of the start of the found space. *)
+let find_space disk len =
+  let rec free_length acc pos =
+    if pos >= Array.length disk then acc
+    else if disk.(pos) <> -1 then acc
+    else free_length (acc + 1) (pos + 1)
+  in
+  let rec impl pos =
+    if pos >= Array.length disk then None
+    else if disk.(pos) <> -1 then impl (pos + 1)
+    else if free_length 0 pos < len then impl (pos + 1)
+    else Some pos
+  in
+  impl 0
+
+(** [move_file disk id src dest] moves the file [id] on [disk] from [src] to
+    [dest].*)
+let rec move_file disk id src dest =
+  if src >= Array.length disk then ()
+  else if dest >= Array.length disk then ()
+  else if disk.(src) <> id then ()
+  else if disk.(dest) <> -1 then failwith "move_block"
+  else (
+    disk.(dest) <- disk.(src);
+    disk.(src) <- -1;
+    move_file disk id (src + 1) (dest + 1);
+    ())
+
+(** [file_defrag disk id search_pos] Locates the file [id] on [disk] and defrags
+    it if possible. We start searching down from [search_pos]. *)
+let file_defrag disk id search_pos =
+  let pos, len = find_id disk id search_pos in
+  match find_space disk len with
+  | None -> pos - 1
+  | Some x ->
+      if pos >= x then move_file disk id pos x;
+      pos - 1
+
+(** Defrag a whole disk according to 2024/09/part 2 rules. *)
+let disk_defrag_whole disk =
+  let max_id = find_largest_id disk in
+  let rec impl id pos =
+    if id = 0 then disk else impl (id - 1) (file_defrag disk id pos)
+  in
+  impl max_id (Array.length disk - 1)
+
+(** [disk_checksum disk] Calculates the checksum for [disk]. *)
+let disk_checksum disk =
+  let rec impl acc idx =
+    if idx = Array.length disk then acc
+    else if disk.(idx) = -1 then impl acc (idx + 1)
+    else impl (acc + (disk.(idx) * idx)) (idx + 1)
+  in
+  impl 0 0
+
+(** [part algo str] defrags the disk represented by [str] using algorithm
+    [algo]. *)
+let part algo str = disk_init str |> algo |> disk_checksum
+
+let _ =
+  Aoc.main load_file
+    [
+      (string_of_int, part disk_defrag); (string_of_int, part disk_defrag_whole);
+    ]

bin/day2410.ml

@@ -0,0 +1,60 @@
+(** [next_char ch] returns the next character after [ch]. *)
+let next_char ch = Char.chr (1 + Char.code ch)
+
+(** [ten] really isn't the digit 10, but is the character after '9'. *)
+let ten = next_char '9'
+
+(** The character '1'. *)
+let one = '1'
+
+(** [find_trail grid pos0] returns a list of all end points of trails in [grid]
+    starting at [pos0]. [pos0] must point to a valid position that contains a
+    '0'. The same endpoint may be returned multiple times if there are multiple
+    routes to it. *)
+let find_trail grid pos0 =
+  assert (Aoc.Grid.get_by_pos grid pos0 = '0');
+  let add_pos lst pos digit =
+    if Aoc.Grid.pos_is_valid grid pos && Aoc.Grid.get_by_pos grid pos = digit
+    then pos :: lst
+    else lst
+  in
+  let add_poses lst (x, y) digit =
+    let lst = add_pos lst (x - 1, y) digit in
+    let lst = add_pos lst (x + 1, y) digit in
+    let lst = add_pos lst (x, y - 1) digit in
+    let lst = add_pos lst (x, y + 1) digit in
+    lst
+  in
+  let rec find_next acc digit = function
+    | [] -> acc
+    | h :: t -> find_next (add_poses acc h digit) digit t
+  in
+  let rec impl acc digit =
+    if digit = ten then acc else impl (find_next [] digit acc) (next_char digit)
+  in
+  impl [ pos0 ] one
+
+(** [find_trails grid] returns the list of list of end-points of trails starting
+    at each position in [grid]. The [n]th element of the returned list
+    corresponds to the trails starting at index [n]. *)
+let find_trails grid =
+  let rec impl acc idx =
+    if idx >= Aoc.Grid.length grid then acc
+    else if Aoc.Grid.get_by_idx grid idx <> '0' then impl acc (idx + 1)
+    else (* grid_get_by_idx grid idx = 0 *)
+      impl (find_trail grid (Aoc.Grid.pos_of_idx grid idx) :: acc) (idx + 1)
+  in
+  impl [] 0 |> List.rev
+
+(** [part sort_fn grid] returns a count of all trails in [grid], before counting
+    the trails for each grid index are sorted by [sort_fn]. *)
+let part sort_fn grid =
+  find_trails grid |> List.map sort_fn |> List.map List.length
+  |> List.fold_left ( + ) 0
+
+let _ =
+  Aoc.main Aoc.Grid.of_file
+    [
+      (string_of_int, part (List.sort_uniq Stdlib.compare));
+      (string_of_int, part Fun.id);
+    ]

bin/day2411.ml

@@ -0,0 +1,56 @@
+module IntMap = Map.Make (Int)
+
+(** [apply_n n fn arg] is equivalent to [(fn (fn ... (fn (fn arg))))] where [fn]
+    is called [n] times.*)
+let rec apply_n n fn arg = if n <= 0 then arg else apply_n (n - 1) fn (fn arg)
+
+(** [update_count n o] returns [Some n] if [o] is [None], or [Some (n + x)] if
+    [o] is [Some x]. *)
+let update_count n = function None -> Some n | Some x -> Some (x + n)
+
+(** [map_of_ints lst] returns an [IntMap] with key-value pairs counting how many
+    times each integer appears in [lst]. *)
+let map_of_ints =
+  let rec impl acc = function
+    | [] -> acc
+    | h :: t -> impl (IntMap.update h (update_count 1) acc) t
+  in
+  impl IntMap.empty
+
+(** [map_stone id n map] calculates how a collection of stones changes in a
+    blink, updating [map] with the result. [id] is the ID of the stone to
+    update, [n] is how many stones there are with that ID. *)
+let map_stone id n acc =
+  match id with
+  | 0 -> IntMap.update 1 (update_count n) acc
+  | x when Aoc.digits10 x mod 2 = 0 ->
+      let pow = Aoc.pow10 (Aoc.digits10 x / 2) in
+      let acc = IntMap.update (x / pow) (update_count n) acc in
+      let acc = IntMap.update (x mod pow) (update_count n) acc in
+      acc
+  | x -> IntMap.update (x * 2024) (update_count n) acc
+
+(** [calc_blink map] calculates how a collection of stones changes in a blink,
+    returning the result.
+
+    This improves performance because we find that the transformation stones go
+    through ends up producing repeated numbers. e.g.: 0 -> 1 -> 2024 -> 20 24 ->
+    2 0 2 4 which has two 2s in it.
+
+    We also note that despite the problem description saying stones stay in
+    order, the result we are asked for (number of stones) does not require them
+    to be in order. *)
+let calc_blink map = IntMap.fold map_stone map IntMap.empty
+
+(** [part n lst] returns the number of stones after [n] blinks, given an initial
+    list, [lst], of stone IDs. *)
+let part n lst =
+  let map = map_of_ints lst |> apply_n n calc_blink in
+  IntMap.fold (fun _ v acc -> v + acc) map 0
+
+(** [ints_of_file fname] returns the integers listed on the first line of
+    [fname]. *)
+let ints_of_file fname = Aoc.string_of_file fname |> Aoc.ints_of_string
+
+let _ =
+  Aoc.main ints_of_file [ (string_of_int, part 25); (string_of_int, part 75) ]

bin/day2412.ml

@@ -0,0 +1,75 @@
+(** [perimeter grid pos] returns the number of sides of [pos] that contribute to
+    the perimeter of the region that [pos] is part of in [grid]. *)
+let perimeter grid (x, y) =
+  let region = Aoc.Grid.get_by_pos grid (x, y) in
+  let check (dx, dy) =
+    Aoc.Grid.get_by_pos_opt grid (x + dx, y + dy) = Some region
+  in
+  [ (-1, 0); (1, 0); (0, 1); (0, -1) ]
+  |> List.map check |> List.map Bool.to_int |> List.fold_left ( + ) 0
+
+(** [is_corner grid pos dir] returns true if there is a region corner on the
+    [dir] side of [pos] in grid. *)
+let is_corner grid (x, y) (dx, dy) =
+  let region = Aoc.Grid.get_by_pos grid (x, y) in
+  if
+    Aoc.Grid.get_by_pos_opt grid (x + dx, y) <> Some region
+    && Aoc.Grid.get_by_pos_opt grid (x, y + dy) <> Some region
+  then true
+  else if
+    Aoc.Grid.get_by_pos_opt grid (x + dx, y) = Some region
+    && Aoc.Grid.get_by_pos_opt grid (x, y + dy) = Some region
+    && Aoc.Grid.get_by_pos_opt grid (x + dx, y + dy) <> Some region
+  then true
+  else false
+
+(** [corners grid pos] returns the count of the number of corners that [pos] is
+    on for its region in [grid]. *)
+let corners grid pos =
+  [ (-1, -1); (-1, 1); (1, 1); (1, -1) ]
+  |> List.map (is_corner grid pos)
+  |> List.map Bool.to_int |> List.fold_left ( + ) 0
+
+(** [find_regions calc grid] finds all the regions in [grid] and returns a list
+    containing an element for each region. The element is a pair [(p, a)] where
+    [p] is the sum of calling [calc grid pos] for every element in the region
+    and [a] is the area of the region. *)
+let find_regions calc grid =
+  let visited = Array.make (Aoc.Grid.length grid) false in
+  let add_pos region pos lst =
+    if Aoc.Grid.get_by_pos_opt grid pos = Some region then
+      Aoc.Grid.idx_of_pos grid pos :: lst
+    else lst
+  in
+  let rec scan_pos perimeter area = function
+    | [] -> (perimeter, area)
+    | idx :: t when visited.(idx) -> scan_pos perimeter area t
+    | idx :: t (* when not visited.(idx) *) ->
+        visited.(idx) <- true;
+        let x, y = Aoc.Grid.pos_of_idx grid idx in
+        let area = area + 1 in
+        let perimeter = perimeter + calc grid (x, y) in
+        let region = Aoc.Grid.get_by_idx grid idx in
+        let t = add_pos region (x - 1, y) t in
+        let t = add_pos region (x + 1, y) t in
+        let t = add_pos region (x, y - 1) t in
+        let t = add_pos region (x, y + 1) t in
+        scan_pos perimeter area t
+  in
+  let rec impl acc idx =
+    if idx >= Aoc.Grid.length grid then List.rev acc
+    else
+      let perimeter, area = scan_pos 0 0 [ idx ] in
+      if area = 0 then impl acc (idx + 1)
+      else impl ((perimeter, area) :: acc) (idx + 1)
+  in
+  impl [] 0
+
+(** [part calc grid] returns the result of Part N over [grid] where [calc] is
+    the perimeter/edge counting function. *)
+let part calc grid =
+  find_regions calc grid |> List.fold_left (fun acc (p, a) -> acc + (p * a)) 0
+
+let _ =
+  Aoc.main Aoc.Grid.of_file
+    [ (string_of_int, part perimeter); (string_of_int, part corners) ]

bin/day2413.ml

@@ -0,0 +1,91 @@
+(** [parse_machine line_a line_b line_p] parse the machine description and
+    returns a triple [(a, b, p)] describing the actions of the 'A' and 'B'
+    buttons along with the location of the prize. *)
+let parse_machine line_a line_b line_p =
+  let get_xy re s =
+    let _ = Str.search_forward re s 0 in
+    ( int_of_string (Str.matched_group 1 s),
+      int_of_string (Str.matched_group 2 s) )
+  in
+  let re_ab = Str.regexp {|Button [AB]: X\+\([0-9]+\), Y\+\([0-9]+\)|} in
+  let re_pos = Str.regexp {|Prize: X=\([0-9]+\), Y=\([0-9]+\)|} in
+  let a = get_xy re_ab line_a in
+  let b = get_xy re_ab line_b in
+  let prize = get_xy re_pos line_p in
+  (a, b, prize)
+
+(** [parse_machines lst] returns a list of the machines parsed from the input
+    list of strings. *)
+let parse_machines =
+  let rec impl acc = function
+    | "" :: t -> impl acc t
+    | a :: b :: p :: t -> impl (parse_machine a b p :: acc) t
+    | [] -> acc
+    | _ -> failwith "parse_machines.impl"
+  in
+  impl []
+
+(** [machines_of_file fname] returns the list of machines described in the file
+    [fname]. *)
+let machines_of_file fname = Aoc.strings_of_file fname |> parse_machines
+
+(** [calc_tokens (a, b p)] calculates how many tokens are needed to get to [p]
+    by pressing button A (moving [a] amount) and button B (moving [b] amount).
+    Returns [None] if no solution possible, or [Some t] if the prize can be got
+    by spending [t] tokens.
+
+    Note the problem says minimize but if there is a solution there is only one
+    solution. *)
+let calc_tokens ((ax, ay), (bx, by), (x, y)) =
+  (* Solve as a sequence of linear equations: 
+     We want to find A & B in:
+     A * ax + B * bx = X (1)
+     A * ay + B * by = Y (2) 
+
+     dividing (1) by bx and (2) by by gives us:
+
+     A * ax / bx + B = X / bx (3)
+     A * ay / by + B = Y / by (4)
+
+     (3) - (4) gives:
+
+     A * (ax / bx - ay / by) = X / bx - Y / by.
+
+     Multiplying through by (bx * by) gives:
+
+     A * (ax * by - ay * bx) = X * by - Y * bx.
+
+     Dividing by (ax * by - ay * by) gives:
+
+     A = (X * by - Y * bx) / (ax * by - ay * by)
+
+     If ax * by - ay * by is 0 we have an infinite number of answers, and we'll
+     deal with that if that becomes an issue (spoiler alert: it doesn't).
+
+    A needs to be a whole number so (X * by - Y * bx) mod (ax * by - ay * by)
+    must be 0, otherwise there is no solution. *)
+  let a_n = (x * by) - (y * bx) in
+  let a_d = (ax * by) - (ay * bx) in
+  if a_d = 0 then None
+  else if a_n mod a_d <> 0 then None
+  else if a_n / a_d <= 0 then None
+  else
+    let a = a_n / a_d in
+    let b = (x - (ax * a)) / bx in
+    Some ((3 * a) + b)
+
+(** [add_offset offset machine] offsets the prize location for [machine] by
+    [(offset, offset)]. *)
+let add_offset offset (a, b, (x, y)) = (a, b, (x + offset, y + offset))
+
+(** [part offset machines] calculates the number of tokens needed to win as many
+    prizes as possible from [machines]. All machines prizes are offset by
+    [(offset, offset)]. *)
+let part offset machines =
+  List.map (add_offset offset) machines
+  |> List.filter_map calc_tokens
+  |> List.fold_left ( + ) 0
+
+let _ =
+  Aoc.main machines_of_file
+    [ (string_of_int, part 0); (string_of_int, part 10000000000000) ]

bin/day2414.ml

@@ -0,0 +1,119 @@
+module IntMap = Map.Make (Int)
+
+(** [parse_robot s] returns a robot description [((x, y), (dx, dy))] parsed from
+    the string [s]. *)
+let parse_robot s =
+  let re =
+    Str.regexp {|p=\(-?[0-9]+\),\(-?[0-9]+\) v=\(-?[0-9]+\),\(-?[0-9]+\)|}
+  in
+  let _ = Str.search_forward re s 0 in
+  ( ( int_of_string (Str.matched_group 1 s),
+      int_of_string (Str.matched_group 2 s) ),
+    ( int_of_string (Str.matched_group 3 s),
+      int_of_string (Str.matched_group 4 s) ) )
+
+(** [robots_of_file fname] returns a list of robots parsed from the file
+    [fname]. *)
+let robots_of_file fname = Aoc.strings_of_file fname |> List.map parse_robot
+
+(** Grid width *)
+let width = 101
+
+(** Grid height *)
+let height = 103
+
+(** Number of seconds to run part 1 for*)
+let secs1 = 100
+
+(** Maximum number of seconds to run part 2 for *)
+let secs2 = 1000000
+
+(** [normalize_velocity robot] returns a robot where the velocity has been
+    normalized to be non-negative in both directions. *)
+let normalize_velocity (p, (dx, dy)) =
+  (p, ((dx + width) mod width, (dy + height) mod height))
+
+(** [calc_pos_after secs r] returns the [(x, y)] position of a robot after
+    [secs] seconds. *)
+let calc_pos_after secs ((x, y), (dx, dy)) =
+  let x' = (x + (secs * dx)) mod width in
+  let y' = (y + (secs * dy)) mod height in
+  (x', y')
+
+(** [in_a_quadrant pos] returns true if [pos] is in a quadrant. *)
+let in_a_quadrant (x, y) = x <> width / 2 && y <> height / 2
+
+(** [update_count n] Is used by [IntMap.update] to increment a count. *)
+let update_count = function None -> Some 1 | Some x -> Some (x + 1)
+
+(** [get_quadrant p] returns the quadrant ID that the position [p] is in. *)
+let get_quadrant (x, y) =
+  if x < width / 2 && y < height / 2 then 1
+  else if x > width / 2 && y < height / 2 then 2
+  else if x < width / 2 && y > height / 2 then 4
+  else if x > width / 2 && y > height / 2 then 3
+  else failwith "get_quadrant"
+
+(** [quadrant_counts map p] updates the quadrant count map [map] with [p]. Keys
+    to [map] are quadrant IDs, and the values are the number of robots in that
+    quadrant. *)
+let quadrant_counts map p =
+  let idx = get_quadrant p in
+  IntMap.update idx update_count map
+
+(** [print_locs lst] prints the grid layout of the robots given in list. *)
+let print_locs lst =
+  let a = Array.make_matrix height width '.' in
+  let rec impl = function
+    | [] -> ()
+    | (x, y) :: t ->
+        if a.(y).(x) = '.' then a.(y).(x) <- '1'
+        else a.(y).(x) <- char_of_int (1 + int_of_char a.(y).(x));
+        impl t
+  in
+  impl lst;
+  Array.iter
+    (fun r ->
+      Array.iter print_char r;
+      print_newline ())
+    a
+
+(** [part1 robots] solves part1 for the list [robots]. *)
+let part1 robots =
+  let counts =
+    robots
+    |> List.map normalize_velocity
+    |> List.map (calc_pos_after secs1)
+    |> List.filter in_a_quadrant
+    |> List.fold_left quadrant_counts IntMap.empty
+  in
+  IntMap.fold (fun _ v acc -> acc * v) counts 1
+
+(** [find_tree max_n lst] tries to find the Christmas tree picture by iterating
+    through the various steps robots move in. Returns the number of iterations
+    before finding the tree. *)
+let find_tree max_n lst =
+  (* We assume that the picture will occur when every robot is in a unique
+     location. *)
+  let num_robots = List.length lst in
+  let rec impl n =
+    if n > max_n then failwith "None found"
+    else
+      let poses = List.map (calc_pos_after n) lst in
+      (* If every tree is in a unique location then sort_uniq will not remove
+         any elements from the list. *)
+      if List.length (List.sort_uniq Aoc.IntPair.compare poses) = num_robots
+      then (
+        print_locs poses;
+        n)
+      else impl (n + 1)
+  in
+  impl 0
+
+(** [part2 robots] solves part 2 for the list of robots. *)
+let part2 robots =
+  let robots = List.map normalize_velocity robots in
+  find_tree secs2 robots
+
+let _ =
+  Aoc.main robots_of_file [ (string_of_int, part1); (string_of_int, part2) ]

bin/day2415.ml

@@ -0,0 +1,157 @@
+type grid = { grid : char array; width : int }
+(** Grid type. Not our normal type as we want to use it in a mutable way. *)
+
+(** [grid_map fn strs] Returns a grid built up from the list of strings [strs].
+    [fn] takes a single string of all map characters and returns a string with
+    the appropriate replacements done. *)
+let grid_make posmap_fn strs =
+  let grid =
+    List.fold_left String.cat "" strs
+    |> posmap_fn |> String.to_seq |> Array.of_seq
+  in
+  let height = List.length strs in
+  let width = Array.length grid / height in
+  { grid; width }
+
+(** [grid_print grid] prints [grid] to standard output. *)
+let[@warning "-32"] grid_print grid =
+  Array.iteri
+    (fun i c ->
+      print_char c;
+      if i mod grid.width = grid.width - 1 then print_newline ())
+    grid.grid
+
+(** [find_robot_idx grid] returns the index of the robot in grid. *)
+let find_robot_idx grid =
+  match Array.find_index (( = ) '@') grid.grid with
+  | None -> failwith "find_robot_idx"
+  | Some x -> x
+
+(** [instrs_of_file fname] reads from the file [fname] and returns a
+    [(grid, instrs)] pair. [grid] is a list of strings describing the initial
+    grid state. [instrs] is a list of characters giving movement instructions.
+*)
+let instrs_of_file fname =
+  let strs = Aoc.strings_of_file fname in
+  let rec impl acc = function
+    | [] | "" :: [] -> failwith "instrs_of_file.impl"
+    | "" :: t -> (List.rev acc, t)
+    | h :: t -> impl (h :: acc) t
+  in
+  let grid, moves = impl [] strs in
+  (grid, List.fold_left String.cat "" moves |> String.to_seq |> List.of_seq)
+
+(** [move_x grid i di] moves the object in [grid] at [i] to [i + di] if
+    possible, returning the new location of the object (either [i] or [i + di]).
+    This assumes a horizontal movement of one step. *)
+let rec move_x grid i di =
+  assert (di == -1 || di == 1);
+  assert (i >= 0 && i <= Array.length grid.grid);
+  match grid.grid.(i + di) with
+  | '#' -> i
+  | 'O' | '[' | ']' ->
+      if move_x grid (i + di) di = i + di then i else move_x grid i di
+  | '.' ->
+      grid.grid.(i + di) <- grid.grid.(i);
+      grid.grid.(i) <- '.';
+      i + di
+  | _ -> failwith "move_x"
+
+(** [can_move_y grid i di] returns true if and only if it is possible to move
+    whatever is at [i] to [i + di] in [grid]. If [i + di] is full it recursively
+    checks to see if that can be moved as well. [di] must be a vertical
+    movement. *)
+let rec can_move_y grid i di =
+  assert (i >= 0 && i < Array.length grid.grid);
+  assert (di = grid.width || di = -grid.width);
+  match grid.grid.(i + di) with
+  | '#' -> false
+  | '.' -> true
+  | 'O' -> can_move_y grid (i + di) di
+  | '[' -> can_move_y grid (i + di) di && can_move_y grid (i + di + 1) di
+  | ']' -> can_move_y grid (i + di - 1) di && can_move_y grid (i + di) di
+  | _ -> failwith "can_move_y"
+
+(** [move_x grid i di] moves the object in [grid] at [i] to [i + di] if
+    possible, returning the new location of the object (either [i] or [i + di]).
+    This assumes a vertical movement of one step. *)
+let move_y grid i di =
+  assert (i >= 0 && i < Array.length grid.grid);
+  assert (di = grid.width || di = -grid.width);
+  let rec do_move i =
+    match grid.grid.(i + di) with
+    | '#' -> failwith "move_y.do_move #"
+    | '.' ->
+        grid.grid.(i + di) <- grid.grid.(i);
+        grid.grid.(i) <- '.'
+    | 'O' ->
+        do_move (i + di);
+        do_move i
+    | '[' ->
+        do_move (i + di);
+        do_move (i + di + 1);
+        do_move i
+    | ']' ->
+        do_move (i + di - 1);
+        do_move (i + di);
+        do_move i
+    | _ -> failwith "move_y.do_move"
+  in
+  if can_move_y grid i di then (
+    do_move i;
+    i + di)
+  else i
+
+(** [process_move grid robot dir] attempts to move robot at idx [robot] in
+    [grid] in direction. Returns location of robot after attempt. *)
+let process_move grid robot dir =
+  match dir with
+  | '^' -> move_y grid robot (-grid.width)
+  | 'v' -> move_y grid robot grid.width
+  | '<' -> move_x grid robot ~-1
+  | '>' -> move_x grid robot 1
+  | _ -> failwith "process_move"
+
+(** [process_moves grid robot lst] Attempts each move in [lst] in turn given a
+    [grid] and initial starting position of the robot [robot]. Returns the
+    [grid]. *)
+let rec process_moves grid robot = function
+  | [] -> ()
+  | h :: t -> process_moves grid (process_move grid robot h) t
+
+(** [calc_score grid] returns the score for [grid]. *)
+let calc_score grid =
+  Array.mapi
+    (fun idx c ->
+      if c = 'O' || c = '[' then
+        (idx mod grid.width) + (100 * (idx / grid.width))
+      else 0)
+    grid.grid
+  |> Array.fold_left ( + ) 0
+
+(** [expand_grid str] given an input [str] returns the output grid string for
+    part 2. *)
+let expand_grid str =
+  let b = Buffer.create (String.length str * 2) in
+  let add_c = function
+    | '#' -> Buffer.add_string b "##"
+    | 'O' -> Buffer.add_string b "[]"
+    | '.' -> Buffer.add_string b ".."
+    | '@' -> Buffer.add_string b "@."
+    | _ -> failwith "expand_grid"
+  in
+  String.iter add_c str;
+  Buffer.contents b
+
+(** [part posmap_fn (grid, moves)] executes the [moves] in [grid] having first
+    applied [posmap_fn] to grid. *)
+let part posmap_fn (grid, moves) =
+  let grid = grid_make posmap_fn grid in
+  let robot = find_robot_idx grid in
+  process_moves grid robot moves;
+  (*grid_print grid;*)
+  calc_score grid
+
+let _ =
+  Aoc.main instrs_of_file
+    [ (string_of_int, part Fun.id); (string_of_int, part expand_grid) ]

bin/day2416.ml

@@ -0,0 +1,128 @@
+(** [find grid c] returns the position of the character [c] in [grid]. *)
+let find grid c =
+  match Aoc.Grid.idx_from_opt grid 0 c with
+  | None -> failwith "find"
+  | Some idx -> Aoc.Grid.pos_of_idx grid idx
+
+(** [input_of_file fname] returns a [(grid, start_pos)] pair parsed from
+    [fname]. *)
+let input_of_file fname =
+  let grid = Aoc.Grid.of_file fname in
+  let start_pos = find grid 'S' in
+  (grid, start_pos)
+
+(** [dijkstra visit check_end states] executes Dijkstra's algorithm.
+
+    [visit cost state] is called to visit [state] with [cost]. It should mark
+    [state] as visited, and return a list of [(cost, state)] pairs which contain
+    new states to examine. The returned list should be sorted by [cost].
+
+    [check_end state] should return [true] if and only if [state] is an end
+    state.
+
+    [states] is a list of [(cost, state)] pairs ordered by [cost].
+
+    [dijkstra] returns [None] if no path is found to the destination. It returns
+    [Some (cost, state, remaining_states)] if a route is found. [cost] is the
+    cost of getting to [state]. [remaining_states] is a list of the remaining
+    states which can be passed back to [dijkstra] if we want to find further
+    paths. *)
+let rec dijkstra visit check_end =
+  let compare_costs (lhs, _) (rhs, _) = compare lhs rhs in
+  function
+  | [] -> None
+  | (cost, state) :: t ->
+      if check_end state then Some (cost, state, t)
+      else
+        let new_states = visit cost state |> List.merge compare_costs t in
+        dijkstra visit check_end new_states
+
+(** [visited_idx grid state] returns the index into the visited array for [grid]
+    at a given [state]. *)
+let visited_idx grid ((dx, dy), p) =
+  let add =
+    match (dx, dy) with
+    | 1, 0 -> 0
+    | 0, 1 -> 1
+    | -1, 0 -> 2
+    | 0, -1 -> 3
+    | _ -> failwith "visited_idx"
+  in
+  (Aoc.Grid.idx_of_pos grid p * 4) + add
+
+(** [visit grid visited cost state] visits [state] with [cost] in [grid].
+    [visited] is an array of visited states, and is updated as we visit. It
+    returns a list of new [(cost, state)] pairs to visit. *)
+let visit grid visited_grid cost state =
+  let (dx, dy), ((x, y) as p) = List.hd state in
+  let has_visited = visited_grid.(visited_idx grid (List.hd state)) in
+  if has_visited then []
+  else if Aoc.Grid.get_by_pos grid p = '#' then []
+  else (
+    visited_grid.(visited_idx grid (List.hd state)) <- true;
+    [
+      (cost + 1, ((dx, dy), (x + dx, y + dy)) :: state);
+      (cost + 1000, ((-dy, dx), p) :: state);
+      (cost + 1000, ((dy, -dx), p) :: state);
+    ])
+
+(** [has_visited grid visited_grid (cost, state)] returns true if we have
+    visited the [state]. *)
+let has_visited grid visited_grid (cost, state) =
+  visited_grid.(visited_idx grid (List.hd state)) < cost
+
+(** [visit grid visited cost state] visits [state] with [cost] in [grid].
+    [visited] is an array of visited states, and is updated as we visit. It
+    returns a list of new [(cost, state)] pairs to visit. *)
+let visit_max grid visited_grid cost state =
+  let (dx, dy), ((x, y) as p) = List.hd state in
+  if has_visited grid visited_grid (cost, state) then []
+  else if Aoc.Grid.get_by_pos grid p = '#' then []
+  else (
+    visited_grid.(visited_idx grid (List.hd state)) <- cost;
+    [
+      (cost + 1, ((dx, dy), (x + dx, y + dy)) :: state);
+      (cost + 1000, ((-dy, dx), p) :: state);
+      (cost + 1000, ((dy, -dx), p) :: state);
+    ]
+    |> List.filter (fun x -> not (has_visited grid visited_grid x)))
+
+(** [check_end grid state] returns [true] if [state] is at the end location in
+    [grid]. *)
+let check_end grid state =
+  let _, p = List.hd state in
+  Aoc.Grid.get_by_pos grid p = 'E'
+
+(** [part1 (grid, start_pos)] returns solution to part 1.
+
+    This part does a simple Dijkstra algorithm over the grid finding the
+    shortest path possible. *)
+let part1 (grid, start_pos) =
+  let visited_grid = Array.make (Aoc.Grid.length grid * 4) false in
+  match
+    dijkstra (visit grid visited_grid) (check_end grid)
+      [ (0, [ ((1, 0), start_pos) ]) ]
+  with
+  | None -> failwith "part"
+  | Some (cost, _, _) -> cost
+
+(** [part2 (grid, start_pos)] returns solution to part 2.
+
+    We reuse part 1 to find the cost of getting to the exit. Then we redo the
+    Dijkstra algorithm to find all walks with that cost.
+
+    Finally we get all the positions visited, de-duplicate, and count the length
+    of the list. This produces the number of locations for benches. *)
+let part2 (grid, start_pos) =
+  let cost = part1 (grid, start_pos) in
+  let visited_grid = Array.make (Aoc.Grid.length grid * 4) cost in
+  let rec impl acc lst =
+    match dijkstra (visit_max grid visited_grid) (check_end grid) lst with
+    | None -> acc
+    | Some (_, states, remainder) -> impl (states :: acc) remainder
+  in
+  impl [] [ (0, [ ((1, 0), start_pos) ]) ]
+  |> List.concat |> List.map snd |> List.sort_uniq compare |> List.length
+
+let _ =
+  Aoc.main input_of_file [ (string_of_int, part1); (string_of_int, part2) ]

bin/day2417.ml

@@ -0,0 +1,167 @@
+type vm = {
+  a : int;
+  b : int;
+  c : int;
+  ip : int;
+  code : int array;
+  out : int list;
+}
+(** Virtual Machine definition
+
+    Consists of three general-purpose registers: A, B, C, an instruction pointer
+    (ip), and array of code, and a list of output. The output list is in reverse
+    order of output. *)
+
+(** Generate a VM from a list of strings *)
+let vm_of_strings lst =
+  let re_val = Str.regexp {|Register [ABC]: \([0-9]+\)|} in
+  let re_prog = Str.regexp {|Program: \([0-9,]+\)|} in
+  let get_val = function
+    | [] -> failwith "vm_of_strings.get_val"
+    | h :: t ->
+        let _ = Str.search_forward re_val h 0 in
+        (int_of_string (Str.matched_group 1 h), t)
+  in
+  let skip_line = function
+    | "" :: t -> t
+    | _ -> failwith "vm_of_strings.skip_line"
+  in
+  let get_code = function
+    | [] -> failwith "vm_of_strings.get_prog"
+    | h :: t ->
+        let _ = Str.search_forward re_prog h 0 in
+        let nums =
+          Str.matched_group 1 h |> Aoc.ints_of_string ~sep:"," |> Array.of_list
+        in
+        (nums, t)
+  in
+  let a, lst = get_val lst in
+  let b, lst = get_val lst in
+  let c, lst = get_val lst in
+  let lst = skip_line lst in
+  let code, lst = get_code lst in
+  let ip = 0 in
+  let out = [] in
+  assert (List.is_empty lst);
+  { a; b; c; ip; code; out }
+
+(** Generate a VM from a file *)
+let vm_of_file fname = Aoc.strings_of_file fname |> vm_of_strings
+
+(** [is_halted vm] returns true if the VM is halted. *)
+let is_halted vm = vm.ip >= Array.length vm.code || vm.ip < 0
+
+(** [get_literal vm] returns the Literal value from the current IP + 1 in [vm].
+*)
+let get_literal vm = vm.code.(vm.ip + 1)
+
+(** [print_combo vm] prints the combo operand at the current IP + 1 in [vm]. *)
+let[@warning "-32"] print_combo vm =
+  match vm.code.(vm.ip + 1) with
+  | 0 | 1 | 2 | 3 -> print_int vm.code.(vm.ip + 1)
+  | 4 -> Printf.printf "A (=%d)" vm.a
+  | 5 -> Printf.printf "B (=%d)" vm.a
+  | 6 -> Printf.printf "C (=%d)" vm.a
+  | 7 -> failwith "print_combo reserved"
+  | _ -> failwith "print_combo not 3-bit"
+
+(** [get_combo vm] returns the value of interpreting the combo operant at IP + 1
+    in [vm]. *)
+let get_combo vm =
+  match vm.code.(vm.ip + 1) with
+  | 0 | 1 | 2 | 3 -> vm.code.(vm.ip + 1)
+  | 4 -> vm.a
+  | 5 -> vm.b
+  | 6 -> vm.c
+  | 7 -> failwith "get_combo reserved"
+  | _ -> failwith "get_combo not 3-bit"
+
+(** [print_insn vm] prints the current instruction at VM. *)
+let[@warning "-32"] print_insn vm =
+  Printf.printf "%d: " vm.ip;
+  if is_halted vm then print_endline "Halted"
+  else Printf.printf "%d " vm.code.(vm.ip);
+  (match vm.code.(vm.ip) with
+  | 0 ->
+      print_string "adv ";
+      print_combo vm
+  | 1 -> Printf.printf "bxl %d" (get_literal vm)
+  | 2 ->
+      print_string "bst ";
+      print_combo vm
+  | 3 -> Printf.printf "jnz %d" (get_literal vm)
+  | 4 -> print_string "bxc"
+  | 5 ->
+      print_string "out ";
+      print_combo vm
+  | 6 ->
+      print_string "bdv ";
+      print_combo vm
+  | 7 ->
+      print_string "cdv ";
+      print_combo vm
+  | _ -> failwith "print_insn");
+  Printf.printf " A=%d B=%d C=%d\n" vm.a vm.b vm.c
+
+(** [execute_insn vm] executes the current instruction in [vm] returns an
+    updated VM. *)
+let execute_insn vm =
+  if is_halted vm then vm
+  else
+    (*print_insn vm;*)
+    match vm.code.(vm.ip) with
+    | 0 -> { vm with a = vm.a / (1 lsl get_combo vm); ip = vm.ip + 2 }
+    | 1 -> { vm with b = vm.b lxor get_literal vm; ip = vm.ip + 2 }
+    | 2 -> { vm with b = get_combo vm land 7; ip = vm.ip + 2 }
+    | 3 ->
+        if vm.a <> 0 then { vm with ip = get_literal vm }
+        else { vm with ip = vm.ip + 2 }
+    | 4 -> { vm with b = vm.b lxor vm.c; ip = vm.ip + 2 }
+    | 5 -> { vm with out = (get_combo vm land 7) :: vm.out; ip = vm.ip + 2 }
+    | 6 -> { vm with b = vm.a / (1 lsl get_combo vm); ip = vm.ip + 2 }
+    | 7 -> { vm with c = vm.a / (1 lsl get_combo vm); ip = vm.ip + 2 }
+    | _ -> failwith "execute_insn"
+
+(** [execute_until_halted vm] executes a VM until it runs out of steam. *)
+let rec execute_until_halted vm =
+  match is_halted vm with
+  | true -> vm
+  | false -> execute_until_halted (execute_insn vm)
+
+(** [string_of_ouput vm] gives the output of [vm]. *)
+let part1 vm =
+  let vm = execute_until_halted vm in
+  List.rev vm.out |> List.map string_of_int |> String.concat ","
+
+(** [scan_digit acc ip vm] updates the acc for A so that the output of running
+    VM agrees in the last [ip] digits with the input program. *)
+let scan_digit acc ip vm =
+  let rec impl v =
+    let acc = acc + (v lsl (3 * ip)) in
+    let vm = { vm with a = acc } in
+    let vm = execute_until_halted vm in
+    let out = List.rev vm.out in
+    if List.length out <= ip then impl (v + 1)
+    else if
+      List.of_seq (Seq.drop ip (List.to_seq out))
+      = List.of_seq (Seq.drop ip (Array.to_seq vm.code))
+    then acc
+    else impl (v + 1)
+  in
+  impl 0
+
+(** [scan_all vm] generates the input A which means the output of executing [vm]
+    is the same as the input program. *)
+let scan_all vm =
+  let rec impl acc ip =
+    if ip < 0 || ip >= Array.length vm.code then { vm with a = acc }
+    else impl (scan_digit acc ip vm) (ip - 1)
+  in
+  impl 0 (Array.length vm.code - 1)
+
+(** [string_of_a vm] returns the A register of [vm]. *)
+let part2 vm =
+  let vm = scan_all vm in
+  string_of_int vm.a
+
+let _ = Aoc.main vm_of_file [ (Fun.id, part1); (Fun.id, part2) ]

bin/day2418.ml

@@ -0,0 +1,147 @@
+(** [pairs_of_ints lst] returns a pair from a list of two elements. *)
+let pairs_of_ints = function
+  | [ h; h' ] -> (h, h')
+  | _ -> raise (Invalid_argument "pairs_of_ints")
+
+(** [dijkstra visit check_end states] executes Dijkstra's algorithm.
+
+    [visit cost state] is called to visit [state] with [cost]. It should mark
+    [state] as visited, and return a list of [(cost, state)] pairs which contain
+    new states to examine. The returned list should be sorted by [cost].
+
+    [check_end state] should return [true] if and only if [state] is an end
+    state.
+
+    [states] is a list of [(cost, state)] pairs ordered by [cost].
+
+    [dijkstra] returns [None] if no path is found to the destination. It returns
+    [Some (cost, state, remaining_states)] if a route is found. [cost] is the
+    cost of getting to [state]. [remaining_states] is a list of the remaining
+    states which can be passed back to [dijkstra] if we want to find further
+    paths. *)
+let rec dijkstra visit check_end =
+  let compare_costs (lhs, _) (rhs, _) = compare lhs rhs in
+  function
+  | [] -> None
+  | (cost, state) :: t ->
+      if check_end state then Some (cost, state)
+      else
+        let new_states = visit cost state |> List.merge compare_costs t in
+        dijkstra visit check_end new_states
+
+type 'a grid = { grid : 'a array; width : int }
+
+(** [grid_is_valid_pos grid (x, y)] returns true if (x, y) is a valid position
+*)
+let grid_is_valid_pos grid (x, y) =
+  x >= 0 && x < grid.width && y >= 0 && y < grid.width
+
+(** Get the index into the grid from an x, y position. *)
+let grid_idx_by_pos grid (x, y) = x + (y * grid.width)
+
+(** Set the value of the position (x, y) to v in grid. *)
+let grid_set_by_pos grid p v =
+  assert (grid_is_valid_pos grid p);
+  let idx = grid_idx_by_pos grid p in
+  grid.grid.(idx) <- v
+
+(** Get the value of the position (x, y) in grid. *)
+let grid_get_by_pos grid p =
+  assert (grid_is_valid_pos grid p);
+  let idx = grid_idx_by_pos grid p in
+  grid.grid.(idx)
+
+(** [grid_of_rocks w rocks] returns a [w * w] grid with [grid.(x + y * w)]
+    indicating whether the space is empty ([=max_int]) or which rock it is (0
+    based). *)
+let grid_of_rocks width rocks =
+  let grid = { grid = Array.make (width * width) max_int; width } in
+  let add_rock idx p = grid_set_by_pos grid p idx in
+  List.iteri add_rock rocks;
+  grid
+
+(** [visit grid has_visited count cost pos] visits the location pos marking it
+    as visited and returning a list of [(cost, pos)] pairs of next locations to
+    examine.
+
+    [grid] is the grid of rocks, [has_visited] is an array of bools indicating
+    whether a position has already been visited, and [count] is how many rocks
+    have fallen. *)
+let visit grid has_visited count cost state =
+  if not (grid_is_valid_pos grid state) then []
+  else if has_visited.(grid_idx_by_pos grid state) then []
+  else if grid_get_by_pos grid state < count then []
+  else
+    let x, y = state in
+    has_visited.(grid_idx_by_pos grid state) <- true;
+    [
+      (cost + 1, (x + 1, y));
+      (cost + 1, (x - 1, y));
+      (cost + 1, (x, y + 1));
+      (cost + 1, (x, y - 1));
+    ]
+
+(** [grid_of_file w fname] returns a grid of width & height [w] populated with
+    rocks described in the file [fname]. *)
+let grid_of_file width fname =
+  Aoc.strings_of_file fname
+  |> List.map (Aoc.ints_of_string ~sep:",")
+  |> List.map pairs_of_ints |> grid_of_rocks width
+
+(** [find_route_length count grid] calculates the route from the top-left
+    position in [grid] to the bottom right if [count] rocks have fallen. It
+    returns [None] if no route is possible or [Some (cost, pos)] if the route is
+    possible. *)
+let find_route_length count grid =
+  let has_visited = Array.make (Array.length grid.grid) false in
+  dijkstra
+    (visit grid has_visited count)
+    (( = ) (grid.width - 1, grid.width - 1))
+    [ (0, (0, 0)) ]
+
+(** [part1 count rocks] returns how long it takes to navigate the grid [rocks]
+    when [count] rocks have fallen. *)
+let part1 count rocks =
+  match find_route_length count rocks with
+  | None -> failwith "part1"
+  | Some (cost, _) -> string_of_int cost
+
+(** [part2 start_count grid] returns the location of the first rock to fall into
+    [grid] which makes it impossible to get from the top-left to bottom-right.
+*)
+let part2 width start_count grid =
+  (* Implementation notes:
+  
+     We do this by binary search in impl.  The left_count is a known count of
+     rocks that is passable, right_count is a known count that is impassable.
+
+     Once left_count + 1 = right_count we know that right_count is the first
+     rock to fall that causes the route to be blocked.
+
+     count_rocks is used to find the number of rocks (and so give an initial
+     right_count).
+  *)
+  let rec count_rocks acc idx =
+    if idx >= Array.length grid.grid then acc
+    else if grid.grid.(idx) = max_int then count_rocks acc (idx + 1)
+    else count_rocks (max acc grid.grid.(idx)) (idx + 1)
+  in
+  let rec impl left_count right_count =
+    if right_count - left_count = 1 then right_count
+    else
+      let count = (left_count + right_count) / 2 in
+      match find_route_length count grid with
+      | None -> impl left_count count
+      | Some _ -> impl count right_count
+  in
+  let count = impl start_count (1 + count_rocks 0 0) in
+  match Array.find_index (( = ) (count - 1)) grid.grid with
+  | None -> failwith "part2"
+  | Some idx -> Printf.sprintf "%d,%d" (idx mod width) (idx / width)
+
+(** Width of grid *)
+let width = 71
+
+let _ =
+  Aoc.main (grid_of_file width)
+    [ (Fun.id, part1 1024); (Fun.id, part2 width 1024) ]

bin/day2419.ml

@@ -0,0 +1,45 @@
+(** [towels_of_strings lst] returns a pair containing a list of available towels
+    and a list of patterns wanted. *)
+let towels_of_strings = function
+  | h :: "" :: t ->
+      let re = Str.regexp "[, ]+" in
+      let h = Str.split re h in
+      (h, t)
+  | _ -> failwith "towels_of_strings"
+
+(** [towels_of_file fname] returns the list of towels and patterns from the file
+    [fname]. *)
+let towels_of_file fname = Aoc.strings_of_file fname |> towels_of_strings
+
+(** Memoizing hash table shared between parts 1 and 2. *)
+let memo = Hashtbl.create 1000
+
+(** [count_hashes memo towels pattern] counts the number of ways of matching
+    [pattern] using [towels]. [memo] is a hashtable used for memoizing results.
+*)
+let rec count_matches memo towels pattern =
+  let pattern_len = String.length pattern in
+  let rec count_matched = function
+    | [] -> 0
+    | h :: t ->
+        let towel_len = String.length h in
+        if String.starts_with ~prefix:h pattern then
+          Aoc.memoize memo
+            (count_matches memo towels)
+            (String.sub pattern towel_len (pattern_len - towel_len))
+          + count_matched t
+        else count_matched t
+  in
+  if pattern_len = 0 then 1 else count_matched towels
+
+let part1 (towels, patterns) =
+  List.map (Aoc.memoize memo (count_matches memo towels)) patterns
+  |> List.filter (( < ) 0)
+  |> List.length
+
+let part2 (towels, patterns) =
+  List.map (Aoc.memoize memo (count_matches memo towels)) patterns
+  |> List.fold_left ( + ) 0
+
+let _ =
+  Aoc.main towels_of_file [ (string_of_int, part1); (string_of_int, part2) ]

bin/day2420.ml

@@ -0,0 +1,99 @@
+(** [populate_grid grid start] does a depth-first search through [grid] to find
+    the route from [start] to the end. *)
+let populate_grid grid start =
+  let costs = Array.make (Aoc.Grid.length grid) max_int in
+  let rec step acc cost = function
+    | [] -> acc
+    | (x, y) :: t ->
+        if
+          Aoc.Grid.pos_is_valid grid (x, y)
+          && Aoc.Grid.get_by_pos grid (x, y) <> '#'
+          && costs.(Aoc.Grid.idx_of_pos grid (x, y)) = max_int
+        then begin
+          costs.(Aoc.Grid.idx_of_pos grid (x, y)) <- cost;
+          if Aoc.Grid.get_by_pos grid (x, y) = 'E' then step acc cost t
+          else
+            step
+              ((x - 1, y) :: (x + 1, y) :: (x, y - 1) :: (x, y + 1) :: acc)
+              cost t
+        end
+        else step acc cost t
+  in
+  let rec dfs cost lst =
+    let next_step = step [] cost lst in
+    if next_step = [] then costs else dfs (cost + 1) next_step
+  in
+  let costs = dfs 0 [ start ] in
+  costs
+
+(** [manhattan_distance2 p p'] returns the Manhattan distance between two points
+    on a 2-D plane. *)
+let manhattan_distance2 (x, y) (x', y') = abs (x - x') + abs (y - y')
+
+(** [within_distance pos distance] returns all points that are at most
+    [distance] units away from [pos] when measured using the Manhattan distance.
+*)
+let within_distance (x, y) distance =
+  let rec impl' acc y' x' =
+    if manhattan_distance2 (x, y) (x', y') > distance then acc
+    else impl' ((x', y') :: acc) y' (x' + 1)
+  in
+  let rec impl acc y' =
+    if y' - y > distance then acc
+    else impl (impl' acc y' (x - (distance - abs (y - y')))) (y' + 1)
+  in
+  impl [] (y - distance)
+
+(** [find_cost min_amount depth_first grid length idx] returns the number of
+    cheat routes starting at [idx] which have a saving of at least [min_amount]
+    and are no longer than [length]. [depth_first] is the cost map, and [grid]
+    is the grid. *)
+let find_cost min_amount depth_first grid length idx =
+  (* because there is only one route through the grid we can specialize and look
+     to see how much we can save by going from [idx] to any other grid position
+     within [length] units (manhattan distance).  The saving is the cost of
+     gettimg to idx' from idx via the old route - the cost via the new route. *)
+  let saving idx' =
+    let cost = depth_first.(idx) in
+    let cost' = depth_first.(idx') in
+    cost' - cost
+    - manhattan_distance2
+        (Aoc.Grid.pos_of_idx grid idx)
+        (Aoc.Grid.pos_of_idx grid idx')
+  in
+  within_distance (Aoc.Grid.pos_of_idx grid idx) length
+  |> List.filter (Aoc.Grid.pos_is_valid grid)
+  |> List.map (Aoc.Grid.idx_of_pos grid)
+  |> List.filter (fun idx' -> depth_first.(idx') <> max_int)
+  |> List.filter (fun idx' -> depth_first.(idx') - depth_first.(idx) >= 0)
+  |> List.map saving
+  |> List.filter (( <= ) min_amount)
+  |> List.length
+
+(** [find_cost_reductions min_amount cheat_length (grid, start)] returns the
+    number of cheat-routes that can be found in [grid] starting at [start] that
+    save at least [min_amount] moves and are no longer than [cheat_length]
+    units. *)
+let find_cost_reductions min_amount cheat_length (grid, start) =
+  let costs = populate_grid grid start in
+  Seq.ints 0
+  |> Seq.take (Aoc.Grid.length grid)
+  |> Seq.map (find_cost min_amount costs grid cheat_length)
+  |> Seq.fold_left ( + ) 0
+
+let find_start grid =
+  match Aoc.Grid.idx_from_opt grid 0 'S' with
+  | None -> failwith "find_start"
+  | Some x -> Aoc.Grid.pos_of_idx grid x
+
+let data_of_file fname =
+  let grid = Aoc.Grid.of_file fname in
+  let start = find_start grid in
+  (grid, start)
+
+let _ =
+  Aoc.main data_of_file
+    [
+      (string_of_int, find_cost_reductions 100 2);
+      (string_of_int, find_cost_reductions 100 20);
+    ]

bin/day2421.ml

@@ -0,0 +1,157 @@
+(** A Pair of characters *)
+module CharPair = struct
+  type t = char * char
+
+  let compare (x, y) (x', y') =
+    match compare y y' with 0 -> compare x x' | c -> c
+end
+
+module CharPairMap = Map.Make (CharPair)
+
+(** [pos_of_numeric_grid c] returns the [(x, y)] position of [c] in the numeric
+    grid. *)
+let pos_of_numeric_grid c =
+  match c with
+  | '7' -> (0, 0)
+  | '8' -> (1, 0)
+  | '9' -> (2, 0)
+  | '4' -> (0, 1)
+  | '5' -> (1, 1)
+  | '6' -> (2, 1)
+  | '1' -> (0, 2)
+  | '2' -> (1, 2)
+  | '3' -> (2, 2)
+  | '0' -> (1, 3)
+  | 'A' -> (2, 3)
+  | _ -> raise (invalid_arg "pos_of_numeric_grid")
+
+(** [pos_of_numeric_grid c] returns the [(x, y)] position of [c] in the
+    direction grid. *)
+let pos_of_dir_grid c =
+  (* Implementation note: We chose 'A' to have the same position in both grids
+     so that there is only one location for the hole. *)
+  match c with
+  | '^' -> (1, 3)
+  | 'A' -> (2, 3)
+  | '<' -> (0, 4)
+  | 'v' -> (1, 4)
+  | '>' -> (2, 4)
+  | _ -> raise (invalid_arg "pos_of_dir_grid")
+
+(** Location of the hole which the robot can not go to. *)
+let invalid_x, invalid_y = (0, 3)
+
+(** [find_paths start finish] returns a list of paths (using the direction
+    keypad to get from [start] to [finish] positions.
+
+    The routing is picked to avoid the invalid location. *)
+let find_paths (sx, sy) (fx, fy) =
+  let b = Buffer.create 6 in
+  let result = [] in
+  let result =
+    if fx <> invalid_x || sy <> invalid_y then begin
+      Buffer.reset b;
+      if fx > sx then Buffer.add_string b (String.make (fx - sx) '>')
+      else if fx < sx then Buffer.add_string b (String.make (sx - fx) '<');
+      if fy > sy then Buffer.add_string b (String.make (fy - sy) 'v')
+      else if fy < sy then Buffer.add_string b (String.make (sy - fy) '^');
+      Buffer.add_char b 'A';
+      Buffer.contents b :: result
+    end
+    else result
+  in
+  let result =
+    if sx <> invalid_x || fy <> invalid_y then begin
+      Buffer.reset b;
+      if fy > sy then Buffer.add_string b (String.make (fy - sy) 'v')
+      else if fy < sy then Buffer.add_string b (String.make (sy - fy) '^');
+      if fx > sx then Buffer.add_string b (String.make (fx - sx) '>')
+      else if fx < sx then Buffer.add_string b (String.make (sx - fx) '<');
+      Buffer.add_char b 'A';
+      Buffer.contents b :: result
+    end
+    else result
+  in
+  result
+
+(** [cartesian f initial_acc lst lst'] calls [f acc h h'] for the cross-product
+    of all elements [h], [h'] in [lst] and [lst']. [acc] is updated in each call
+    with the result of all previous calls to [f]. The result is the final [acc].
+*)
+let cartesian f initial_acc lst lst' =
+  let rec impl' acc h = function
+    | [] -> acc
+    | h' :: t' -> impl' (f acc h h') h t'
+  in
+  let rec impl acc = function
+    | [] -> acc
+    | h :: t -> impl (impl' acc h lst') t
+  in
+  impl initial_acc lst
+
+(** [routes pos_of_grid locs] returns a map of [(start, finish)] pairs mapping
+    to a list of paths for getting to that route. [locs] are the locations on
+    the grid to investiagte. [pos_of_grid] gives the location of each of the
+    [locs]. The returned map contains routes from each element in [locs] to
+    every element. *)
+let routes pos_of_grid locs =
+  let impl acc h h' =
+    CharPairMap.add (h, h') (find_paths (pos_of_grid h) (pos_of_grid h')) acc
+  in
+  cartesian impl CharPairMap.empty locs locs
+
+(** [initial_cost_map grid] returns a map for the initial costs (1) of moving
+    between different positions on [grid]. *)
+let initial_cost_map grid =
+  let update acc h h' = CharPairMap.add (h, h') 1 acc in
+  cartesian update CharPairMap.empty grid grid
+
+(** [calc_cost cost_map steps] calculates the cost of following [steps].
+    [cost_map] gives the cost of moving between each position. *)
+let calc_cost cost_map steps =
+  let rec impl acc from seq =
+    match Seq.uncons seq with
+    | None -> acc
+    | Some (h, t) -> impl (acc + CharPairMap.find (from, h) cost_map) h t
+  in
+  impl 0 'A' (String.to_seq steps)
+
+(** [get_next_level_costs route_map cost_map] gets the cost map which
+    corresponds to [route_map] with costs [cost_map]. *)
+let get_next_level_costs route_map cost_map =
+  let impl routes =
+    List.map (calc_cost cost_map) routes
+    |> List.fold_left (fun acc x -> min acc x) max_int
+  in
+  CharPairMap.map impl route_map
+
+(** [min_code_cost count code] returns the number of buttons a human needs to
+    press to get [code] entered when indirected through [count] robots. *)
+let min_code_cost count code =
+  let num_grid = [ '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9'; 'A' ] in
+  let num_routes = routes pos_of_numeric_grid num_grid in
+  let dir_grid = [ '<'; '>'; 'v'; '^'; 'A' ] in
+  let dir_routes = routes pos_of_dir_grid dir_grid in
+  let costs =
+    Aoc.apply_n count
+      (get_next_level_costs dir_routes)
+      (initial_cost_map dir_grid)
+  in
+  let costs = get_next_level_costs num_routes costs in
+  calc_cost costs code
+
+(** [get_code_complexity count code] returns the complexity of a given code when
+    there are [count] robots involved. *)
+let get_code_complexity count code =
+  let len = min_code_cost count code in
+  let num = int_of_string (String.sub code 0 (String.length code - 1)) in
+  num * len
+
+(** [part count codes] returns the puzzle rest when there are [count] robots,
+    and you need to enter [codes]. *)
+let part count codes =
+  List.map (get_code_complexity count) codes |> List.fold_left ( + ) 0
+
+let _ =
+  Aoc.main Aoc.strings_of_file
+    [ (string_of_int, part 2); (string_of_int, part 25) ]

bin/day2422.ml

@@ -0,0 +1,60 @@
+(** Module describing a tuple of four integers, used for the map keys later. *)
+module Int4Tuple = struct
+  type t = int * int * int * int
+
+  let compare = Stdlib.compare
+end
+
+module Int4Map = Map.Make (Int4Tuple)
+(** Map keyed by a tuple of 4 integers *)
+
+(** [next_secret secret] returns the next secret value after [secret]. *)
+let next_secret secret =
+  let secret = secret * 64 lxor secret mod 16777216 in
+  let secret = secret / 32 lxor secret mod 16777216 in
+  let secret = secret * 2048 lxor secret mod 16777216 in
+  secret
+
+let part1 n nums =
+  List.map (Aoc.apply_n n next_secret) nums |> List.fold_left ( + ) 0
+
+(** [secret_list n secret] returns a list containing the [n] secrets after
+    [secret]. *)
+let secret_list n secret =
+  let rec impl s () = Seq.Cons (s, impl (next_secret s)) in
+  Seq.drop 1 (impl secret) |> Seq.take n |> List.of_seq
+
+(** [find_sequence_values map lst] updates [map] to contain the value of the
+    sale for the first occurance in each sequence of 4 differences in [lst]. *)
+let rec find_sequence_values map =
+  let update_value amt = function None -> Some amt | x -> x in
+  function
+  | a :: b :: c :: d :: e :: t ->
+      find_sequence_values
+        (Int4Map.update (b - a, c - b, d - c, e - d) (update_value e) map)
+        (b :: c :: d :: e :: t)
+  | _ -> map
+
+let part2 n secrets =
+  let merge_values _ x y =
+    match (x, y) with
+    | Some x, Some y -> Some (x + y)
+    | Some x, None -> Some x
+    | None, Some y -> Some y
+    | None, None -> None
+  in
+  let costs =
+    List.map (secret_list n) secrets (* list of lists of secrets *)
+    |> List.map (List.map (fun x -> x mod 10)) (* list of lists of values *)
+    |> List.map (find_sequence_values Int4Map.empty) (* sequence -> value map *)
+    |> List.fold_left (* merge maps - adding values of same key *)
+         (fun acc map -> Int4Map.merge merge_values acc map)
+         Int4Map.empty
+  in
+  Int4Map.fold (fun _ v acc -> max acc v) costs 0 (* find max value *)
+
+let read_file fname = Aoc.strings_of_file fname |> List.map int_of_string
+
+let _ =
+  Aoc.main read_file
+    [ (string_of_int, part1 2000); (string_of_int, part2 2000) ]

bin/day2423.ml

@@ -0,0 +1,93 @@
+module StringMap = Map.Make (String)
+module StringSet = Set.Make (String)
+
+let add_connection map (a, b) =
+  let update s = function
+    | None -> Some (StringSet.add s StringSet.empty)
+    | Some set -> Some (StringSet.add s set)
+  in
+  let map = StringMap.update a (update b) map in
+  let map = StringMap.update b (update a) map in
+  map
+
+let make_pairs = function
+  | [ a; b ] -> (a, b)
+  | _ -> raise (invalid_arg "make_pairs")
+
+let load_file fname =
+  Aoc.strings_of_file fname
+  |> List.map (String.split_on_char '-')
+  |> List.map make_pairs
+  |> List.fold_left add_connection StringMap.empty
+
+let rec find_second_member acc connections visited a candidates =
+  let rec impl acc set = function
+    | [] -> acc
+    | c :: t -> impl (StringSet.add c set :: acc) set t
+  in
+  match StringSet.choose_opt candidates with
+  | None -> acc
+  | Some h ->
+      let candidates = StringSet.remove h candidates in
+      if StringSet.mem h visited then
+        find_second_member acc connections visited a candidates
+      else
+        let visited = StringSet.add h visited in
+        let anh = StringSet.inter (StringMap.find h connections) candidates in
+        let acc =
+          impl acc (StringSet.of_list [ a; h ]) (StringSet.to_list anh)
+        in
+        find_second_member acc connections visited a candidates
+
+let rec find_rings acc visited connections = function
+  | [] -> acc
+  | h :: t ->
+      if StringSet.mem h visited then find_rings acc visited connections t
+      else
+        let visited = StringSet.add h visited in
+        let acc =
+          find_second_member acc connections visited h
+            (StringMap.find h connections)
+        in
+        find_rings acc visited connections t
+
+(** [starts_with_t set] returns true if any member of [set] starts with the
+    letter ['t']. *)
+let starts_with_t = StringSet.exists (fun x -> x.[0] = 't')
+
+let part1 connections =
+  StringMap.to_list connections
+  |> List.map fst
+  |> find_rings [] StringSet.empty connections
+  |> List.filter starts_with_t |> List.length |> string_of_int
+
+(** [find_max_set connections] returns a list containing the largest number of
+    computers in a star network (that is for every pair of elements in the list
+    there is a connection between them).
+
+    [connections] is the map of connections keyed by computer with the value
+    being a set of all direct connections. [connections] must be bi-directional
+    that is if: [StringSet.mem a (StringMap.find b connections)] then
+    [StringSet.mem b (StringMap.find a connections)]. Note that
+    [StringSet.mem a (StringMap.find a connections)] must return [false]. *)
+let find_max_set connections =
+  let rec search_candidate max_lst current candidates =
+    (* recursion invariant: all nodes in the list [current] are in a clique with
+       each other.  [current] unioned with any individual element of 
+       [candidates] is also a valid clique. *)
+    match candidates with
+    | [] ->
+        if List.length current > List.length max_lst then current else max_lst
+    | h :: t ->
+        let map = StringMap.find h connections in
+        let current' = h :: current in
+        let candidates' = List.filter (Fun.flip StringSet.mem map) candidates in
+        let max_lst = search_candidate max_lst current' candidates' in
+        search_candidate max_lst current t
+  in
+  StringMap.to_list connections |> List.map fst |> search_candidate [] []
+
+let part2 connections =
+  find_max_set connections |> List.sort compare |> String.concat ","
+
+let _ = Aoc.main load_file [ (Fun.id, part1); (Fun.id, part2) ]

bin/day2424.ml

@@ -0,0 +1,134 @@
+type op = And | Or | Xor
+type gate = { in1 : string; in2 : string; op : op; out : string }
+
+module StringMap = Map.Make (String)
+
+let get_wire_value str =
+  let re = Str.regexp {|\(.+\): \([01]\)|} in
+  let _ = Str.search_forward re str 0 in
+  let v = if Str.matched_group 2 str = "0" then 0 else 1 in
+  (Str.matched_group 1 str, v)
+
+let get_gate_op = function
+  | "AND" -> And
+  | "OR" -> Or
+  | "XOR" -> Xor
+  | _ -> failwith "get_gate_op"
+
+let[@warning "-32"] string_of_op = function
+  | And -> "AND"
+  | Or -> "OR"
+  | Xor -> "XOR"
+
+let get_gate_config str =
+  let re = Str.regexp {|\(.+\) \(AND\|OR\|XOR\) \(.+\) -> \(.+\)|} in
+  let _ = Str.search_forward re str 0 in
+  let in1 = Str.matched_group 1 str in
+  let op = get_gate_op (Str.matched_group 2 str) in
+  let in2 = Str.matched_group 3 str in
+  let out = Str.matched_group 4 str in
+  { in1; in2; op; out }
+
+let initial_wires_of_strings =
+  let rec impl acc = function
+    | "" :: t -> (acc, t)
+    | h :: t ->
+        let wire, v = get_wire_value h in
+        impl (StringMap.add wire v acc) t
+    | _ -> failwith "initial_wires_of_strings"
+  in
+  impl StringMap.empty
+
+let gates_from_strings =
+  let rec impl acc = function
+    | [] -> acc
+    | h :: t -> impl (get_gate_config h :: acc) t
+  in
+  impl []
+
+let config_of_file fname =
+  let lst = Aoc.strings_of_file fname in
+  let wires, lst = initial_wires_of_strings lst in
+  let gates = gates_from_strings lst in
+  (wires, gates)
+
+let process_gate wires gate =
+  match
+    ( gate.op,
+      StringMap.find_opt gate.in1 wires,
+      StringMap.find_opt gate.in2 wires )
+  with
+  | And, Some a, Some b -> if a = 1 && b = 1 then Some 1 else Some 0
+  | Or, Some a, Some b -> if a = 1 || b = 1 then Some 1 else Some 0
+  | Xor, Some a, Some b -> if a <> b then Some 1 else Some 0
+  | _, _, _ -> None
+
+let process_gates wires =
+  let rec impl wires acc = function
+    | [] -> (wires, acc)
+    | h :: t -> begin
+        match process_gate wires h with
+        | None -> impl wires (h :: acc) t
+        | Some x ->
+            let wires = StringMap.add h.out x wires in
+            impl wires acc t
+      end
+  in
+  impl wires []
+
+let rec repeat_to_end wires gates =
+  let old_len = List.length gates in
+  let wires, gates = process_gates wires gates in
+  if gates = [] then Some wires
+  else if old_len = List.length gates then begin
+    Printf.printf "Loop detected: %d\n" (List.length gates);
+    None
+  end
+  else begin
+    repeat_to_end wires gates
+  end
+
+let calc_value = Fun.flip (List.fold_right (fun x acc -> x + (2 * acc))) 0
+
+let k_wires wires x =
+  StringMap.filter (fun k _ -> k.[0] = x) wires
+  |> StringMap.bindings |> List.map snd |> calc_value
+
+let wires_set wires x v' =
+  let set_v k v =
+    if k.[0] = x then
+      let idx = int_of_string (String.sub k 1 (String.length k - 1)) in
+      (v' lsr idx) land 1
+    else v
+  in
+  StringMap.mapi set_v wires
+
+let part1 (wires, gates) =
+  match repeat_to_end wires gates with
+  | None -> failwith "part1"
+  | Some wires -> k_wires wires 'z'
+
+let part2 (wires, gates) =
+  let run_test x y =
+    let wires = wires_set wires 'x' x in
+    let wires = wires_set wires 'y' y in
+    Printf.printf "%d + %d = " (k_wires wires 'x') (k_wires wires 'y');
+    match repeat_to_end wires gates with
+    | None -> print_endline "(infinite loop)"
+    | Some wires ->
+        let z = k_wires wires 'z' in
+        print_int z;
+        if z <> x + y then print_string " (wrong answer)";
+        print_newline ()
+  in
+  let tst n =
+    Printf.printf "Test for n = %d\n" n;
+    run_test (1 lsl n) 0;
+    run_test 0 (1 lsl n);
+    run_test (1 lsl n) (1 lsl n)
+  in
+  Seq.ints 0 |> Seq.take 45 |> Seq.iter tst;
+  0
+
+let _ =
+  Aoc.main config_of_file [ (string_of_int, part1); (string_of_int, part2) ]

bin/day2425.ml

@@ -0,0 +1,34 @@
+let pin_count = 5
+let height = 7
+
+let read_lock_or_key lst =
+  let result = Array.make pin_count 0 in
+  let add_node i c = if c = '#' then result.(i) <- result.(i) + 1 in
+  List.iter (String.iteri add_node) lst;
+  result |> Array.to_list
+
+let locks_and_keys_of_list =
+  let rec impl locks keys = function
+    | [] -> (locks, keys)
+    | "" :: t -> impl locks keys t
+    | a :: b :: c :: d :: e :: f :: g :: t ->
+        let h = read_lock_or_key [ a; b; c; d; e; f; g ] in
+        if a = String.make pin_count '#' then impl locks (h :: keys) t
+        else impl (h :: locks) keys t
+    | _ -> failwith "locks_and_keys_of_list"
+  in
+  impl [] []
+
+let locks_and_keys_of_file fname =
+  Aoc.strings_of_file fname |> locks_and_keys_of_list
+
+let lock_key_fit lock key =
+  List.map2 ( + ) lock key |> List.for_all (( >= ) height)
+
+let count_keys keys lock = List.filter (lock_key_fit lock) keys |> List.length
+
+let count_locks_and_keys (locks, keys) =
+  List.map (count_keys keys) locks |> List.fold_left ( + ) 0
+
+let _ =
+  Aoc.main locks_and_keys_of_file [ (string_of_int, count_locks_and_keys) ]

bin/dune

@@ -1,4 +1,54 @@
 (executables
- (public_names day2401 day2402 day2403 day2404 day2405)
+ (public_names
- (names day2401 day2402 day2403 day2404 day2405)
+  day2401
+  day2402
+  day2403
+  day2404
+  day2405
+  day2406
+  day2407
+  day2408
+  day2409
+  day2410
+  day2411
+  day2412
+  day2413
+  day2414
+  day2415
+  day2416
+  day2417
+  day2418
+  day2419
+  day2420
+  day2421
+  day2422
+  day2423
+  day2424
+  day2425)
+ (names
+  day2401
+  day2402
+  day2403
+  day2404
+  day2405
+  day2406
+  day2407
+  day2408
+  day2409
+  day2410
+  day2411
+  day2412
+  day2413
+  day2414
+  day2415
+  day2416
+  day2417
+  day2418
+  day2419
+  day2420
+  day2421
+  day2422
+  day2423
+  day2424
+  day2425)
  (libraries str aoc))

dune-project

@@ -20,7 +20,17 @@
  (synopsis "Implementation of AoC competitions in OCaml")
  (description
   "Implementation of solutions to various Advent of Code exercises written in OCaml")
- (depends ocaml dune)
+ (depends
+  (ocaml
+   (>= 5.2))
+  dune
+  (ocamlformat
+   (and
+    :dev
+    (= 0.26.2)))
+  (odoc :build)
+  (utop :dev)
+  (ocaml-lsp-server :dev))
  (tags
   (advent-of-code ocaml)))
 

lib/aoc.ml

@@ -1,16 +1,24 @@
-let ints_of_string s = List.map int_of_string (Str.split (Str.regexp " +") s)
+let ints_of_string ?(sep = " ") s =
+  List.map int_of_string (Str.split (Str.regexp sep) s)
+
 let distance1 a b = abs (a - b)
 
 let strings_of_file fname =
   In_channel.with_open_text fname In_channel.input_lines
 
+let string_of_file fname =
+  match In_channel.with_open_text fname In_channel.input_line with
+  | Some x -> x
+  | None -> failwith "Aoc.string_of_file"
+
 let main prep parts =
   try
     match Sys.argv with
     | [| _; fname |] ->
         let lines = prep fname in
         let do_part i (fmt, fn) =
-          Printf.printf "Part %d = %s\n" (i + 1) (fmt (fn lines))
+          Printf.printf "Part %d = %s\n" (i + 1) (fmt (fn lines));
+          flush stdout
         in
         List.iteri do_part parts;
         exit 0
@@ -18,5 +26,78 @@ let main prep parts =
         Printf.printf "Usage: %s <fname>\n" Sys.executable_name;
         exit 2
   with e ->
-    Printf.printf "An error occured: %s\n" (Printexc.to_string e);
+    Printf.fprintf stderr "An error occured: %s\n" (Printexc.to_string e);
+    if Printexc.backtrace_status () then (
+      Printf.fprintf stderr "Backtrace:\n";
+      Printexc.print_backtrace stderr);
     exit 1
+
+module IntPair = struct
+  type t = int * int
+
+  let compare (x, y) (x', y') =
+    match compare y y' with 0 -> compare x x' | c -> c
+end
+
+module IntPairSet = Set.Make (IntPair)
+
+module Grid = struct
+  type t = { grid : string; width : int; height : int }
+
+  let of_file fname =
+    let strs = strings_of_file fname in
+    let width = String.length (List.hd strs) in
+    let grid = List.fold_left ( ^ ) "" strs in
+    let height = String.length grid / width in
+    { grid; width; height }
+
+  let length grid = String.length grid.grid
+  let pos_of_idx grid idx = (idx mod grid.width, idx / grid.width)
+  let idx_of_pos grid (x, y) = x + (y * grid.width)
+
+  let pos_is_valid grid (x, y) =
+    x >= 0 && x < grid.width && y >= 0 && y < grid.height
+
+  let get_by_idx grid idx = grid.grid.[idx]
+  let get_by_pos grid pos = get_by_idx grid (idx_of_pos grid pos)
+
+  let get_by_pos_opt grid pos =
+    if pos_is_valid grid pos then Some (get_by_pos grid pos) else None
+
+  let idx_from_opt grid = String.index_from_opt grid.grid
+
+  let update_idx grid idx c =
+    let builder = Buffer.create (length grid) in
+    Buffer.add_string builder (String.sub grid.grid 0 idx);
+    Buffer.add_char builder c;
+    Buffer.add_string builder
+      (String.sub grid.grid (idx + 1) (length grid - idx - 1));
+    { grid with grid = Buffer.contents builder }
+
+  let update_pos grid pos c = update_idx grid (idx_of_pos grid pos) c
+end
+
+let log10i i =
+  let rec impl acc = function 0 -> acc | x -> impl (acc + 1) (x / 10) in
+  assert (i > 0);
+  impl ~-1 i
+
+let digits10 = function
+  | 0 -> 1
+  | n when n > 0 -> 1 + log10i n
+  | n (* when n < 0 *) -> 1 + log10i (-n)
+
+let pow10 n =
+  let rec impl acc = function 0 -> acc | x -> impl (acc * 10) (x - 1) in
+  assert (n >= 0);
+  impl 1 n
+
+let memoize memo f value =
+  match Hashtbl.find_opt memo value with
+  | Some x -> x
+  | None ->
+      let x = f value in
+      Hashtbl.add memo value x;
+      x
+
+let rec apply_n n fn arg = if n <= 0 then arg else apply_n (n - 1) fn (fn arg)

lib/aoc.mli

@@ -1,18 +1,154 @@
-val ints_of_string : string -> int list
+val ints_of_string : ?sep:string -> string -> int list
-(** [nums_from_string s] takes a string of space separated integers and gives
+(** [nums_from_string ?sep s] takes a string of integers separated by [sep] and
-    back a list of the integers. *)
+    gives back a list of the integers. By default [sep] is " " *)
 
 val distance1 : int -> int -> int
 (** [distance1 a b] returns the absolute difference between [a] and [b]. *)
 
 val strings_of_file : string -> string list
-(** [strings_from_file fname] returns a list of strings from the file 
+(** [strings_from_file fname] returns a list of strings from the file [fname].
-    [fname].  Each string represents a line from the file. *)
+    Each string represents a line from the file. *)
+
+val string_of_file : string -> string
+(** [string_of_file fname] returns the first line in [fname]. *)
+
+val log10i : int -> int
+(** [log10i n] returns the floor of [(log10 (float_of_int n))]. [n] must be
+    positive. *)
+
+val digits10 : int -> int
+(** [digits10 n] returns the number of base-10 digits in [n]. *)
+
+val pow10 : int -> int
+(** [pow10 n] returns [int_of_float (10. ** float_of_int n)]. [n] must be
+    non-negative. *)
 
 val main : (string -> 'a) -> (('b -> string) * ('a -> 'b)) list -> unit
-(** [main prep parts] executes an advent of code problem.  [prep fname] should
+(** [main prep parts] executes an advent of code problem. [prep fname] should be
-    be a function that returns the input from [fname].  Each elemet of
+    a function that returns the input from [fname]. Each elemet of [parts] is a
-    [parts] is a pair of functions.  The first converts the output to a string
+    pair of functions. The first converts the output to a string (for example
-    (for example [string_of_int]).  The second executes the given part.
+    [string_of_int]). The second executes the given part. Output is given as if
-    Output is given as if done by: 
+    done by: [print_string ( prep fname |> snd |> fst )] *)
-    [print_string ( prep fname |> snd |> fst )] *)
+
+val memoize : ('a, 'b) Hashtbl.t -> ('a -> 'b) -> 'a -> 'b
+(** [memoize memo f value] returns the result of [f value]. The hashtable [memo]
+    is used to cache results, so repeated calls with the same [value] will not
+    call [f] again. *)
+
+val apply_n : int -> ('a -> 'a) -> 'a -> 'a
+(** [apply_n n fn arg] is equivalent to [(fn (fn ... (fn (fn arg))))] where [fn]
+    is called [n] times.*)
+
+(** Module representing a pair of integers, useful for Set.Make *)
+module IntPair : sig
+  type t = int * int
+  (** [t] is a pair of integers *)
+
+  val compare : t -> t -> int
+  (** Standard comparion operation. *)
+end
+
+(** IntPairSet represents a Set of integers, see standard docs for info. *)
+module IntPairSet : sig
+  type elt = IntPair.t
+  type t = Set.Make(IntPair).t
+
+  val empty : t
+  val add : elt -> t -> t
+  val singleton : elt -> t
+  val remove : elt -> t -> t
+  val union : t -> t -> t
+  val inter : t -> t -> t
+  val disjoint : t -> t -> bool
+  val diff : t -> t -> t
+  val cardinal : t -> int
+  val elements : t -> elt list
+  val min_elt : t -> elt
+  val min_elt_opt : t -> elt option
+  val max_elt : t -> elt
+  val max_elt_opt : t -> elt option
+  val choose : t -> elt
+  val choose_opt : t -> elt option
+  val find : elt -> t -> elt
+  val find_opt : elt -> t -> elt option
+  val find_first : (elt -> bool) -> t -> elt
+  val find_first_opt : (elt -> bool) -> t -> elt option
+  val find_last : (elt -> bool) -> t -> elt
+  val find_last_opt : (elt -> bool) -> t -> elt option
+  val iter : (elt -> unit) -> t -> unit
+  val fold : (elt -> 'acc -> 'acc) -> t -> 'acc -> 'acc
+  val map : (elt -> elt) -> t -> t
+  val filter : (elt -> bool) -> t -> t
+  val filter_map : (elt -> elt option) -> t -> t
+  val partition : (elt -> bool) -> t -> t * t
+  val split : elt -> t -> t * bool * t
+  val is_empty : t -> bool
+  val mem : elt -> t -> bool
+  val equal : t -> t -> bool
+  val compare : t -> t -> int
+  val subset : t -> t -> bool
+  val for_all : (elt -> bool) -> t -> bool
+  val exists : (elt -> bool) -> t -> bool
+  val to_list : t -> elt list
+  val of_list : elt list -> t
+  val to_seq_from : elt -> t -> elt Seq.t
+  val to_seq : t -> elt Seq.t
+  val to_rev_seq : t -> elt Seq.t
+  val add_seq : elt Seq.t -> t -> t
+  val of_seq : elt Seq.t -> t
+end
+
+(** The [Grid] module is used to represent and manipulate a grid of characters.
+    Its main goals are to be non-mutable and have constant access times to
+    locations in the grid.
+
+    Grid locations can be accessed by index or (col, row) position. Indicies do
+    not guarantee an ordering on accesses - but iterating by index from 0 to
+    [Grid.length grid - 1] inclusive will cover the whole grid. *)
+module Grid : sig
+  type t
+  (** The type used to represent a grid *)
+
+  val of_file : string -> t
+  (** [Grid.of_file fname] returns a grid loaded from the file [fname] *)
+
+  val length : t -> int
+  (** [Grid.length grid] returns the length of the grid. *)
+
+  val get_by_idx : t -> int -> char
+  (** [Grid.get_by_idx grid idx] returns the character at index [idx] in [grid].
+  *)
+
+  val get_by_pos : t -> int * int -> char
+  (** [Grid.get_by_pos grid pos] returns the character at position [pos] in
+      [grid]. *)
+
+  val get_by_pos_opt : t -> int * int -> char option
+  (** [Grid.get_by_pos_opt grid pos] returns [Some (get_by_pos grid pos)] if
+      [pos] is a valid position in [grid], and [None] otherwise. *)
+
+  val pos_of_idx : t -> int -> int * int
+  (** [Grid.pos_of_idx grid idx] returns the [(x, y)] position mapped by [idx]
+      in [grid]. *)
+
+  val idx_of_pos : t -> int * int -> int
+  (** [Grid.pos_of_idx grid pos] returns the index corresponding to [pos] in
+      [grid]. *)
+
+  val pos_is_valid : t -> int * int -> bool
+  (** [Grid.pos_is_valid grid pos] returns [true] if and only if [pos] is a
+      valid position in [grid]. *)
+
+  val idx_from_opt : t -> int -> char -> int option
+  (** [Grid.idx_from_opt grid start c] returns [Some idx] where [idx] is the
+      first location in [grid] at or after the [start] index which is [c]. It
+      returns [None] if [c] does not appear. *)
+
+  val update_pos : t -> int * int -> char -> t
+  (** [Grid.update_pos grid pos c] returns a grid with the character at position
+      [pos] changed to [c]. *)
+
+  val update_idx : t -> int -> char -> t
+  (** [Grid.update_pos grid idx c] returns a grid with the character at index
+      [idx] changed to [c]. *)
+end