additional types + computing weights from scratch

hgeometry/hgeometry.cabal

@@ -452,6 +452,7 @@ library
         HGeometry.Plane.LowerEnvelope.Connected.BruteForce
 
         HGeometry.Plane.LowerEnvelope.Connected.Separator.Util
+        HGeometry.Plane.LowerEnvelope.Connected.Separator.Type
 
         HGeometry.Plane.LowerEnvelope.DivideAndConquer
         HGeometry.Plane.LowerEnvelope.EpsApproximation

hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Separator.hs

@@ -10,7 +10,7 @@
 --
 --------------------------------------------------------------------------------
 module HGeometry.Plane.LowerEnvelope.Connected.Separator
-  ( Separator
+  ( Separator(..)
   , planarSeparator
 
   , bff
@@ -33,6 +33,7 @@ import qualified Data.Set as Set
 import           Data.Tree
 import           HGeometry.Plane.LowerEnvelope.Connected.Graph
 import           HGeometry.Plane.LowerEnvelope.Connected.Separator.Util
+import           HGeometry.Plane.LowerEnvelope.Connected.Separator.Type
 import           HGeometry.Plane.LowerEnvelope.Connected.Split
 import           HGeometry.Vector
 
@@ -96,7 +97,6 @@ sqrt' = floor . sqrt . fromIntegral
 --                    => planarGraph
 --                    -> ([VertexIx planarGraph], Vector 2 [VertexIx planarGraph])
 
-type Separator k = ([k],Vector 2 [k])
 type Size = Int
 
 -- | Computes the connected components; for each component we report a BFS tree. The trees
@@ -115,9 +115,9 @@ connectedComponents = List.sortOn (Down . snd) . map (\t -> (t, length t)) . bff
 -- 3) the vertex sets of A and B have weight at most 2/3 the total weight
 planarSeparator    :: ( Ord k
                       , Show k
-                      ) => PlaneGraph k v e -> Separator k
+                      ) => PlaneGraph k v e -> Separator [k]
 planarSeparator gr = case trees of
-    []                 -> ([],Vector2 [] [])
+    []                 -> mempty
     ((tr,m):rest)
       | m <= twoThirds -> traceShow (tr,m,n,twoThirds) $ groupComponents
       | otherwise      -> planarSeparator' (traceShowWith ("tree",) tr) m -- FIXME: we should also add the remaining vertices
@@ -130,7 +130,7 @@ planarSeparator gr = case trees of
     groupComponents = undefined
 
     planarSeparator' tr _ = case List.break (\lvl -> accumSize lvl < half) lvls of
-        (_,    [])          -> ([], Vector2 (F.toList tr) [])
+        (_,    [])          -> Separator [] (F.toList tr) []
                                  -- somehow we have too little weight;
         (pref, (l1 : suff)) -> planarSeparatorTree twoThirds gr tr'
           where

hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Separator/Cycle.hs

@@ -15,14 +15,15 @@ module HGeometry.Plane.LowerEnvelope.Connected.Separator.Cycle
   , toCycle
   , splitTree
   , missingEdge
+  , toSeparator
 
   , annotateCycle
   , makeInsideHeaviest
 
   , splitCycleAt
 
   , CycleSplitPaths(..)
-  , collectPaths
+  , collectPathsWith
   , collectAll
   , cycleSplitPathWeights
   , endPoints
@@ -45,6 +46,7 @@ import           Data.Tree (Tree(..))
 import           HGeometry.Plane.LowerEnvelope.Connected.Separator.InitialSplit
 import           HGeometry.Plane.LowerEnvelope.Connected.Separator.Path
 import           HGeometry.Plane.LowerEnvelope.Connected.Separator.Weight
+import           HGeometry.Plane.LowerEnvelope.Connected.Separator.Type
 import           HGeometry.Vector
 
 import           Debug.Trace
@@ -76,7 +78,12 @@ collectAll                        :: Cycle' a -> [a]
 collectAll (Cycle paths bs ms as) = collectAllPaths paths <> flatten (bs <> ms <> as)
 
 
