Topological sort in F#

toposort.fs

module DirectedGraphs

open System
open System.IO
open System.Text.RegularExpressions

type Conn<'a when 'a : comparison> = 'a * 'a
type Graph<'a when 'a : comparison> = 'a Set * 'a Conn Set

let eq = (=)
let incomings (vertices, conns) vertex = Set.filter (snd >> eq vertex) conns
let outgoings (vertices, conns) vertex = Set.filter (fst >> eq vertex)  conns
let connections graph conn = outgoings graph conn |> Set.union <| incomings graph conn

let isEnd graph vertex =
  let ins = incomings graph vertex
  let outs = outgoings graph vertex
  ins = Set.empty || outs = Set.empty

let isDeadEnd graph = outgoings graph >> eq Set.empty

let removeBadConns (vertices, conns) =
  vertices,
  (conns
   |> Set.filter (fun (x, y) -> (x |> Set.contains <| vertices) &&
                                (y |> Set.contains <| vertices)))

let findDeadEnds graph =
  let vertices, conns = graph
  isDeadEnd graph |> Set.filter <| vertices

let removeVertices p graph = fst graph |> Set.filter (p graph >> not), snd graph

// doesn't work on fsi: compiler bug related to generic tuples
let rec removeEnds graph = 
  let g2 = removeBadConns <| removeVertices isEnd graph
  let v1, v2 = fst graph, fst g2
  if v2.Count = v1.Count then
    id graph
  else
    removeEnds g2

let updateVertex (vertices, conns) v1 v2 =
  Set.map (fun x -> if x = v1 then v2 else x) vertices,
  Set.map (fun (x, y) -> (if x = v1 then v2 else x),
                         (if y = v1 then v2 else y)) conns

let removeVertex (vertices, conns) v =
  Set.filter (fun x -> x <> v),
  Set.filter (fun (x, y) -> not(x = v || y = v))

let hasCycles =
  removeEnds
  >> (eq (Set.empty, Set.empty))
  >> not

let label graph =
  if hasCycles graph then failwith "Graph has cycles: No solution." 
  else
    let rec label' graph n (disabledVertices, disabledConns) =
      let vertices, conns = graph
      let deadEnds = findDeadEnds graph
      let inDeadEnds x = Set.contains x deadEnds
      let bail x = failwith "Node #%A is already filled."

      if deadEnds = Set.empty then
        (vertices |> Set.union <| disabledVertices),
        (conns |> Set.union <| disabledConns)
      else
        let disabledVertices', vertices =
          Set.partition inDeadEnds vertices

        let disabledVertices' = Set.map (fun (x, a) -> match a with
                                                       | None -> x, Some(n)
                                                       | _ -> bail x) disabledVertices'

        let disabledConns', conns =
          conns
          |> Set.partition (fun (x, y) -> inDeadEnds x || inDeadEnds y)

        let graph1 = vertices, conns
        let disabled = (disabledVertices |> Set.union <| disabledVertices'),
                       (disabledConns |> Set.union <| disabledConns')
        label' graph1 (n + 1) disabled

    label' graph 1 (Set.empty, Set.empty)
    |> (fun (vertices, conns) ->
      let update v =
        match v with
        | x, None ->
          let _, v1 = Seq.find (fun (y, _) -> y = x) vertices
          x, v1
        | _ -> v
      vertices, Set.map (fun (a, b) -> update a, update b) conns
    )

do
  let vertexset = List.map (fun x -> x, None) >> Set.ofList
  let conns = List.map (fun (x, y) -> (x, (None : int option)), (y, None)) >> Set.ofList

  let graph =
    seq {
      let rxClass = new Regex(@"^(\w+)\s*$")
      let rxPrereq = new Regex(@"^\s+(\w+)\s*$")
      use sr = new StreamReader(Console.OpenStandardInput())
      while not sr.EndOfStream do
        let line = sr.ReadLine()
        let mat = rxClass.Match(line)
        if mat.Success then
          let cls = mat.Groups.[1].Value
          yield Some(cls), None
          let looping = ref true
          while not(sr.EndOfStream) && (!looping) do
            let line = sr.ReadLine()
            let mat = rxPrereq.Match(line)
            if mat.Success then
              yield Some(cls), Some(mat.Groups.[1].Value)
            else
              looping := false
    }
    |> Set.ofSeq
    |> Set.partition (fun (x, y) -> not y.IsSome)
    |> (fun (vs, cs) ->
      Set.map (fun (Some(x), _) -> x, None) vs,
      Set.map (fun (Some(x), Some(y)) -> (x, None), (y, None)) cs
    )

  let vertices, connections = label graph
  printfn "Vertices: "
  vertices
  |> Set.toSeq
  |> Seq.sortBy (fun (_, Some(x)) -> x)
  |> Seq.iter (fun (x, Some(y)) -> printfn " - %s = %d" x y)
  printfn "Connections: "
  connections
  |> Set.toSeq
  |> Seq.sortBy (fun ((x, _), _) -> x)
  |> Seq.iter (fun ((x, _), (y, _)) -> printfn " - %s -> %s" x y)