[add back in files that got lost
John Meacham <john@repetae.net>**20050923161849] addfile ./Util/Graph.hs
addfile ./Util/SameShape.hs
addfile ./Util/HasSize.hs
hunk ./Util/Graph.hs 1
+-- | Data.Graph is sorely lacking in several ways, This just tries to fill in
+-- some holes and provide a more convinient interface
+
+module Util.Graph where
+
+import qualified Data.Graph
+import Data.Graph hiding(Graph)
+import GenUtil
+import Array
+import List(sort,sortBy,group,delete)
+
+
+data Graph n k = Graph Data.Graph.Graph (Vertex -> n) (k -> Maybe Vertex) (n -> k)
+
+instance Show n => Show (Graph n k) where
+    showsPrec n g = showsPrec n (Util.Graph.scc g)
+
+newGraph :: Ord k => [n] -> (n -> k) -> (n -> [k]) -> Graph n k
+newGraph ns fn fd = Graph ans lv' kv fn where
+    (ans,lv,kv) = graphFromEdges [ (n,fn n,snub $ fd n) | n <- ns ]
+    lv' x | (n,_,_) <- lv x = n
+
+fromScc (Left n) = [n]
+fromScc (Right n) = n
+
+-- | determine a set of loopbreakers subject to a fitness function
+-- loopbreakers have a minimum of their  incoming edges ignored.
+findLoopBreakers ::
+    (n -> Int)    -- ^ fitness function, greater numbers mean more likely to be a loopbreaker
+    -> Graph n k  -- ^ the graph
+    ->  ([n],[n]) -- ^ (loop breakers,dependency ordered nodes after loopbreaking)
+findLoopBreakers func (Graph g ln kv fn) = ans where
+    scc = Data.Graph.scc g
+    ans = f g scc [] [] where
+        f g (Node v []:sccs) fs lb
+            | v `elem` g ! v = let ng = (fmap (List.delete v) g) in  f ng (Data.Graph.scc ng) [] (v:lb)
+            | otherwise = f g sccs (v:fs) lb
+
+        f g (n:_) fs lb = f ng (Data.Graph.scc ng) [] (mv:lb) where
+            ((mv,_):_) = sortBy (\ a b -> compare (snd b) (snd a)) [ (v,func (ln v)) | v <- ns]
+            ns = dec n []
+            ng = fmap (List.delete mv) g
+
+        f _ [] xs lb = (map (ln . head) (group $ sort lb),reverse $ map ln xs)
+    dec (Node v ts) vs = v:foldr dec vs ts
+
+
+sccGroups :: Graph n k -> [[n]]
+sccGroups g = map fromScc (Util.Graph.scc g)
+
+scc :: Graph n k -> [Either n [n]]
+scc (Graph g ln kv fn) = map decode forest where
+    forest = Data.Graph.scc g
+    decode (Node v [])
+        | v `elem` g ! v = Right [ln v]
+        | otherwise = Left (ln v)
+    decode other = Right (dec other [])
+    dec (Node v ts) vs = ln v:foldr dec vs ts
+
+
+reachable :: Graph n k -> [k] -> [n]
+reachable (Graph g ln kv _) ns = map ln $ snub $  concatMap (Data.Graph.reachable g) gs where
+    gs = [ v | Just v <- map kv ns]
+
+topSort :: Graph n k -> [n]
+topSort (Graph g ln _ _) = map ln $ Data.Graph.topSort g
+
+cyclicNodes :: Graph n k -> [n]
+cyclicNodes g = concat [ xs | Right xs <- Util.Graph.scc g]
+
hunk ./Util/HasSize.hs 1
+module Util.HasSize where
+
+-- this point of this module is not only to share the 'size' syntax, but to
+-- provide optimally lazy versions of size comparasin functions when dealing
+-- with lazy structures. This is especially useful when having to compare the
+-- size of possibly long lists.
+
+-- it is up to each instance to decide what 'size' means
+
+import qualified Data.Map(Map,size)
+import qualified Data.Set(Set,size)
+import qualified Data.IntMap(IntMap,size)
+import qualified Data.IntSet(IntSet,size)
+
+
+class HasSize a where
+    size :: a -> Int
+    sizeEQ :: Int -> a -> Bool
+    sizeGT :: Int -> a -> Bool
+    sizeLT :: Int -> a -> Bool
+    sizeGTE :: Int -> a -> Bool
+    sizeLTE :: Int -> a -> Bool
+    sizeEQ s x = size x == s
+    sizeGT s x = size x > s
+    sizeLT s x = size x < s
+    sizeGTE s x = not $ sizeLT s x
+    sizeLTE s x = not $ sizeGT s x
+
+genSize :: (Integral b,HasSize a) => a -> b
+genSize = fromIntegral . Util.HasSize.size
+
+instance HasSize [x] where
+    size = length
+    sizeEQ n _ | n < 0 = False
+    sizeEQ n xs = f n xs where
+        f 0 [] = True
+        f _ [] = False
+        f 0 _ = False
+        f n (_:xs) = sizeEQ (n - 1) xs
+    sizeGT n _ | n < 0 = True
+    sizeGT n xs = f n xs where
+        f 0 (_:_) = True
+        f n [] = False
+        f n (_:xs) = f (n - 1) xs
+    sizeLT n _ | n <= 0 = False
+    sizeLT n xs = f n xs where
+        f 0 _ = False
+        f _ [] = True
+        f n (_:xs) = f (n - 1) xs
+
+
+
+instance HasSize (Data.Map.Map a b) where
+    size = Data.Map.size
+
+
+instance HasSize (Data.Set.Set a) where
+    size = Data.Set.size
+
+instance HasSize (Data.IntMap.IntMap v) where
+    size = Data.IntMap.size
+instance HasSize Data.IntSet.IntSet where
+    size = Data.IntSet.size
+
+instance (HasSize a,HasSize b) => HasSize (Either a b) where
+    size (Left x) = size x
+    size (Right y) = size y
+    sizeEQ s (Left x)  = sizeEQ s x
+    sizeEQ s (Right x)  = sizeEQ s x
+    sizeLT s (Left x)  = sizeLT s x
+    sizeLT s (Right x)  = sizeLT s x
+    sizeGT s (Left x)  = sizeGT s x
+    sizeGT s (Right x)  = sizeGT s x
+
+instance (HasSize a,HasSize b) => HasSize (a,b) where
+    size (x,y) = size x + size y
+
+instance (HasSize a,HasSize b,HasSize c) => HasSize (a,b,c) where
+    size (x,y,z) = size x + size y  + size z
+
hunk ./Util/SameShape.hs 1
+module Util.SameShape where
+
+import Data.Tree
+
+
+
+--class SameShape a b where
+--    sameShape :: a -> b -> Bool
+
+--instance (SameShape1 f) => SameShape (f a) (f b) where
+--    sameShape x y = sameShape1 x y
+--instance (SameShape2 f) => SameShape (f a b) (f c d) where
+--    sameShape x y = sameShape2 x y
+
+class SameShape1 f where
+    sameShape1 :: f a -> f b -> Bool
+class SameShape2 f where
+    sameShape2 :: f a b -> f c d -> Bool
+
+
+instance SameShape1 [] where
+    sameShape1 [] [] = True
+    sameShape1 (_:xs) (_:ys) = sameShape1 xs ys
+    sameShape1 _ _ = False
+
+instance SameShape1 Tree where
+    sameShape1 (Node _ xs) (Node _ ys) = f xs ys where
+        f [] [] = True
+        f (x:xs) (y:ys) = sameShape1 x y && f xs ys
+        f _ _ = False
+
+instance SameShape1 Maybe where
+    sameShape1 (Just _) (Just _) = True
+    sameShape1 Nothing Nothing = True
+    sameShape1 _ _ = False
+
+instance SameShape2 Either where
+    sameShape2 (Left _) (Left _) = True
+    sameShape2 (Right _) (Right _) = True
+    sameShape2 _ _ = False
+
+instance SameShape1 IO where
+    sameShape1 _ _ = True
+
+