d18

18/main.ml

@@ -0,0 +1,115 @@
+open Printf;;
+
+let rec list_of_lines in_file =
+  try
+    let line = input_line in_file in
+    line :: list_of_lines(in_file)
+  with End_of_file ->
+    close_in in_file;
+    []
+
+let parse_tuple line =
+  let nums = line |> String.split_on_char ',' |> List.map int_of_string in
+  (List.hd nums, List.nth nums 1)
+
+let build_map (width, height) obstacles =
+  let arr = Array.make_matrix height width '.' in
+  List.iter (fun (x, y) -> arr.(y).(x) <- '#') obstacles;
+  arr
+
+module IntPair =
+struct
+  type t = int * int
+  let compare (x0,y0) (x1,y1) =
+    match Stdlib.compare x0 x1 with
+        0 -> Stdlib.compare y0 y1
+      | c -> c
+end
+
+module IntPairScore =
+struct
+  type t = IntPair.t * int * int
+  let compare (pos0, score0, h_score0) (pos1, score1, h_score1) =
+    match Stdlib.compare score0 score1 with
+        0 -> IntPair.compare pos0 pos1
+      | c -> c
+end
+module IntPairsScoreSet = Set.Make(IntPairScore)
+
+let generate_next_moves_pos (x, y) =
+  [(x - 1, y); (x, y - 1); (x + 1, y); (x, y + 1)]
+
+let can_go_to layout (x, y) =
+  try
+    layout.(y).(x) <> '#'
+  with Invalid_argument _ -> false
+
+let manhattan_distance (x1, y1) (x2, y2) =
+  (Int.abs (x2 - x1)) + (Int.abs (y2 - y1))
+
+let generate_next_moves layout end_pos (pos, score, h_score) =
+  generate_next_moves_pos pos
+  |> List.filter (can_go_to layout)
+  |> List.map (fun p ->
+    let h = manhattan_distance p end_pos in
+    (p, score - h_score + 1 + h, h))
+
+let rec a_star_find_path layout visited_array end_pos next_move_queue =
+  match IntPairsScoreSet.min_elt_opt next_move_queue with
+  | Some state ->
+    let ((x, y), score, _) = state in
+    let queue_with_removed = IntPairsScoreSet.remove state next_move_queue in
+    if visited_array.(y).(x) then
+      a_star_find_path layout visited_array end_pos queue_with_removed
+    else begin
+      visited_array.(y).(x) <- true;
+      let next_states = generate_next_moves layout end_pos state in
+      let solution_states = List.filter (fun (pos, _, _) -> pos = end_pos) next_states in
+      if List.length solution_states > 0 then
+        let (_, score, _) = List.hd solution_states in
+        score
+      else
+        let new_queue = List.fold_left (fun queue pos -> IntPairsScoreSet.add pos queue) queue_with_removed next_states in
+        a_star_find_path layout visited_array end_pos new_queue
+    end
+  | None -> (-1)
+
+let find_best_path layout start_pos end_pos =
+  let visited_array = Array.make_matrix (Array.length layout) (Array.length layout.(0)) false in
+  let begin_h_score = manhattan_distance start_pos end_pos in
+  a_star_find_path layout visited_array end_pos (IntPairsScoreSet.add (start_pos, begin_h_score, begin_h_score) IntPairsScoreSet.empty)
+
+let apply_first_n_obstacles map_size obstacles n =
+   obstacles
+    |> List.to_seq
+    |> Seq.take n
+    |> List.of_seq
+    |> build_map (map_size, map_size)
+
+let rec binary_search_find_min_satisfying pred lower_bound upper_bound =
+  if lower_bound = upper_bound then
+    lower_bound
+  else
+    let midpoint = (lower_bound + upper_bound) / 2 in
+    if pred midpoint then
+      binary_search_find_min_satisfying pred lower_bound midpoint
+    else
+      binary_search_find_min_satisfying pred (midpoint + 1) upper_bound
+
+let blocked_by_obstacles map_size obstacles n =
+  let map = apply_first_n_obstacles map_size obstacles n in
+  find_best_path map (0, 0) (map_size - 1, map_size - 1) < 0
+
+let find_path_cutoff map_size obstacles =
+  binary_search_find_min_satisfying (blocked_by_obstacles map_size obstacles) 1 (List.length obstacles)
+
+let () =
+  let f = open_in "input.txt" in
+  let obstacles = list_of_lines f |> List.map parse_tuple in
+  let map_size = 71 in
+  let first_elems = 1024 in
+  let part1_map = apply_first_n_obstacles map_size obstacles first_elems in
+  let result = find_best_path part1_map (0, 0) (map_size - 1, map_size - 1) in
+  let result2_index = find_path_cutoff map_size obstacles in
+  let result2 = List.nth obstacles (result2_index - 1) in
+  printf "%d\n%d,%d\n" result (fst result2) (snd result2)