Source file TSort.ml

(*

   MIT License

   Copyright (c) 2019 Daniil Baturin

   Permission is hereby granted, free of charge, to any person obtaining a copy
   of this software and associated documentation files (the "Software"), to deal
   in the Software without restriction, including without limitation the rights
   to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
   copies of the Software, and to permit persons to whom the Software is
   furnished to do so, subject to the following conditions:

   The above copyright notice and this permission notice shall be included in all
   copies or substantial portions of the Software.

   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
   AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
   OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
   SOFTWARE.
*)

(* CHANGES:
   Added functor [Hashtbl] argument since we need to inject custom comparators + hashes.

   Removed [sort_strongly_connected_components] since unused
   and made [Hashtbl] functor argument monomorphic over integers.

   Went further and removed everything except [sort]. *)

module Make (Hashtbl : Hashtbl.S) = struct
  (* Original: https://github.com/dmbaturin/ocaml-tsort/blob/39320d506369b1dc508ca75ee4f8898e401f9016/src/lib/compat.ml *)
  module Compat = struct
    (*
   Basic functions not available in older versions of OCaml's standard
   library.
   *)

    module Hashtbl = struct
      let find_opt tbl key =
        try Some (Hashtbl.find tbl key) with Not_found -> None

      let list_keys tbl = Hashtbl.fold (fun k _ acc -> k :: acc) tbl []
    end

    module List = struct
      let rec remove ?(eq = ( = )) ~key xs =
        match xs with
        | [] -> []
        | x :: xs -> if eq x key then xs else x :: remove ~eq ~key xs
    end
  end

  (* Original: https://github.com/dmbaturin/ocaml-tsort/blob/39320d506369b1dc508ca75ee4f8898e401f9016/src/lib/tsort.ml *)

  (* User-friendly topological sort based on Kahn's algorithm.

     Usage example: sort [("foundation", []); ("basement", ["foundation"]);]

     Authors: Daniil Baturin (2019), Martin Jambon (2020).
  *)

  type 'a sort_result = Sorted of 'a list | ErrorCycle of 'a list

  (* Deduplicate list items.

     Differences with CCList.uniq:
     - when an item is duplicated, keep the first item encountered rather than
       the last: [1;2;3;1] gives [1;2;3] (not [2;3;1]).
     - complexity is O(n), not O(n^2).
  *)
  let deduplicate l =
    let tbl = Hashtbl.create (List.length l) in
    List.fold_left
      (fun acc x ->
        if Hashtbl.mem tbl x then acc
        else (
          Hashtbl.add tbl x ();
          x :: acc))
      [] l
    |> List.rev

  let graph_hash_of_list l =
    let update h k v =
      let orig_v = Compat.Hashtbl.find_opt h k in
      match orig_v with
      | None -> Hashtbl.add h k v
      | Some orig_v ->
          (* Allow "partial" dependency lists like [(1, [2]); (1, [3]); (2, [1])].
             Sometimes it's a more natural way to write cyclic graphs.
          *)
          Hashtbl.replace h k (List.append orig_v v)
    in
    let tbl = Hashtbl.create 100 in
    let () = List.iter (fun (k, v) -> update tbl k v) l in
    let () =
      Hashtbl.filter_map_inplace (fun _ xs -> Some (deduplicate xs)) tbl
    in
    tbl

  (* Finds "isolated" nodes,
     that is, nodes that have no dependencies *)
  let find_isolated_nodes hash =
    let aux id deps acc = match deps with [] -> id :: acc | _ -> acc in
    Hashtbl.fold aux hash []

  (* Takes a node name list and removes all those nodes from a hash *)
  let remove_nodes nodes hash = List.iter (Hashtbl.remove hash) nodes

  (* Walks through a node:dependencies hash and removes a dependency
     from all nodes that have it in their dependency lists *)
  let remove_dependency hash dep =
    let aux dep hash id =
      let deps = Hashtbl.find hash id in
      let deps =
        if List.exists (( = ) dep) deps then
          Compat.List.remove ~eq:( = ) ~key:dep deps
        else deps
      in
      begin
        Hashtbl.remove hash id;
        Hashtbl.add hash id deps
      end
    in
    let ids = Compat.Hashtbl.list_keys hash in
    List.iter (aux dep hash) ids

  (*
   Append missing nodes to the graph, in the order in which they were
   encountered. This particular order doesn't have to be guaranteed by the
   API but seems nice to have.
*)
  let add_missing_nodes graph_l graph =
    let missing =
      List.fold_left
        (fun acc (_, vl) ->
          List.fold_left
            (fun acc v ->
              if not (Hashtbl.mem graph v) then (v, []) :: acc else acc)
            acc vl)
        [] graph_l
      |> List.rev
    in
    List.iter (fun (v, vl) -> Hashtbl.replace graph v vl) missing;
    graph_l @ missing

  (* The Kahn's algorithm:
      1. Find nodes that have no dependencies ("isolated") and remove them from
         the graph hash.
         Add them to the initial sorted nodes list and the list of isolated
         nodes for the first sorting pass.
      2. For every isolated node, walk through the remaining nodes and
         remove it from their dependency list.
         Nodes that only depended on it now have empty dependency lists.
      3. Find all nodes with empty dependency lists and append them to the sorted
         nodes list _and_ the list of isolated nodes to use for the next step
      4. Repeat until the list of isolated nodes is empty
      5. If the graph hash is still not empty, it means there is a cycle.
  *)
  let sort nodes =
    let rec sorting_loop deps hash acc =
      match deps with
      | [] -> acc
      | dep :: deps ->
          let () = remove_dependency hash dep in
          let isolated_nodes = find_isolated_nodes hash in
          let () = remove_nodes isolated_nodes hash in
          sorting_loop
            (List.append deps isolated_nodes)
            hash
            (List.append acc isolated_nodes)
    in
    let nodes_hash = graph_hash_of_list nodes in
    let _nodes = add_missing_nodes nodes nodes_hash in
    let base_nodes = find_isolated_nodes nodes_hash in
    let () = remove_nodes base_nodes nodes_hash in
    let sorted_node_ids = sorting_loop base_nodes nodes_hash [] in
    let sorted_node_ids = List.append base_nodes sorted_node_ids in
    let remaining_ids = Compat.Hashtbl.list_keys nodes_hash in
    match remaining_ids with
    | [] -> Sorted sorted_node_ids
    | _ -> ErrorCycle remaining_ids
end