From 1145aefdbb37667ff05488314a26b3d2eefa0c8b Mon Sep 17 00:00:00 2001
From: bjorn <bjorn@bringert.net>
Date: Thu, 27 Nov 2008 10:29:29 +0000
Subject: More efficient implementation of topological sort.

Profiling the compilation of the OALD lexicon showed that 90-95% of the time was spent in topoSort. The old implementation was quadratic. Replaced this with O(E + V) implementation, in GF.Data.Relation. This gave a 10x speed-up (~ 25 sec instead of ~270 sec) for compiling ParseEng and OaldEng.
---
 src/GF/Data/Operations.hs | 35 ++++-------------------------------
 1 file changed, 4 insertions(+), 31 deletions(-)

(limited to 'src/GF/Data/Operations.hs')

diff --git a/src/GF/Data/Operations.hs b/src/GF/Data/Operations.hs
index 9bcae5c6a..377ac736f 100644
--- a/src/GF/Data/Operations.hs
+++ b/src/GF/Data/Operations.hs
@@ -56,7 +56,7 @@ module GF.Data.Operations (-- * misc functions
 		   sortByLongest, combinations, mkTextFile, initFilePath,
 
 		   -- * topological sorting with test of cyclicity
-		   topoTest, topoSort, cyclesIn,
+		   topoTest, 
 
 		   -- * the generic fix point iterator
 		   iterFix,
@@ -82,6 +82,7 @@ import Data.Map (Map)
 import Control.Monad (liftM,liftM2, MonadPlus, mzero, mplus)
 
 import GF.Data.ErrM
+import GF.Data.Relation
 
 infixr 5 +++
 infixr 5 ++-
@@ -477,36 +478,8 @@ initFilePath :: FilePath -> FilePath
 initFilePath f = reverse (dropWhile (/='/') (reverse f))
 
 -- | topological sorting with test of cyclicity
-topoTest :: Eq a => [(a,[a])] -> Either [a] [[a]]
-topoTest g = if length g' == length g then Left g' else Right (cyclesIn g ++[[]]) 
-  where
-    g' = topoSort g
-  
-cyclesIn :: Eq a => [(a,[a])] -> [[a]]
-cyclesIn deps = nubb $ clean $ filt $ iterFix findDep immediate where
-  immediate = [[y,x] | (x,xs) <- deps, y <- xs] 
-  findDep chains = [y:x:chain | 
-                      x:chain <- chains, (x',xs) <- deps, x' == x, y <- xs, 
-                      notElem y (init chain)]
-
-  clean = map remdup
-  nubb = nubBy (\x y -> y == reverse x) 
-  filt = filter (\xs -> last xs == head xs)
-  remdup (x:xs) = x : remdup xs' where xs' = dropWhile (==x) xs
-  remdup [] = []
-
-
--- | topological sorting 
-topoSort :: Eq a => [(a,[a])] -> [a]
-topoSort g = reverse $ tsort 0 [ffs | ffs@(f,_) <- g, inDeg f == 0] [] where
-  tsort _ []     r = r
-  tsort k (ffs@(f,fs) : cs) r
-    | elem f r  = tsort k cs r
-    | k > lx    = r  
-    | otherwise = tsort (k+1) cs (f : tsort (k+1) (info fs) r)
-  info hs = [(f,fs) | (f,fs) <- g, elem f hs]
-  inDeg f = length [t | (h,hs) <- g, t <- hs, t == f]
-  lx = length g
+topoTest :: Ord a => [(a,[a])] -> Either [a] [[a]]
+topoTest = topologicalSort . mkRel'
 
 -- | the generic fix point iterator
 iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a]
-- 
cgit v1.2.3