Source

kamlostuff / topological.ml

type 'a graph = 'a list * (('a * 'a) list)

let vertexes:('a graph -> 'a list) = fst

let edges:('a graph -> ('a * 'a) list) = snd

let make_graph:('a list -> ('a * 'a) list -> 'a graph) = 
    fun vertexes edges -> (vertexes, edges)

let graph:(int graph) = 
  let node2 = 2 and node3 = 3 and node5 = 5
  and node7 = 7 and node8 = 8 and node9 = 9
  and node10 = 10 and node11 = 11
  in
    ([node2; node3; node5; node7; node8; node9;
      node10; node11],
     [(node3, node8); (node3, node10);
      (node5, node11);
      (node7, node11); (node7, node8);
      (node8, node9);
      (node11, node2); (node11, node9); (node11, node10)
     ])

let incoming from_graph for_node =
  let work acc (from, to_) = 
    if to_ == for_node then (from::acc) else acc
  in (for_node, List.fold_left work [] (edges from_graph))

let all_incoming graph = 
  let incoming' = incoming graph in
  List.map incoming' (vertexes graph)
  
let topological_sort graph = 
  let graph_size = List.length (vertexes graph) in
  let rec choose sorted all_incom vert = match vert with 
    | [] -> failwith "Graph contains circuits!"
    | (head::tail) -> 
        let in_sorted = List.mem head sorted in
        let is_begining = List.length (List.assoc head all_incom) = 0 in
          if not in_sorted && is_begining then head
          else choose sorted all_incom tail
  in
  let rec sort sorted all_incom vertexes' = 
    if List.length sorted < graph_size then
      let vert = choose sorted all_incom vertexes' in
      let vertexes'' = List.filter ((!=) vert) vertexes' in
      let sorted' = (vert::sorted) in
      let work (to_, from) = (to_, List.filter ((!=) vert) from) in 
      let all_incom' = List.map work all_incom in
        sort sorted' all_incom' vertexes''
    else List.rev sorted
  in
  let sorted_vertexes = sort [] (all_incoming graph) (vertexes graph) in 
    make_graph sorted_vertexes (edges graph)