From 409875b3303fdce7733ed7510e018ba7e83959a6 Mon Sep 17 00:00:00 2001 From: jindraivanek Date: Wed, 10 Jan 2018 08:42:11 +0100 Subject: [PATCH 1/6] Experiments with Min Topological order --- src/Mechanic.Tests/Tests.fs | 23 +++++++++++++++++++++++ src/Mechanic/GraphAlg.fs | 5 ++++- src/Mechanic/Utils.fs | 9 +++++++++ 3 files changed, 36 insertions(+), 1 deletion(-) diff --git a/src/Mechanic.Tests/Tests.fs b/src/Mechanic.Tests/Tests.fs index 481e82d..585bb2e 100644 --- a/src/Mechanic.Tests/Tests.fs +++ b/src/Mechanic.Tests/Tests.fs @@ -3,6 +3,11 @@ module Tests.Main open Expecto open Mechanic open Mechanic.GraphAlg +open Mechanic.Utils + +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 [] let tests = @@ -26,5 +31,23 @@ open Mechanic.GraphAlg 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" + + ftestPropertyWithConfig (2035338253, 296398869) {FsCheckConfig.defaultConfig with maxTest = 1000; endSize = 100} "Topological order alg - min edit distance" <| fun (edges: list) -> + let edges = edges |> List.filter (fun (v,w) -> v <> w) + let nodes = edges |> List.collect (fun (v,w) -> [v;w]) |> List.distinct + 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 + order2 |> List.mapi (fun i v -> abs (i - orderPos1.[v])) |> List.sum + match variants with + | [] -> () + | _ -> + let minOrder = variants |> List.minBy (editDistance nodes) + let minDistance = editDistance nodes minOrder + match GraphAlg.topologicalOrder nodes edges, GraphAlg.topologicalOrder (nodes |> List.rev) (edges |> List.map (fun (v,w) -> w,v)) with + | TopologicalOrder order, TopologicalOrder orderRev -> + let order2 = orderRev |> List.rev + Expect.equal (min (editDistance nodes order) (editDistance nodes order2)) minDistance (sprintf "Not minimal edit distance %A %A %A" nodes order minOrder) + | _ -> () ] diff --git a/src/Mechanic/GraphAlg.fs b/src/Mechanic/GraphAlg.fs index c00612f..1e2b118 100644 --- a/src/Mechanic/GraphAlg.fs +++ b/src/Mechanic/GraphAlg.fs @@ -6,14 +6,17 @@ type TopologicalOrderResult<'a> = 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 zeroInLevelNodes = nodeLevels |> Map.toSeq |> Seq.filter (fun (_, level) -> level = 0) |> Seq.map fst |> set - let nodeLevels = nodeLevels |> Map.filter (fun _ level -> level > 0) + //let nodeLevels = nodeLevels |> Map.filter (fun _ level -> level > 0) + let zeroInLevelNodes = if Set.isEmpty zeroInLevelNodes then Set.empty else zeroInLevelNodes |> Seq.minBy (fun v -> orderPos.[v]) |> Set.singleton let (edges, nodeLevels) = + let nodeLevels = nodeLevels |> Map.filter (fun v _ -> Set.contains v zeroInLevelNodes |> not) 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 diff --git a/src/Mechanic/Utils.fs b/src/Mechanic/Utils.fs index 54a61a5..b5b7e9c 100644 --- a/src/Mechanic/Utils.fs +++ b/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 From 0689ebf229e14eb4773e95160996a32b497f4999 Mon Sep 17 00:00:00 2001 From: jindraivanek Date: Wed, 10 Jan 2018 18:35:28 +0100 Subject: [PATCH 2/6] Better graph generation. --- src/Mechanic.Tests/Tests.fs | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/src/Mechanic.Tests/Tests.fs b/src/Mechanic.Tests/Tests.fs index 585bb2e..78b91cd 100644 --- a/src/Mechanic.Tests/Tests.fs +++ b/src/Mechanic.Tests/Tests.fs @@ -5,6 +5,21 @@ open Mechanic open Mechanic.GraphAlg open Mechanic.Utils +module Gen = + open FsCheck + + type RandomGraph = RandomGraph of list + let genEdges = + Gen.sized (fun s -> + let nodeGen = [0..s] |> List.map Gen.constant |> Gen.oneof + Gen.map2 (fun x y -> x,y) nodeGen nodeGen |> Gen.listOfLength (s*s)) + |> Gen.map set |> Gen.map (Set.toList) + |> Arb.fromGen + |> Arb.convert RandomGraph (fun (RandomGraph l) -> l) + let addToConfig config = + {config with arbitrary = typeof.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 @@ -12,7 +27,7 @@ let correctOrder edges order = [] let tests = testList "GraphAlg" [ - testProperty "Topological order alg" <| fun (edges: list) -> + testPropertyWithConfig (Gen.addToConfig {FsCheckConfig.defaultConfig with maxTest = 1000; endSize = 100}) "Topological order alg" <| fun (Gen.RandomGraph edges) -> let rec haveCycleAcc edges acc = let (edgesFrom, edgesRemain) = edges |> List.partition (fun (v,_) -> Set.contains v acc) match edgesFrom with @@ -23,7 +38,7 @@ let correctOrder edges order = | true -> haveCycleAcc edgesRemain (acc + nodes) | false -> true let haveCycle (nodes: list) 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 -> @@ -32,7 +47,7 @@ let correctOrder edges order = 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" - ftestPropertyWithConfig (2035338253, 296398869) {FsCheckConfig.defaultConfig with maxTest = 1000; endSize = 100} "Topological order alg - min edit distance" <| fun (edges: list) -> + testPropertyWithConfig (Gen.addToConfig {FsCheckConfig.defaultConfig with maxTest = 100; endSize = 5}) "Topological order alg - min edit distance" <| fun (Gen.RandomGraph edges) -> let edges = edges |> List.filter (fun (v,w) -> v <> w) let nodes = edges |> List.collect (fun (v,w) -> [v;w]) |> List.distinct let variants = nodes |> List.allPermutations |> List.filter (correctOrder edges) From 03af17fd51afe82ca5f91d67f5a006e961860fba Mon Sep 17 00:00:00 2001 From: jindraivanek Date: Wed, 10 Jan 2018 18:50:16 +0100 Subject: [PATCH 3/6] Betteg graph generation --- src/Mechanic.Tests/Tests.fs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/src/Mechanic.Tests/Tests.fs b/src/Mechanic.Tests/Tests.fs index 78b91cd..f91a61c 100644 --- a/src/Mechanic.Tests/Tests.fs +++ b/src/Mechanic.Tests/Tests.fs @@ -8,12 +8,15 @@ open Mechanic.Utils module Gen = open FsCheck - type RandomGraph = RandomGraph of list + type RandomGraph = RandomGraph of (list * list) let genEdges = Gen.sized (fun s -> - let nodeGen = [0..s] |> List.map Gen.constant |> Gen.oneof - Gen.map2 (fun x y -> x,y) nodeGen nodeGen |> Gen.listOfLength (s*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 = @@ -27,7 +30,7 @@ let correctOrder edges order = [] let tests = testList "GraphAlg" [ - testPropertyWithConfig (Gen.addToConfig {FsCheckConfig.defaultConfig with maxTest = 1000; endSize = 100}) "Topological order alg" <| fun (Gen.RandomGraph edges) -> + testPropertyWithConfig (Gen.addToConfig {FsCheckConfig.defaultConfig with maxTest = 1000; endSize = 100}) "Topological order alg" <| 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 @@ -39,7 +42,6 @@ let correctOrder edges order = | false -> true let haveCycle (nodes: list) 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" @@ -47,9 +49,9 @@ let correctOrder edges order = 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" - testPropertyWithConfig (Gen.addToConfig {FsCheckConfig.defaultConfig with maxTest = 100; endSize = 5}) "Topological order alg - min edit distance" <| fun (Gen.RandomGraph edges) -> + testPropertyWithConfig (Gen.addToConfig {FsCheckConfig.defaultConfig with maxTest = 1000; endSize = 5}) "Topological order alg - min edit distance" <| fun (Gen.RandomGraph(nodes, edges)) -> + printfn "%A" (nodes, edges) let edges = edges |> List.filter (fun (v,w) -> v <> w) - let nodes = edges |> List.collect (fun (v,w) -> [v;w]) |> List.distinct 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 From 2111b8e1a1fd0c603d55449c15904f229dc23cb9 Mon Sep 17 00:00:00 2001 From: jindraivanek Date: Thu, 11 Jan 2018 08:48:14 +0100 Subject: [PATCH 4/6] min-cost path alg --- .paket/Paket.Restore.targets | 5 ++++ paket.dependencies | 1 + paket.lock | 4 ++- src/Mechanic.Tests/Tests.fs | 13 +++++---- src/Mechanic/GraphAlg.fs | 50 +++++++++++++++++++++++------------ src/Mechanic/paket.references | 3 ++- 6 files changed, 50 insertions(+), 26 deletions(-) diff --git a/.paket/Paket.Restore.targets b/.paket/Paket.Restore.targets index 7136773..a86be3a 100644 --- a/.paket/Paket.Restore.targets +++ b/.paket/Paket.Restore.targets @@ -18,6 +18,11 @@ $(PaketToolsPath)paket.exe "$(PaketExePath)" $(MonoPath) --runtime=v4.0.30319 "$(PaketExePath)" + + + <_PaketExeExtension>$([System.IO.Path]::GetExtension("$(PaketExePath)")) + dotnet "$(PaketExePath)" + $(PaketRootPath)paket.bootstrapper.exe $(PaketToolsPath)paket.bootstrapper.exe "$(PaketBootStrapperExePath)" diff --git a/paket.dependencies b/paket.dependencies index fd79357..60b61c9 100644 --- a/paket.dependencies +++ b/paket.dependencies @@ -2,6 +2,7 @@ source https://api.nuget.org/v3/index.json storage:none nuget FSharp.Compiler.Service +nuget FSharpx.Collections nuget Microsoft.NET.Test.Sdk nuget Expecto nuget Expecto.FsCheck diff --git a/paket.lock b/paket.lock index 829582b..4158d9f 100644 --- a/paket.lock +++ b/paket.lock @@ -37,7 +37,7 @@ NUGET System.Runtime.Loader (>= 4.0) - restriction: && (< net45) (>= netstandard1.6) System.Security.Cryptography.Algorithms (>= 4.3) - restriction: && (< net45) (>= netstandard1.6) System.ValueTuple (>= 4.4) - restriction: && (< net45) (>= netstandard1.6) - FSharp.Core (4.2.3) - restriction: || (>= net461) (>= netstandard1.6) + FSharp.Core (4.2.3) System.Collections (>= 4.0.11) - restriction: && (< net45) (>= netstandard1.6) System.Console (>= 4.0) - restriction: && (< net45) (>= netstandard1.6) System.Diagnostics.Debug (>= 4.0.11) - restriction: && (< net45) (>= netstandard1.6) @@ -61,6 +61,8 @@ NUGET System.Threading.Thread (>= 4.0) - restriction: && (< net45) (>= netstandard1.6) System.Threading.ThreadPool (>= 4.0.10) - restriction: && (< net45) (>= netstandard1.6) System.Threading.Timer (>= 4.0.1) - restriction: && (< net45) (>= netstandard1.6) + FSharpx.Collections (1.17) + FSharp.Core Microsoft.CodeCoverage (1.0.3) Microsoft.CSharp (4.4.1) - restriction: || (>= netcoreapp1.0) (>= uap10.0) NETStandard.Library (>= 1.6.1) - restriction: || (>= dnxcore50) (&& (< monoandroid) (< net45) (>= netstandard1.0) (< netstandard1.3) (< win8) (< wp8) (< wpa81)) (&& (< monotouch) (< net45) (>= netstandard1.3) (< netstandard2.0) (< win8) (< wpa81) (< xamarinios) (< xamarinmac) (< xamarintvos) (< xamarinwatchos)) diff --git a/src/Mechanic.Tests/Tests.fs b/src/Mechanic.Tests/Tests.fs index f91a61c..b779a9b 100644 --- a/src/Mechanic.Tests/Tests.fs +++ b/src/Mechanic.Tests/Tests.fs @@ -30,7 +30,8 @@ let correctOrder edges order = [] let tests = testList "GraphAlg" [ - testPropertyWithConfig (Gen.addToConfig {FsCheckConfig.defaultConfig with maxTest = 1000; endSize = 100}) "Topological order alg" <| fun (Gen.RandomGraph(nodes, edges)) -> + testPropertyWithConfig (Gen.addToConfig {FsCheckConfig.defaultConfig with maxTest = 100; endSize = 10}) "Topological order alg" <| fun (Gen.RandomGraph(nodes, edges)) -> + printfn "%A" (nodes,edges) let rec haveCycleAcc edges acc = let (edgesFrom, edgesRemain) = edges |> List.partition (fun (v,_) -> Set.contains v acc) match edgesFrom with @@ -49,8 +50,7 @@ let correctOrder edges order = 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" - testPropertyWithConfig (Gen.addToConfig {FsCheckConfig.defaultConfig with maxTest = 1000; endSize = 5}) "Topological order alg - min edit distance" <| fun (Gen.RandomGraph(nodes, edges)) -> - printfn "%A" (nodes, edges) + 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 = @@ -61,10 +61,9 @@ let correctOrder edges order = | _ -> let minOrder = variants |> List.minBy (editDistance nodes) let minDistance = editDistance nodes minOrder - match GraphAlg.topologicalOrder nodes edges, GraphAlg.topologicalOrder (nodes |> List.rev) (edges |> List.map (fun (v,w) -> w,v)) with - | TopologicalOrder order, TopologicalOrder orderRev -> - let order2 = orderRev |> List.rev - Expect.equal (min (editDistance nodes order) (editDistance nodes order2)) minDistance (sprintf "Not minimal edit distance %A %A %A" nodes order 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) | _ -> () ] diff --git a/src/Mechanic/GraphAlg.fs b/src/Mechanic/GraphAlg.fs index 1e2b118..d8c34ec 100644 --- a/src/Mechanic/GraphAlg.fs +++ b/src/Mechanic/GraphAlg.fs @@ -1,4 +1,5 @@ module Mechanic.GraphAlg +open FSharpx.Collections type TopologicalOrderResult<'a> = | TopologicalOrder of 'a list @@ -7,27 +8,42 @@ type TopologicalOrderResult<'a> = let topologicalOrder orderedNodes edges = //TODO: maintain original order of nodes let orderPos = orderedNodes |> List.mapi (fun i v -> v, i) |> Map.ofList + let heur nodeInLevels nodes edges = + let getLevel n = nodeInLevels |> Map.tryFind n |> Option.defaultValue 0 + let rec f visited n = + if Set.contains n visited then 0 + else getLevel n + (edges |> Seq.filter (fun (v,w) -> v<>w && w=n) |> Seq.sumBy (fst >> (f (Set.add n visited)))) + nodes |> Seq.mapi (fun i n -> max 0 (f Set.empty n - i)) |> Seq.sum 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 zeroInLevelNodes = nodeLevels |> Map.toSeq |> Seq.filter (fun (_, level) -> level = 0) |> Seq.map fst |> set - //let nodeLevels = nodeLevels |> Map.filter (fun _ level -> level > 0) - let zeroInLevelNodes = if Set.isEmpty zeroInLevelNodes then Set.empty else zeroInLevelNodes |> Seq.minBy (fun v -> orderPos.[v]) |> Set.singleton - let (edges, nodeLevels) = - let nodeLevels = nodeLevels |> Map.filter (fun v _ -> Set.contains v zeroInLevelNodes |> not) - 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 rec solve heap = + match PriorityQueue.tryPop heap with + | Some ((costH, cost, nodeLevels, edges, acc), rest) -> + let zeroInLevelNodes = nodeLevels |> Map.toSeq |> Seq.filter (fun (_, level) -> level = 0) |> Seq.map fst |> set + match edges, Set.count zeroInLevelNodes with + | [], 0 -> TopologicalOrder acc + | (_ :: _), 0 -> + //TODO: remove nodes not part of cycle + Cycle (nodeLevels |> Map.toList |> List.map fst) + | _ -> + let variants = + 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 h = heur nodeLevels (nodeLevels |> Map.keys |> Seq.sortBy (fun n -> orderPos.[n])) edges + let c = cost + abs (orderPos.[n] - List.length acc) + let acc = acc @ [n] + c+h, c, nodeLevels, edges, acc + ) |> List.ofSeq + solve ((rest, variants) ||> Seq.fold (fun h x -> PriorityQueue.insert x h)) + | None -> failwith "" + + match solve (PriorityQueue.empty false |> PriorityQueue.insert (0, 0, nodeInLevel, edges, [])) with | TopologicalOrder result -> let islandNodes = nodes - (set result) TopologicalOrder (Set.toList islandNodes @ result) diff --git a/src/Mechanic/paket.references b/src/Mechanic/paket.references index e4c76ae..66a531c 100644 --- a/src/Mechanic/paket.references +++ b/src/Mechanic/paket.references @@ -1,2 +1,3 @@ FSharp.Core -FSharp.Compiler.Service \ No newline at end of file +FSharp.Compiler.Service +FSharpx.Collections \ No newline at end of file From 5f8c988a10661da27fd26fbecf7f8d35693cad00 Mon Sep 17 00:00:00 2001 From: jindraivanek Date: Mon, 15 Jan 2018 08:26:01 +0100 Subject: [PATCH 5/6] Finally working alg :) --- paket.dependencies | 1 - paket.lock | 4 +-- src/Mechanic.Tests/Tests.fs | 10 ++++--- src/Mechanic/GraphAlg.fs | 53 +++++++++++++---------------------- src/Mechanic/paket.references | 3 +- 5 files changed, 28 insertions(+), 43 deletions(-) diff --git a/paket.dependencies b/paket.dependencies index 60b61c9..fd79357 100644 --- a/paket.dependencies +++ b/paket.dependencies @@ -2,7 +2,6 @@ source https://api.nuget.org/v3/index.json storage:none nuget FSharp.Compiler.Service -nuget FSharpx.Collections nuget Microsoft.NET.Test.Sdk nuget Expecto nuget Expecto.FsCheck diff --git a/paket.lock b/paket.lock index 4158d9f..829582b 100644 --- a/paket.lock +++ b/paket.lock @@ -37,7 +37,7 @@ NUGET System.Runtime.Loader (>= 4.0) - restriction: && (< net45) (>= netstandard1.6) System.Security.Cryptography.Algorithms (>= 4.3) - restriction: && (< net45) (>= netstandard1.6) System.ValueTuple (>= 4.4) - restriction: && (< net45) (>= netstandard1.6) - FSharp.Core (4.2.3) + FSharp.Core (4.2.3) - restriction: || (>= net461) (>= netstandard1.6) System.Collections (>= 4.0.11) - restriction: && (< net45) (>= netstandard1.6) System.Console (>= 4.0) - restriction: && (< net45) (>= netstandard1.6) System.Diagnostics.Debug (>= 4.0.11) - restriction: && (< net45) (>= netstandard1.6) @@ -61,8 +61,6 @@ NUGET System.Threading.Thread (>= 4.0) - restriction: && (< net45) (>= netstandard1.6) System.Threading.ThreadPool (>= 4.0.10) - restriction: && (< net45) (>= netstandard1.6) System.Threading.Timer (>= 4.0.1) - restriction: && (< net45) (>= netstandard1.6) - FSharpx.Collections (1.17) - FSharp.Core Microsoft.CodeCoverage (1.0.3) Microsoft.CSharp (4.4.1) - restriction: || (>= netcoreapp1.0) (>= uap10.0) NETStandard.Library (>= 1.6.1) - restriction: || (>= dnxcore50) (&& (< monoandroid) (< net45) (>= netstandard1.0) (< netstandard1.3) (< win8) (< wp8) (< wpa81)) (&& (< monotouch) (< net45) (>= netstandard1.3) (< netstandard2.0) (< win8) (< wpa81) (< xamarinios) (< xamarinmac) (< xamarintvos) (< xamarinwatchos)) diff --git a/src/Mechanic.Tests/Tests.fs b/src/Mechanic.Tests/Tests.fs index b779a9b..db75cc9 100644 --- a/src/Mechanic.Tests/Tests.fs +++ b/src/Mechanic.Tests/Tests.fs @@ -22,7 +22,6 @@ module Gen = let addToConfig config = {config with arbitrary = typeof.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 @@ -30,8 +29,7 @@ let correctOrder edges order = [] let tests = testList "GraphAlg" [ - testPropertyWithConfig (Gen.addToConfig {FsCheckConfig.defaultConfig with maxTest = 100; endSize = 10}) "Topological order alg" <| fun (Gen.RandomGraph(nodes, edges)) -> - printfn "%A" (nodes,edges) + 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 @@ -50,12 +48,16 @@ let correctOrder edges order = 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 - order2 |> List.mapi (fun i v -> abs (i - orderPos1.[v])) |> List.sum + let rec f i = function + | [] -> 0 + | (x::xs) -> orderPos1.[x] - i + f (i+1) xs + f 0 order2 match variants with | [] -> () | _ -> diff --git a/src/Mechanic/GraphAlg.fs b/src/Mechanic/GraphAlg.fs index d8c34ec..f36fc8d 100644 --- a/src/Mechanic/GraphAlg.fs +++ b/src/Mechanic/GraphAlg.fs @@ -1,49 +1,36 @@ module Mechanic.GraphAlg -open FSharpx.Collections type TopologicalOrderResult<'a> = | TopologicalOrder of 'a list | 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 heur nodeInLevels nodes edges = - let getLevel n = nodeInLevels |> Map.tryFind n |> Option.defaultValue 0 - let rec f visited n = - if Set.contains n visited then 0 - else getLevel n + (edges |> Seq.filter (fun (v,w) -> v<>w && w=n) |> Seq.sumBy (fst >> (f (Set.add n visited)))) - nodes |> Seq.mapi (fun i n -> max 0 (f Set.empty n - i)) |> Seq.sum 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 heap = - match PriorityQueue.tryPop heap with - | Some ((costH, cost, nodeLevels, edges, acc), rest) -> - let zeroInLevelNodes = nodeLevels |> Map.toSeq |> Seq.filter (fun (_, level) -> level = 0) |> Seq.map fst |> set - match edges, Set.count zeroInLevelNodes with - | [], 0 -> TopologicalOrder acc - | (_ :: _), 0 -> - //TODO: remove nodes not part of cycle - Cycle (nodeLevels |> Map.toList |> List.map fst) - | _ -> - let variants = - 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 h = heur nodeLevels (nodeLevels |> Map.keys |> Seq.sortBy (fun n -> orderPos.[n])) edges - let c = cost + abs (orderPos.[n] - List.length acc) - let acc = acc @ [n] - c+h, c, nodeLevels, edges, acc - ) |> List.ofSeq - solve ((rest, variants) ||> Seq.fold (fun h x -> PriorityQueue.insert x h)) - | None -> failwith "" + let rec solve (nodeLevels, edges, acc) = + let zeroInLevelNodes = nodeLevels |> Map.toSeq |> Seq.filter (fun (_, level) -> level = 0) |> Seq.map fst |> set + match edges, Set.count zeroInLevelNodes with + | [], 0 -> TopologicalOrder acc + | (_ :: _), 0 -> + //TODO: remove nodes not part of cycle + Cycle (nodeLevels |> Map.toList |> List.map fst) + | _ -> + 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 (PriorityQueue.empty false |> PriorityQueue.insert (0, 0, nodeInLevel, edges, [])) with + match solve (nodeInLevel, edges, []) with | TopologicalOrder result -> let islandNodes = nodes - (set result) TopologicalOrder (Set.toList islandNodes @ result) diff --git a/src/Mechanic/paket.references b/src/Mechanic/paket.references index 66a531c..e4c76ae 100644 --- a/src/Mechanic/paket.references +++ b/src/Mechanic/paket.references @@ -1,3 +1,2 @@ FSharp.Core -FSharp.Compiler.Service -FSharpx.Collections \ No newline at end of file +FSharp.Compiler.Service \ No newline at end of file From cf4fc3ae9b721af99434d4b0e9ac49e661a83d2c Mon Sep 17 00:00:00 2001 From: jindraivanek Date: Mon, 15 Jan 2018 18:12:52 +0100 Subject: [PATCH 6/6] Documentation --- OrderingAlg.md | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/OrderingAlg.md b/OrderingAlg.md index a4fac43..f3e4e53 100644 --- a/OrderingAlg.md +++ b/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. \ No newline at end of file