[ILouvain] mv_ for GraphContexts' a! (needs clean and tests and rest).

src/Data/Graph/Clustering/ILouvain.hs

@@ -54,6 +54,7 @@ type HyperGraph'   a b c = Gr (HyperGraph a b) c
 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
 
 -- TODO: EdgeGraph (StreamGraph)
 -- type StreamGraph  a b = Gr a (Gr () b)
@@ -61,6 +62,7 @@ type GraphContexts  a b = Gr [Context () a] b
 
 -- TODO
 class IsHyperGraph gr where
+  {-# MINIMAL mv_, toNodes_ #-}
   fromGraph_    :: Gr () a -> gr
 
   -- Flat is to HyperGraph what is empty to Graph
@@ -77,15 +79,14 @@ class IsHyperGraph gr where
   hnodes_       :: gr -> Node -> [Node]
   toNodes_      :: gr -> [[Node]]
 
-  mv_           :: (Show gr, Graph gr, DynGraph gr)
-                => gr -> [Node] -> [Node] -> gr
+  mv_           :: gr -> [Node] -> [Node] -> gr
   -- hdeg_         :: a -> Node -> Maybe Int
 
   imodularity_  :: gr -> gr -> [Node] -> Double
   gmodularity_  :: gr -> gr -> Double
 
   -- Minimal Graphs for tests
-  spoon_  :: gr
+  spoon_  :: a -> gr
   karate_ :: gr
   -- TODO Random graphs generation
 
@@ -104,25 +105,86 @@ instance IsHyperGraph (GraphContexts a a) where
   toNodes_ :: GraphContexts a a -> [[Node]]
   toNodes_ g = map (hnodes_ g) (nodes g)
 
-  mv_ :: ( Show     (GraphContexts a a)
-         , Graph    (GraphContexts a a)
-         , DynGraph (GraphContexts a a)
-         )
-      => GraphContexts a a
+  mv_ :: GraphContexts a a
       -> [Node] -> [Node]
       -> GraphContexts a a
-  mv_ g [ ]    [ ] = g
-  mv_ g [_]    [ ] = g
-  mv_ g [ ]    [_] = g
-  mv_ g [a,b] [ ]  = case match a g of
-    (Nothing,  _) -> panic $ "mv: fst path does not exist: " <> show a
-    (Just (p,n,cs,s), g1) -> case match b (foldr (&) empty cs) of
-      (Just c, g2)  -> c & ( (p, n, gsel (const True) g2, s) & g1)
-      (Nothing, _)               -> panic "mv: snd path does not exist"
-  mv_ g [a,b] [c]  = mv (mv g [a,b] []) [b] [c]
+  mv_ g [ ]   [ ] = g
+  mv_ g [_]   [ ] = g
+  mv_ g [ ]   [_] = g
+  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',[(p,n,(),s)] <> cs <> cs',s') & g2
+      (Nothing, _)  -> panic $ "mv: snd path does not exist: " -- <> show b
+    (Nothing,  _) -> panic $ "mv: fst path does not exist: " -- <> show a
+
+  mv_ g [a,b] [ ] = case match a g of
+    (Just (p,n,cs,s), g1) -> case match b (foldr (&) (empty :: Gr () a) cs) of
+      (Just (p',n',cs',s'), g2) -> (p, n, gsel (const True) g2, s) & g1
+      -- (Just c, g2) -> insNode (b,[c]) $ (p, n, gsel (const True) g2, s) & g1
+      (Nothing, _) -> panic $ "mv: snd path does not exist: " -- <> show b
+    (Nothing,  _)         -> panic $ "mv: fst path does not exist: " -- <> show a
+
+  mv_ g [a,b] [c]  = mv_ (mv_ g [a,b] []) [b] [c]
   mv_ _ [_]   [_]  = panic "path too long"j
 
 
+instance IsHyperGraph (GraphContexts' a a a) where
+  mv_ :: GraphContexts' a a a
+      -> [Node] -> [Node]
+      -> GraphContexts' a a a
+  mv_ g [ ]   [ ] = g
+  mv_ g [_]   [ ] = g
+  mv_ g [ ]   [_] = g
+
+  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
+        where
+          c = (p,n, concat $ map thd4 cs, s)
+      (Nothing, _)  -> panic $ "mv: snd path does not exist: " -- <> show b
+    (Nothing,  _) -> panic $ "mv: fst path does not exist: " -- <> show a
+
+  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)
+      (Nothing, _) -> panic $ "mv: snd path does not exist: " -- <> show b
+    (Nothing,  _)         -> panic $ "mv: fst path does not exist: " -- <> show a
+
+  mv_ g [a,b] [c]  = mv_ (mv_ g [a,b] []) [b] [c]
+  mv_ _ [_]   [_]  = panic "path too long"j
+
+
+spoonS' :: GraphContexts' Double Double Double
+spoonS' = mkGraph ns es
+  where
+    -- ns :: [LNode [Context [Context () Double]]]
+    ns = map (\n-> (n, [])) [1..6]
+
+    es :: [LEdge Double]
+    es = [ (1, 2, 1.0)
+         , (1, 3, 1.0)
+         , (2, 4, 1.0)
+         , (3, 4, 1.0)
+         , (4, 5, 1.0)
+         ]
+
+
+spoonS :: GraphContexts Double Double
+spoonS = mkGraph ns es
+  where
+    ns :: [LNode [Context () Double]]
+    ns = map (\n-> (n, [])) [1..6]
+
+    es :: [LEdge Double]
+    es = [ (1, 2, 1.0)
+         , (1, 3, 1.0)
+         , (2, 4, 1.0)
+         , (3, 4, 1.0)
+         , (4, 5, 1.0)
+         ]
+
+
 ------------------------------------------------------------------------
 type MaxIterations = Int
 type MaxSize       = Int
@@ -444,13 +506,15 @@ mvMContext _ _        = panic "mvMContext: Both  Nodes do   not exist"
 ------------------
 -- Test
 
-test_mv_mv = g0 == foldl' (\g (n1,n2) -> trace (prettify g) $ mv g n1 n2) g0 ns
+test_mv_mv g = (g0 == g', toNodes_ g')
   where
-    g0 = spoon
+    g' = foldl' (\g (n1,n2) -> trace (prettify g) $ mv_ g n1 n2) g0 ns
+    g0 = g
     ns = [ ([2], [1])
-         , ([3], [1])
          , ([1,2], [])
-         --, ([1,3], [])
+         , ([3], [1])
+         , ([1,3], [])
+         , ([], [])
          ]
 
 ------------------