-
+-- | Turn the cycle into an actual separator.
+toSeparator                                  :: Cycle' a -> Separator [a]
+toSeparator (Cycle paths before middle after) =
+    (toList' <$> Separator [] middle (before <> after)) <> collectPathsWith (:[]) paths
+  where
+    toList' = foldMap F.toList
 
 ----------------------------------------
 
@@ -105,27 +112,29 @@ instance Bifoldable CycleSplitPaths where
                                in f r <> h lPath <> h rPath
 
 
-collectAllPaths       :: CycleSplitPaths a [Tree a] -> [a]
-collectAllPaths paths = let (sep,Vector2 inside outside) = collectPaths undefined paths
-                        in sep <> inside <> outside
+
+-- | Collects all a's
+collectAllPaths :: CycleSplitPaths a [Tree a] -> [a]
+collectAllPaths = F.fold . collectPathsWith (:[])
 
 -- | Collects the paths into a (partial) separator
-collectPaths                :: (a -> [Tree a] -> Maybe (Vector 2 [Tree a]))
-                            -> CycleSplitPaths a [Tree a] -> ([a], Vector 2 [a])
-collectPaths splitChildren = \case
-  RootSplit rs            -> collectRootSplitPath splitChildren rs
-  PathSplit r lPath rPath -> let NodeSplit sepL before  middleL = collectPath lPath
-                                 NodeSplit sepR middleR after   = collectPath rPath
-                             in ( r : sepL <> sepR
-                                , Vector2 (middleL <> middleR) (before <> after)
-                                )
--- TODO: I don't think I need the splitChildren here!
+collectPathsWith   :: Monoid w => (a -> w) -> CycleSplitPaths a [Tree a] -> Separator w
+collectPathsWith f = \case
+  RootSplit rs            -> collectRootSplitPathWith f rs
+  PathSplit r lPath rPath -> let NodeSplit sepL before  middleL = collectPathWith f lPath
+                                 NodeSplit sepR middleR after   = collectPathWith f rPath
+                             in Separator (f r <> sepL <> sepR)
+                                          (middleL <> middleR) (before <> after)
 
 -- | Computes the weights of the
-cycleSplitPathWeights :: (Num w, IsWeight w) => CycleSplitPaths a [Tree (Weighted w b)]-> w
+cycleSplitPathWeights :: CycleSplitPaths a [Tree a]-> Weight
 cycleSplitPathWeights = \case
   RootSplit rs            -> rootSplitWeight rs
-  PathSplit _ lPath rPath -> pathWeight L lPath + pathWeight R rPath
+  PathSplit _ lPath rPath -> pathWeightOn L lPath + pathWeightOn R rPath
+
+
+
+
 
 
 -- | The labels of the leaves at which the cyclesplit paths end. If one is a root
@@ -175,39 +184,18 @@ instance Bifoldable RootSplitPath where
 type RootPath a = a
 
 -- | computes the weight of the paths hanging off a rootSplit
-rootSplitWeight :: (IsWeight w, Num w) => RootSplitPath a [Tree (Weighted w b)] -> w
+rootSplitWeight :: RootSplitPath a [Tree a] -> Weight
 rootSplitWeight = \case
-  RootBefore _ rPath -> pathWeight L rPath
-  RootAfter lPath _  -> pathWeight R lPath
+  RootBefore _ rPath -> pathWeightOn L rPath
+  RootAfter lPath _  -> pathWeightOn R lPath
 
 -- | Collect on a rootsplitPath
-collectRootSplitPath                :: (a -> [Tree a] -> Maybe (Vector 2 [Tree a]))
-                                    -> RootSplitPath a [Tree a] -> ([a], Vector 2 [a])
-collectRootSplitPath _ = \case
-    RootBefore r     rPath -> let NodeSplit sep inside outside = collectPath rPath
-                              in (r:sep, Vector2 inside outside)
-    RootAfter  lPath r     -> let NodeSplit sep outside inside = collectPath lPath
-                              in (r:sep, Vector2 inside outside)
-
-
--- -- | Collect on a rootsplitPath
--- collectRootSplitPath                :: (a -> [Tree a] -> Maybe (Vector 2 [Tree a]))
---                                     -> RootSplitPath a [Tree a] -> ([a], Vector 2 [a])
--- collectRootSplitPath splitChildren = fromMaybe err . \case
---     RootBefore r path -> let (NodeSplit sep inside outside, before, after) = splitPath path in
---       splitChildren r before <&> \(Vector2 before' middle) ->
---           (r:sep, Vector2 (flatten middle <> inside) (flatten (before' <> after) <> outside))
-
---     RootAfter path r  -> let (NodeSplit sep outside inside, before, after) = splitPath path in
---       splitChildren r after <&> \(Vector2 middle after') ->
---           (r:sep, Vector2 (flatten middle <> inside) (flatten (before <> after') <> outside))
---   where
---     err = error "collectRootSplitPath: not found!?"
---
-
---     splitPath = \case
---       Leaf (NodeSplit _ before after)         -> (mempty,           before,after)
---       Path (NodeSplit (_,path') before after) -> (collectPath path', before, after)
+collectRootSplitPathWith   :: Monoid w => (a -> w) -> RootSplitPath a [Tree a] -> Separator w
+collectRootSplitPathWith f = \case
+    RootBefore r     rPath -> let NodeSplit sep inside outside = collectPathWith f rPath
+                              in Separator (f r <> sep) inside outside
+    RootAfter  lPath r     -> let NodeSplit sep outside inside = collectPathWith f lPath
+                              in Separator (f r <> sep) inside outside
 
 flatten :: [Tree a] -> [a]
 flatten = foldMap F.toList
@@ -266,14 +254,12 @@ splitTree splitLeaf splitChildren e = toCycle splitLeaf splitChildren . initialS
 type Weight = Int
 type Weighted' = Weighted Weight
 
-
 -- | Annotates a cycle with the subtree weights.
-annotateCycle :: Cycle a [Tree a] -> Cycle (Weighted Int a) [Tree (Weighted Int a)]
+annotateCycle :: Cycle a [Tree a] -> Cycle (Weighted Weight a) [Tree (Weighted Weight a)]
 annotateCycle = bimap (Weighted 1) (fmap annotate)
 
 -- | Makes sure that the inside of the cycle is heaviest.
-makeInsideHeaviest                                         :: Cycle' (Weighted' a)
-                                                           -> Cycle' (Weighted' a)
+makeInsideHeaviest                                         :: Cycle' a -> Cycle' a
 makeInsideHeaviest split@(Cycle paths before inside after)
   | weightOf inside < weightOf before + weightOf after =
       Cycle (shift paths) [] (after <> before) inside
@@ -438,8 +424,7 @@ splitCycleAtPath :: forall a. (Show a, Ord a) =>
                  -> (a -> Bool)
                  -> Cycle' a
                  -> Maybe (Vector 2 (Cycle' a))
-splitCycleAtPath splitLeaf splitChildren p old@(Cycle paths before middle after) =
-    -- verify "PATH" old $
+splitCycleAtPath splitLeaf splitChildren p (Cycle paths before middle after) =
     fmap toCycle' <$> (splitLeftPath <|> splitRightPath)
   where
     toCycle' = toCycle splitLeaf splitChildren

hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Separator/Path.hs

@@ -24,15 +24,16 @@ module HGeometry.Plane.LowerEnvelope.Connected.Separator.Path
   , pathElementsTree, pathElementsNS
 
   , pathToTree, pathToTree', pathToList
-  , collectPath
+  , collectPathWith,  pathValues, pathWeight
   , endPoint
 
   , findNode
   , findNode'
 
 
   , Side(..)
-  , pathWeight
+  , nodeSplitWeightOn
+  , pathWeightOn
   ) where
 
 import           Control.Lens ((<&>))
@@ -68,11 +69,34 @@ instance (Monoid a, Monoid trees) => Monoid (NodeSplit a trees) where
 splitRootLabel                   :: NodeSplit a trees -> a
 splitRootLabel (NodeSplit x _ _) = x
 
--- | Computes the weight of a ndoesplit
-nodeSplitWeight :: (Num w, IsWeight w) => Side -> NodeSplit a [Tree (Weighted w b)] -> w
-nodeSplitWeight s (NodeSplit _ before after) = case s of
-                                                 L -> weightOf before
-                                                 R -> weightOf after
+-- | Computes the weight of a nodesplit on a particular side.
+nodeSplitWeightOn      :: (Num w, IsWeight w) => Side -> NodeSplit a [Tree a] -> w
+nodeSplitWeightOn s ns = let NodeSplit _ before after = nodeSplitWeight ns
+                         in case s of
+                              L -> before
+                              R -> after
+
+-- | Collects the weights
+nodeSplitWeight :: (Functor f, Foldable f, Foldable tree, Functor tree, IsWeight w, Num w)
+                => NodeSplit a (f (tree a)) -> NodeSplit w w
+nodeSplitWeight = bimap getWeight getWeight . collectWithWeight
+
+-- | Collects all values
+nodeSplitValues :: (Functor f, Foldable f, Foldable tree, Functor tree)
+                => NodeSplit a (f (tree a)) -> NodeSplit [a] [a]
+nodeSplitValues = collectNodeSplitWith (:[])
+
+-- | Collect weights and values.
+collectWithWeight :: (Functor f, Foldable f, Foldable tree, Functor tree, IsWeight w, Num w)
+                  => NodeSplit a (f (tree a))
+                  -> NodeSplit (Weighted w [a]) (Weighted w [a])
+collectWithWeight = collectNodeSplitWith (\x -> withWeight 1 [x])
+
+-- | Measure a nodesplit with a given measuring function.
+collectNodeSplitWith   :: (Monoid w, Foldable f, Foldable tree)
+                       => (a -> w) -> NodeSplit a (f (tree a)) -> NodeSplit w w
+collectNodeSplitWith f = bimap f (foldMap (\t -> foldMap f t))
+
 
 -- | unsplit the node split into a proper Tree
 nodeSplitToTree :: NodeSplit a [Tree a] -> Tree a
@@ -138,12 +162,22 @@ trifoldMap fa ft fl = go
 
 ----------------------------------------
 
--- | returns the a's left, on, and right of the path
-collectPath :: Path a [Tree a] (NodeSplit a [Tree a]) -> NodeSplit [a] [a]
-collectPath = foldPath handle (\ns r -> handle ns <> r)
-  where
-    handle (NodeSplit x before after) = NodeSplit [x] (f before) (f after)
-    f = foldMap F.toList
+-- | Collect a list of path values
+pathValues :: Path a [Tree a] (NodeSplit a [Tree a]) -> NodeSplit [a] [a]
+pathValues = collectPathWith (:[])
+
+-- | Collects the weight on the path
+pathWeight :: Path a [Tree a] (NodeSplit a [Tree a]) -> NodeSplit Int Int
+pathWeight = bimap getWeight getWeight . collectPathWith (\x -> withWeight 1 [x])
+
+
+-- | Collect on a node split
+collectPathWith   :: (Monoid w, Foldable f, Foldable tree, Foldable g, Foldable tree')
+                  => (a -> w)
+                  -> Path a (f (tree a)) (NodeSplit a (g (tree' a)))
+                  -> NodeSplit w w
+collectPathWith f = foldPath (collectNodeSplitWith f) (\ns r -> collectNodeSplitWith f ns <> r)
+
 
 -- | Recombine the path into a tree
 pathToTree :: Path a [Tree a] (Tree a) -> Tree a
@@ -210,6 +244,10 @@ findNode' p = go
 data Side = L | R deriving (Show,Eq,Enum,Bounded)
 
 -- | Computes the weight of the path on the particular side.
-pathWeight   :: (IsWeight w, Num w)
-             => Side -> Path c [Tree (Weighted w a)] (NodeSplit b [Tree (Weighted w d)]) -> w
-pathWeight s = foldPath (nodeSplitWeight s) (\ns acc -> acc + nodeSplitWeight s ns)
+-- pathWeight   :: (IsWeight w, Num w)
+--              => Side -> Path c [Tree (Weighted w a)] (NodeSplit b [Tree (Weighted w d)]) -> w
+pathWeightOn     :: Side -> Path a [Tree a] (NodeSplit a [Tree a]) -> Int
+pathWeightOn s p = let NodeSplit _ before after = pathWeight p
+                   in case s of
+                        L -> before
+                        R -> after

hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Separator/Type.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE  TemplateHaskell  #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  HGeometry.Plane.LowerEnvelope.Separator.Type
+-- Copyright   :  (C) Frank Staals
+-- License     :  see the LICENSE file
+-- Maintainer  :  Frank Staals
+--
+-- A Separator for ap lanar graph
+--
+--------------------------------------------------------------------------------
+module HGeometry.Plane.LowerEnvelope.Connected.Separator.Type
+  ( Separator(Separator), separator, inside, outside
+  ) where
+
+import Control.Lens hiding (inside,outside)
+
+--------------------------------------------------------------------------------
+
+-- | A separator
+data Separator a = Separator { _separator :: a
+                             , _inside    :: a
+                             , _outside   :: a
+                             }
+                 deriving (Show,Eq,Functor,Foldable,Traversable)
+
+makeLenses ''Separator
+
+instance Semigroup a => Semigroup (Separator a) where
+  (Separator sep is os) <> (Separator sep' is' os') =
+    Separator (sep <> sep') (is <> is') (os <> os')
+
+instance (Monoid a) => Monoid (Separator a) where
+  mempty = Separator mempty mempty mempty