Merge pull request #58 from jindraivanek/order-edit-distance

Toplogical order alg. minimize the number of move operations from original order.

.paket/Paket.Restore.targets

@@ -18,6 +18,11 @@
     <PaketExePath Condition=" '$(PaketExePath)' == '' ">$(PaketToolsPath)paket.exe</PaketExePath>
     <PaketCommand Condition=" '$(OS)' == 'Windows_NT'">"$(PaketExePath)"</PaketCommand>
     <PaketCommand Condition=" '$(OS)' != 'Windows_NT' ">$(MonoPath) --runtime=v4.0.30319 "$(PaketExePath)"</PaketCommand>
+
+    <!-- .net core fdd -->
+    <_PaketExeExtension>$([System.IO.Path]::GetExtension("$(PaketExePath)"))</_PaketExeExtension>
+    <PaketCommand Condition=" '$(_PaketExeExtension)' == '.dll' ">dotnet "$(PaketExePath)"</PaketCommand>
+
     <PaketBootStrapperExePath Condition=" '$(PaketBootStrapperExePath)' == '' AND Exists('$(PaketRootPath)paket.bootstrapper.exe')">$(PaketRootPath)paket.bootstrapper.exe</PaketBootStrapperExePath>
     <PaketBootStrapperExePath Condition=" '$(PaketBootStrapperExePath)' == '' ">$(PaketToolsPath)paket.bootstrapper.exe</PaketBootStrapperExePath>
     <PaketBootStrapperCommand Condition=" '$(OS)' == 'Windows_NT'">"$(PaketBootStrapperExePath)"</PaketBootStrapperCommand>

OrderingAlg.md

@@ -38,6 +38,13 @@ Actual implementation uses Map with the last part of the qualified identifier of
 Correct ordering of files is such that for each dependency `file1 -> file2`, `file1` is before `file2`.
 This directly translates to Topological order problem in oriented graphs: https://en.wikipedia.org/wiki/Topological_sort
 
-Kahn's algorithm mentioned on wiki is implemented.
+Kahn's algorithm mentioned on wiki is implemented with modifications to find ordering with minimal number of move operations:
+
+In each cycle, we add only one node to resulting ordered list; from set of nodes with no incoming edge, we select the one that comes first in original order.
+
+This alg outputs ordering that can be achieved by minimal number of *move up/down* operations (switching order of two neighbour elements).
+
+> *Side note (by @jindraivanek)*: If we choose different definition for edit distance as *sum of differences in node positions*, 
+> then above alg wouldn't work, and from my experiments with it, I think this is a hard (NP-complete) problem.
 
 Later, we need to find a way how to find ordering with minimal editing distance from original ordering.

src/Mechanic.Tests/Tests.fs

@@ -3,11 +3,33 @@ module Tests.Main
 open Expecto
 open Mechanic
 open Mechanic.GraphAlg
+open Mechanic.Utils
+
+module Gen =
+    open FsCheck
+
+    type RandomGraph = RandomGraph of (list<int> * list<int * int>)
+    let genEdges = 
+        Gen.sized (fun s -> 
+            let nodeGen = [1..s] |> List.map Gen.constant |> Gen.oneof
+            Gen.map2 (fun x y -> x,y) nodeGen nodeGen |> Gen.listOfLength s) 
+        |> Gen.map set |> Gen.map (Set.toList)
+    let genNodes = Gen.sized (fun s -> Gen.shuffle [1..s]) |> Gen.map List.ofArray
+    let genGraph = 
+        Gen.map2 (fun x y -> x,y) genNodes genEdges
+        |> Arb.fromGen
+        |> Arb.convert RandomGraph (fun (RandomGraph l) -> l)
+    let addToConfig config =
+        {config with arbitrary = typeof<RandomGraph>.DeclaringType::config.arbitrary}
+
+let correctOrder edges order =
+    let orderPos = order |> List.mapi (fun i v -> v, i) |> Map.ofList
+    Seq.forall (fun (v,w) -> orderPos.[v] < orderPos.[w]) edges
 
 [<Tests>]
  let tests =
     testList "GraphAlg" [
-        testProperty "Topological order alg" <| fun (edges: list<int * int>) ->
+        testPropertyWithConfig (Gen.addToConfig {FsCheckConfig.defaultConfig with maxTest = 100; endSize = 100}) "Topological order alg - correctness" <| fun (Gen.RandomGraph(nodes, edges)) ->
             let rec haveCycleAcc edges acc =
                 let (edgesFrom, edgesRemain) = edges |> List.partition (fun (v,_) -> Set.contains v acc)
                 match edgesFrom with
@@ -18,13 +40,32 @@ open Mechanic.GraphAlg
                 | true -> haveCycleAcc edgesRemain (acc + nodes)
                 | false -> true
             let haveCycle (nodes: list<int>) edges = nodes |> Seq.exists (fun v -> haveCycleAcc edges (set [v]))
-
-            let nodes = edges |> List.collect (fun (v,w) -> [v;w]) |> List.distinct
+
             match GraphAlg.topologicalOrder nodes edges with
             | TopologicalOrder order ->
                 Expect.equal (List.length order) (List.length nodes) "Number of nodes differs"
                 let orderPos = order |> List.mapi (fun i v -> v, i) |> Map.ofList
                 Expect.all edges (fun (v,w) -> orderPos.[v] < orderPos.[w]) "Ordering must respect oriented edge"
             | Cycle _ -> Expect.isTrue (haveCycle nodes edges) "Cycle reported on graph without cycle"
+
+        // this test is really slow for bigger sizes, because it check all permutations of given size
+        testPropertyWithConfig (Gen.addToConfig {FsCheckConfig.defaultConfig with maxTest = 100; endSize = 7}) "Topological order alg - min edit distance" <| fun (Gen.RandomGraph(nodes, edges)) ->
+            let edges = edges |> List.filter (fun (v,w) -> v <> w)
+            let variants = nodes |> List.allPermutations |> List.filter (correctOrder edges)
+            let editDistance order1 order2 =
+                let orderPos1 = order1 |> List.mapi (fun i v -> v, i) |> Map.ofList
+                let rec f i = function
+                    | [] -> 0
+                    | (x::xs) -> orderPos1.[x] - i + f (i+1) xs
+                f 0 order2
+            match variants with
+            | [] -> ()
+            | _ ->
+            let minOrder = variants |> List.minBy (editDistance nodes)
+            let minDistance = editDistance nodes minOrder
+            match GraphAlg.topologicalOrder nodes edges with
+            | TopologicalOrder order ->
+                Expect.equal (editDistance nodes order) minDistance (sprintf "Not minimal edit distance: original %A result %A min dist %A" nodes order minOrder)
+            | _ -> ()
     ]
 

