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.27.0
+exp-grouping = preserve

bin/day2407.ml

@@ -35,8 +35,8 @@ let is_valid_target tgt nums ops =
     | [] -> List.exists (( = ) 0) tgts
     | h :: t ->
         impl
-          (List.map (fun tgt -> List.map (fun op -> op tgt h) ops) tgts
-          |> List.concat |> List.filter_map Fun.id)
+          (List.map (fun tgt -> List.filter_map (fun op -> op tgt h) ops) tgts
+          |> List.concat)
           t
   in
   impl [ tgt ] nums

bin/day2412.ml

@@ -1,35 +1,75 @@
-let find_regions grid =
-  let working = Array.make (Aoc.Grid.length grid) ~-1 in
-  let add_pos region pos perimeter lst =
-    if Aoc.Grid.pos_is_valid grid pos && Aoc.Grid.get_by_pos grid pos = region
-    then (Aoc.Grid.idx_of_pos grid pos :: lst, perimeter - 1)
-    else (lst, perimeter)
+(** [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
-  let rec scan_pos perimeter area id = function
+  [ (-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 working.(idx) <> -1 -> scan_pos perimeter area id t
-    | idx :: t ->
-        working.(idx) <- id;
+    | 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 = succ area in
-        let perimeter = perimeter + 4 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, perimeter = add_pos region (x - 1, y) perimeter t in
-        let t, perimeter = add_pos region (x + 1, y) perimeter t in
-        let t, perimeter = add_pos region (x, y - 1) perimeter t in
-        let t, perimeter = add_pos region (x, y + 1) perimeter t in
-        scan_pos perimeter area id t
+        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 id =
+  let rec impl acc idx =
     if idx >= Aoc.Grid.length grid then List.rev acc
     else
-      let perimeter, area = scan_pos 0 0 id [ idx ] in
-      if area = 0 then impl acc (idx + 1) id
-      else impl ((perimeter, area) :: acc) (idx + 1) (id + 1)
+      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 0
+  impl [] 0
 
-let part1 grid =
-  find_regions grid |> List.fold_left (fun acc (p, a) -> acc + (p * a)) 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, part1) ]
+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

@@ -11,7 +11,20 @@
   day2409
   day2410
   day2411
-  day2412)
+  day2412
+  day2413
+  day2414
+  day2415
+  day2416
+  day2417
+  day2418
+  day2419
+  day2420
+  day2421
+  day2422
+  day2423
+  day2424
+  day2425)
  (names
   day2401
   day2402
@@ -24,5 +37,18 @@
   day2409
   day2410
   day2411
-  day2412)
+  day2412
+  day2413
+  day2414
+  day2415
+  day2416
+  day2417
+  day2418
+  day2419
+  day2420
+  day2421
+  day2422
+  day2423
+  day2424
+  day2425)
  (libraries str aoc))

lib/aoc.ml

@@ -54,22 +54,27 @@ module Grid = struct
   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 get_by_idx grid idx = grid.grid.[idx]
-  let get_by_pos grid pos = get_by_idx grid (idx_of_pos grid pos)
 
   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_pos grid pos c =
-    let idx = idx_of_pos grid pos in
+  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 =
@@ -86,3 +91,13 @@ 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

@@ -30,6 +30,15 @@ val main : (string -> 'a) -> (('b -> string) * ('a -> 'b)) list -> unit
     [string_of_int]). The second executes the given part. Output is given as if
     done by: [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
@@ -114,6 +123,10 @@ module Grid : sig
   (** [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]. *)
@@ -134,4 +147,8 @@ module Grid : sig
   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