[ILouvain] another type: MetaGraph (with Tree of Contexts)

src/Data/Graph/Clustering/ILouvain.hs

@@ -56,10 +56,17 @@ type HyperContext' a b c = Context (HyperGraph a b) c
 type GraphContexts  a b = Gr [Context () a] b
 type GraphContexts'  a b c = Gr [Context [Context () a] b] c
 
+
+------------------------------------------------------------------------
+type MetaGraph a = Gr [TreeContext a] a
+data TreeContext a   = EmptyContext () | MetaContext [TreeContext a] a
+type MetaContext a b = Context a b
+------------------------------------------------------------------------
+
+
 -- TODO: EdgeGraph (StreamGraph)
 -- type StreamGraph  a b = Gr a (Gr () b)
 ------------------------------------------------------------------------
-
 -- TODO
 class IsHyperGraph gr where
   {-# MINIMAL mv_, toNodes_ #-}
@@ -129,7 +136,25 @@ instance IsHyperGraph (GraphContexts a a) where
   mv_ _ [_]   [_]  = panic "path too long"j
 
 
+
 instance IsHyperGraph (GraphContexts' a a a) where
+
+  fromGraph_ = undefined
+
+  isFlat_ :: GraphContexts' a a a -> Bool
+  isFlat_ g = all null
+            $ concat
+            $ map (map thd4)
+            $ map snd (labNodes g)
+
+  hnodes_ :: GraphContexts' a a a -> Node -> [Node]
+  hnodes_ g n = case (match n g) of
+    (Nothing        , _) -> []
+    (Just (_,n,cs,_), _) -> n : (map snd4 cs)
+
+  toNodes_ :: GraphContexts' a a a -> [[Node]]
+  toNodes_ g = map (hnodes_ g) (nodes g)
+
   mv_ :: Show (GraphContexts' a a a)
       => GraphContexts' a a a
       -> [Node] -> [Node]
@@ -140,7 +165,7 @@ instance IsHyperGraph (GraphContexts' a a a) where
 
   mv_ g [a]   [b] = case match a g of
     (Just (p,n,cs,s), g1) -> case match b g1 of
-      (Just (p',n',cs',s'), g2) -> (p',n', c:cs,s') & g2
+      (Just (p',n',cs',s'), g2) -> (p',n', c:cs',s') & g2
         where
           c = (p,n, concat $ map thd4 cs, s)
       (Nothing, _)  -> panic $ "mv: snd path does not exist: "  <> show b
@@ -148,8 +173,8 @@ instance IsHyperGraph (GraphContexts' a a a) where
 
   mv_ g [a,b] [ ] = case match a g of
     (Just (p,n,cs,s), g1) -> case match b (foldr (&) (empty :: GraphContexts a a) cs) of
-      (Just (p',n',cs',s'), g2) -> (p', n', map (\(p'',n'',c'',s'') -> (p'',n'',[(p'',n'',c'',s'')],s'')) cs', s') &
-                                   ((p, n, gsel (const True) g2, s) & g1)
+      (Just (p',n',cs',s'), g2) -> up & ((p, n, gsel (const True) g2, s) & g1)
+        where up = (p', n', map (\(p'',n'',c'',s'') -> (p'',n'',[(p'',n'',c'',s'')],s'')) cs', s')
       (Nothing, _) -> panic $ "mv: snd path does not exist: "  <> show b
     (Nothing,  _) -> panic $ "mv: fst path does not exist: "  <> show a
 
@@ -171,6 +196,8 @@ spoonS' = mkGraph ns es
          , (4, 5, 1.0)
          ]
 
+------------------------------------------------------------------------
+
 
 spoonS :: GraphContexts Double Double
 spoonS = mkGraph ns es
@@ -512,10 +539,9 @@ test_mv_mv g = (g0 == g', toNodes_ g')
   where
     g' = foldl' (\g (n1,n2) -> trace (prettify g) $ mv_ g n1 n2) g0 ns
     g0 = g
-    ns = [ ([2], [1])
-         , ([1,2], [])
-         , ([3], [1])
-         , ([1,3], [])
+    ns = [ ([2], [3])
+         , ([3], [4])
+         -- , ([4,3], [])
          , ([], [])
          ]