src/Mechanic/GraphAlg.fs

@@ -5,26 +5,32 @@ type TopologicalOrderResult<'a> =
     | Cycle of 'a list
 
 let topologicalOrder orderedNodes edges =
-    //TODO: maintain original order of nodes
+    let orderPos = orderedNodes |> List.mapi (fun i v -> v, i) |> Map.ofList
     let nodes = orderedNodes |> set
     let nodeInLevel = edges |> Seq.groupBy snd |> Seq.map (fun (v, xs) -> v, Seq.length xs)
     let initZeroInLevelNodes = nodes - (nodeInLevel |> Seq.map fst |> set)
     let nodeInLevel = Seq.append nodeInLevel (initZeroInLevelNodes |> Seq.map (fun x -> x, 0)) |> Map.ofSeq
-    let rec solve edges nodeLevels acc =
+    let rec solve (nodeLevels, edges, acc) =
         let zeroInLevelNodes = nodeLevels |> Map.toSeq |> Seq.filter (fun (_, level) -> level = 0) |> Seq.map fst |> set
-        let nodeLevels = nodeLevels |> Map.filter (fun _ level -> level > 0)
-        let (edges, nodeLevels) =
-            let (edgesToRemove, remainEdges) = edges |> List.partition (fun (v,_) -> Set.contains v zeroInLevelNodes)
-            let nodeLevels = (nodeLevels, edgesToRemove) ||> Seq.fold (fun m (_,w) -> m |>Map.add w (m.[w]-1))
-            remainEdges, nodeLevels
-        let acc = acc @ (Set.toList zeroInLevelNodes)
         match edges, Set.count zeroInLevelNodes with
         | [], 0 -> TopologicalOrder acc
         | (_ :: _), 0 -> 
             //TODO: remove nodes not part of cycle
             Cycle (nodeLevels |> Map.toList |> List.map fst)
-        | _ -> solve edges nodeLevels acc
-    match solve edges nodeInLevel [] with
+        | _ -> 
+            let next = 
+                zeroInLevelNodes |> Seq.sortBy (fun n -> orderPos.[n]) |> Seq.map (fun n ->
+                    let (edges, nodeLevels) =
+                        let nodeLevels = nodeLevels |> Map.filter (fun v _ -> v <> n)
+                        let (edgesToRemove, remainEdges) = edges |> List.partition (fun (v,_) -> v = n)
+                        let nodeLevels = (nodeLevels, edgesToRemove) ||> Seq.fold (fun m (_,w) -> m |> Map.add w (m.[w]-1))
+                        remainEdges, nodeLevels
+                    let acc = acc @ [n]
+                    nodeLevels, edges, acc
+                ) |> Seq.tryHead
+            next |> Option.map solve |> Option.defaultValue (TopologicalOrder acc)
+
+    match solve (nodeInLevel, edges, []) with
     | TopologicalOrder result ->
         let islandNodes = nodes - (set result)
         TopologicalOrder (Set.toList islandNodes @ result)

src/Mechanic/Utils.fs

@@ -2,6 +2,15 @@ module Mechanic.Utils
 
 let tee f x = f x; x
 
+module List =
+    let rec internal distribute e = function
+      | [] -> [[e]]
+      | x::xs' as xs -> (e::xs)::[for xs in distribute e xs' -> x::xs]
+
+    let rec allPermutations = function
+      | [] -> [[]]
+      | e::xs -> List.collect (distribute e) (allPermutations xs)
+
 module Namespace =
     let splitByDot (s:string) = s.Split('.') |> Array.filter (System.String.IsNullOrEmpty >> not) |> Array.toList
     let joinByDot xs = String.concat "." xs