diff --git a/bin/day2421.ml b/bin/day2421.ml
index 63f3b0f..0e4344b 100644
--- a/bin/day2421.ml
+++ b/bin/day2421.ml
@@ -24,56 +24,178 @@ let pos_of_dir_grid c =
 
 let invalid_x, invalid_y = (0, 3)
 
-let rec move pos_of_grid builder (cx, cy) code =
-  match Seq.uncons code with
-  | None -> Buffer.contents builder
-  | Some (c, t) ->
-      let dx, dy = pos_of_grid c in
-      if dx > cx && (cy = dy || cy <> invalid_y) then begin
-        Buffer.add_string builder (String.make (dx - cx) '>');
-        move pos_of_grid builder (dx, cy) code
-      end
-      else if dx < cx && (cy = dy || cy <> invalid_y) then begin
-        Buffer.add_string builder (String.make (cx - dx) '<');
-        move pos_of_grid builder (dx, cy) code
-      end
-      else if dy > cy && (cx = dx || cx <> invalid_x) then begin
-        Buffer.add_string builder (String.make (dy - cy) 'v');
-        move pos_of_grid builder (cx, dy) code
-      end
-      else if dy < cy && (cx = dx || cx <> invalid_x) then begin
-        Buffer.add_string builder (String.make (cy - dy) '^');
-        move pos_of_grid builder (cx, dy) code
-      end
-      else begin
-        assert (cx = dx);
-        assert (dy = dy);
-        Buffer.add_char builder 'A';
-        move pos_of_grid builder (cx, cy) t
-      end
+let find_shortest (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
+  List.sort_uniq compare result
 
-let process_code pos_of_grid code =
-  let builder = Buffer.create 30 in
-  move pos_of_grid builder (pos_of_grid 'A') (String.to_seq code)
+let[@warning "-32"] print_list lst =
+  let rec impl = function
+    | [] -> ()
+    | h :: t ->
+        Printf.printf "; %s" h;
+        impl t
+  in
+  match lst with
+  | [] -> print_endline "[]"
+  | h :: t ->
+      Printf.printf "[%s" h;
+      impl t;
+      Printf.printf "]\n"
 
-let human_insns code =
-  let first_robot_insns = process_code pos_of_numeric_grid code in
-  let second_robot_insns = process_code pos_of_dir_grid first_robot_insns in
-  let human = process_code pos_of_dir_grid second_robot_insns in
-  print_endline human;
-  print_endline second_robot_insns;
-  print_endline first_robot_insns;
-  print_endline code;
+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)
+
+let routes pos_of_grid locs =
+  let rec impl acc pos =
+    let start = pos_of_grid pos in
+    function
+    | [] -> acc
+    | h :: t ->
+        impl
+          (CharPairMap.add (pos, h) (find_shortest start (pos_of_grid h)) acc)
+          pos t
+  in
+  let rec impl' acc = function
+    | [] -> acc
+    | h :: t -> impl' (impl acc h locs) t
+  in
+  impl' CharPairMap.empty locs
+
+let num_grid = [ '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9'; 'A' ]
+let num_routes = routes pos_of_numeric_grid num_grid
+let dir_grid = [ '<'; '>'; 'v'; '^'; 'A' ]
+let dir_routes = routes pos_of_dir_grid dir_grid
+
+let cross_product lst lst' =
+  let rec impl' acc app' = function
+    | [] -> acc
+    | h :: t -> impl' ((h ^ app') :: acc) app' t
+  in
+  let rec impl acc = function
+    | [] -> acc
+    | h :: t -> impl (impl' acc h lst) t
+  in
+  if List.is_empty lst then lst'
+  else if List.is_empty lst' then lst
+  else impl [] lst'
+
+let find_route route_map presses =
+  let rec impl acc from presses =
+    match Seq.uncons presses with
+    | None -> acc
+    | Some (h, t) ->
+        let routes = CharPairMap.find (from, h) route_map in
+        impl (cross_product acc routes) h t
+  in
+  impl [] 'A' (String.to_seq presses)
+
+let find_routes route_map press_list =
+  let rec impl acc = function
+    | [] -> acc
+    | h :: t -> impl (acc @ find_route route_map h) t
+  in
+  impl [] press_list
+
+let min_length = List.fold_left (fun acc x -> min acc (String.length x)) max_int
+
+let human_insns2 count code =
+  let rec robot_round codes n =
+    if n >= count then codes
+    else robot_round (find_routes dir_routes codes) (n + 1)
+  in
+  let first_robot_insns = find_routes num_routes [ code ] in
+  let human = robot_round first_robot_insns ~-1 in
+  min_length human
+
+let complexity2 count code =
+  let len = human_insns2 count code in
+  let num = int_of_string (String.sub code 0 (String.length code - 1)) in
+  num * len
+
+let part1a count codes =
+  List.map (complexity2 count) codes |> List.fold_left ( + ) 0
+
+let initial_cost_map grid =
+  let rec impl' acc f = function
+    | [] -> acc
+    | h :: t -> impl' (CharPairMap.add (f, h) 1 acc) f t
+  in
+  let rec impl acc = function
+    | [] -> acc
+    | h :: t -> impl (impl' acc h grid) t
+  in
+  impl CharPairMap.empty grid
+
+let calc_costs 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)
+
+let get_next_level_costs route_map cost_map =
+  let impl routes =
+    List.fold_left (fun acc x -> min acc (calc_costs cost_map x)) max_int routes
+  in
+  CharPairMap.map impl route_map
+
+let human_insns3 count code =
+  let first_round = initial_cost_map dir_grid in
+  let rec robot_round cost_map n =
+    if n >= count then cost_map
+    else robot_round (get_next_level_costs dir_routes cost_map) (n + 1)
+  in
+  let number_costs = robot_round first_round 0 in
+  let number_costs = get_next_level_costs num_routes number_costs in
+  let human = calc_costs number_costs code in
   human
 
-let complexity code =
-  let insns = human_insns code in
+let complexity3 count code =
+  let len = human_insns3 count code in
   let num = int_of_string (String.sub code 0 (String.length code - 1)) in
-  Printf.printf "%s (%d): %s (%d) (%d) \n" code num insns (String.length insns)
-    (num * String.length insns);
-  num * String.length insns
+  num * len
 
-let part1 codes = List.map complexity codes |> List.fold_left ( + ) 0
-let _ = Aoc.main Aoc.strings_of_file [ (string_of_int, part1) ]
+let part1b count codes =
+  List.map (complexity3 count) codes |> List.fold_left ( + ) 0
 
-(* 175386 too high *)
+let _ =
+  Aoc.main Aoc.strings_of_file
+    [
+      (string_of_int, part1a 1);
+      (string_of_int, part1b 2);
+      (string_of_int, part1b 25);
+    ]
+
+(* too high 524110008179112 *)