| 1 | module List = ListLabels |
| 2 | |
| 3 | module Map = Tiger_map |
| 4 | module Opt = Tiger_opt |
| 5 | |
| 6 | type t = |
| 7 | unit |
| 8 | |
| 9 | type count = |
| 10 | { parents : int |
| 11 | ; children : int |
| 12 | } |
| 13 | |
| 14 | let of_list pairs = |
| 15 | let incr counts k incr = |
| 16 | let prev = Opt.get (Map.get counts ~k) ~default:{parents=0; children=0} in |
| 17 | Map.set counts ~k ~v:(incr prev) |
| 18 | in |
| 19 | let incr_parents count = {count with parents = succ count.parents} in |
| 20 | let incr_children count = {count with children = succ count.children} in |
| 21 | let zero_children counts = |
| 22 | List.filter (Map.to_list counts) ~f:(fun (_, {children=c; _}) -> c = 0 ) |
| 23 | in |
| 24 | let zero_parents counts = |
| 25 | List.filter (Map.to_list counts) ~f:(fun (_, {parents=p; _}) -> p = 0 ) |
| 26 | in |
| 27 | let counts = |
| 28 | List.fold_left pairs ~init:Map.empty ~f:( |
| 29 | fun counts (p, c) -> |
| 30 | let counts = incr counts p incr_children in |
| 31 | let counts = incr counts c incr_parents in |
| 32 | counts |
| 33 | ) |
| 34 | in |
| 35 | (* At least one node with no in-coming links and |
| 36 | * at least one node with no out-going links. *) |
| 37 | match (zero_parents counts, zero_children counts) with |
| 38 | | _ :: _, _ :: _ -> Ok () |
| 39 | | _, _ -> Error `Cycle |