[ILouvain] mvContext of HyperGraph' to fix only.

src/Data/Graph/Clustering/ILouvain.hs

@@ -9,9 +9,6 @@ Portability : POSIX
 
 ILouvain: inductive Graph clustering with destructives updates
 
-metagraph (plural metagraphs) (mathematics) A representation of a set of nodes and the morphisms relating them
-https://en.wiktionary.org/wiki/metagraph
-
 TODO FGL improvements:
 - deg   :: Graph gr => gr a b -> Node -> Maybe Int
 - match :: Graph gr => Node -> gr a b -> Maybe (Context, Graph)
@@ -34,15 +31,24 @@ data NodePath = AllNodes | DfsNodes
 
 ------------------------------------------------------------------------
 -- data MetaGraph = LabGraph (HyperGraph) | EdgeGraph (StreamGraph)
+-- Metagraph (plural metagraphs) (mathematics) A representation
+-- of a set of nodes and the morphisms relating them
+-- https://en.wiktionary.org/wiki/metagraph
 -- MetaGraph (x,y) where x is space (hyper structure of labels), y is
 -- time like (stream structure)
 -- (Below LabGraph definition)
-type HyperGraph'   a b c = Gr (HyperGraph a b) c
-type HyperContext' a b c = Context (HyperGraph a b) c
 
+-- | Why do we need more depth in the HyperGraph ?
+-- BUG to fix:
+-- toNodes $ mv (mv (mv spoon [1] [2]) [2] [3]) [3,1] []
+-- == [[1,2],[3,2],[4],[5],[6]]
+-- (Node 2 is in 2 different clusters)
 type HyperGraph    a b   = Gr (Gr () a) b
 type HyperContext  a b   = Context (Gr () a) b
 
+type HyperGraph'   a b c = Gr (HyperGraph a b) c
+type HyperContext' a b c = Context (HyperGraph a b) c
+
 -- TODO: EdgeGraph (StreamGraph)
 -- type StreamGraph  a b = Gr a (Gr () b)
 ------------------------------------------------------------------------
@@ -76,7 +82,7 @@ iLouvainH :: (Eq a, Show a)
 iLouvainH 0 s p g = g
 iLouvainH n s p g
   | length (toNodes' g') <= s = g'
-  | otherwise                = iLouvainH' p g g'
+  | otherwise                 = iLouvainH' p g g'
     where
       g' = iLouvainH (n-1) s p g
 ------------------------------------------------------------------------
@@ -110,7 +116,6 @@ iLouvainH' p g g' =   -- trace (show ps :: Text)
                      DfsNodes -> path' g
               else sortOn (length . hnodes' g') (nodes g')
 
-
 ------------------------------------------------------------------------
 iLouvain'' :: Show a
            => HyperGraph a a
@@ -129,8 +134,6 @@ iLouvainH'' :: Show a
 iLouvainH'' g g' ns  = foldl' (\g1 n -> trace (show (n, toNodes' g1) :: Text) 
                              $ stepMax' g g1 n
                              $ neighborhood' g g1 n ) g' ns
-
-
 ------------------------------------------------------------------------
 -- | Neighborhood definition
 -- TODO optim sort by jackard
@@ -163,7 +166,7 @@ hood' g g' n = H.exclusion (fromList ns) candidates
     ns         = hnodes' g' n
 
 ------------------------------------------------------------------------
--- | Here we need more depth in the HyperGraph => HyperGraph'
+
 stepMax :: Show a
      => HyperGraph a b
      -> HyperGraph a a
@@ -178,7 +181,6 @@ stepMax g g' x xs =
                                           else mv g'' [p,x] [n]
                                           ) g'
                    $ zip (x:xs) xs
-
 -------------------------------------------------------------------------
 stepMax' :: Show a
      => Start a
@@ -195,9 +197,8 @@ stepMax' g g' x xs =
                                           ) g'
                    $ zip (x:xs) xs
 
-
-
 ------------------------------------------------------------------------
+-- TODO
 class IsHyperGraph gr where
   toHyperGraph_ :: Gr () a -> gr a a
   -- flat is to HyperGraph what is empty to Graph
@@ -213,7 +214,6 @@ class IsHyperGraph gr where
   -- hdeg_         :: a -> Node -> Maybe Int
 
 ------------------------------------------------------------------------
-
 {-
 instance IsHyperGraph HyperGraph
   where
@@ -231,9 +231,7 @@ instance IsHyperGraph HyperGraph
 
     mv_ = mv
 -}
-
 ------------------------------------------------------------------------
-
 hnodes :: HyperGraph a b -> Node -> [Node]
 hnodes g n = case match n g of
   (Nothing          , _) -> []
@@ -355,6 +353,18 @@ mvH :: Show a
 mvH g [ ] [ ] = g
 mvH g [_] [ ] = g
 mvH g [ ] [_] = g
+mvH g [a] [b] = case a == b of
+  True  -> panic "mv, impossible: from node == dest node"
+  False -> mvH' g a b
+mvH g [a,b] [ ] = case match a g of
+  (Nothing,  _) -> panic $ "mv: fst path does not exist: " <> show a
+  (Just (p, n, l, s), g1) -> case match b l of
+    (Just (p',n',l',s'), g2)  -> (p', n', g2, s')
+                               & ((p , n , delNode b l , s )
+                               & g1)
+    (Nothing, _) -> panic "mv: snd path does not exist"
+mvH g [a,b] [c] = mvH (mvH g [a,b] []) [b] [c]
+mvH g _ _  = panic "mv:todo long path"
 
 
 
@@ -389,6 +399,16 @@ mv' g n1 n2 = -- trace (show (c1,c2) :: Text) $
       (c1, g1) = match n1 g
       (c2, g2) = match n2 g1
 
+mvH' :: Show a => HyperGraph' a a a
+    -> Node -> Node
+    -> HyperGraph' a a a
+mvH' g n1 n2 = -- trace (show (c1,c2) :: Text) $
+  (mvMContext' c1 c2) & g2
+    where
+      (c1, g1) = match n1 g
+      (c2, g2) = match n2 g1
+
+
 mvMContext :: Maybe (HyperContext a a)
            -> Maybe (HyperContext a a)
            -> HyperContext a a
@@ -400,18 +420,18 @@ mvMContext _ (Just _) = panic "mvMContext: First Node  does not exist"
 mvMContext (Just _) _ = panic "mvMContext: Snd   Node  does not exist"
 mvMContext _ _        = panic "mvMContext: Both  Nodes do   not exist"
 
-{-
+--{-
 mvMContext' :: Maybe (HyperContext' a a a)
             -> Maybe (HyperContext' a a a)
             -> HyperContext' a a a
 mvMContext' (Just (a1 ,n ,l ,a2 ))
-            (Just (a1',n',l',a2')) = (a1',n', (c & l'),a2')
+            (Just (a1',n',l',a2')) = (a1',n', merge l' (c & l), a2')
             where
-              c = (a1, n, labNodes l, a2)
+              c = (a1, n, empty, a2)
 mvMContext' _ (Just _) = panic "mvMContext': First Node  does not exist"
 mvMContext' (Just _) _ = panic "mvMContext': Snd   Node  does not exist"
 mvMContext' _ _        = panic "mvMContext': Both  Nodes do   not exist"
--}
+--}
 
 ------------------------------------------------------------------------
 test_mv :: (Ord a, Show a) => HyperGraph a a -> Node -> Node -> Bool