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.map (fun tgt -> List.filter_map (fun op -> op tgt h) ops) tgts
-          |> List.concat |> List.filter_map Fun.id)
+          |> List.concat)
           t
   in
   impl [ tgt ] nums

bin/day2417.ml

@@ -129,7 +129,8 @@ let rec execute_until_halted vm =
   | false -> execute_until_halted (execute_insn vm)
 
 (** [string_of_ouput vm] gives the output of [vm]. *)
-let string_of_output 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
@@ -159,8 +160,8 @@ let scan_all vm =
   impl 0 (Array.length vm.code - 1)
 
 (** [string_of_a vm] returns the A register of [vm]. *)
-let string_of_a vm = string_of_int vm.a
+let part2 vm =
+  let vm = scan_all vm in
+  string_of_int vm.a
 
-let _ =
+let _ = Aoc.main vm_of_file [ (Fun.id, part1); (Fun.id, part2) ]
-  Aoc.main vm_of_file
-    [ (string_of_output, execute_until_halted); (string_of_a, scan_all) ]

bin/day2418.ml

@@ -104,12 +104,12 @@ let find_route_length count grid =
 let part1 count rocks =
   match find_route_length count rocks with
   | None -> failwith "part1"
-  | Some (cost, _) -> cost
+  | 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 start_count grid =
+let part2 width start_count grid =
   (* Implementation notes:
   
      We do this by binary search in impl.  The left_count is a known count of
@@ -137,16 +137,11 @@ let part2 start_count grid =
   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 -> idx
+  | Some idx -> Printf.sprintf "%d,%d" (idx mod width) (idx / width)
-
-(** [string_of_idx width idx] prints the (x, y) location for a given index in a
-    grid. *)
-let string_of_idx width idx =
-  Printf.sprintf "%d,%d" (idx mod width) (idx / width)
 
 (** Width of grid *)
 let width = 71
 
 let _ =
   Aoc.main (grid_of_file width)
-    [ (string_of_int, part1 1024); (string_of_idx width, part2 1024) ]
+    [ (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

@@ -17,7 +17,14 @@
   day2415
   day2416
   day2417
-  day2418)
+  day2418
+  day2419
+  day2420
+  day2421
+  day2422
+  day2423
+  day2424
+  day2425)
  (names
   day2401
   day2402
@@ -36,5 +43,12 @@
   day2415
   day2416
   day2417
-  day2418)
+  day2418
+  day2419
+  day2420
+  day2421
+  day2422
+  day2423
+  day2424
+  day2425)
  (libraries str aoc))

lib/aoc.ml

@@ -66,14 +66,15 @@ module Grid = struct
 
   let idx_from_opt grid = String.index_from_opt grid.grid
 
-  let update_pos grid pos c =
+  let update_idx grid idx c =
-    let idx = idx_of_pos grid pos in
     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 =
@@ -90,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
@@ -138,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