diff --git a/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Separator.hs b/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Separator.hs index c4db83bf3..333af8cb3 100644 --- a/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Separator.hs +++ b/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Separator.hs @@ -162,219 +162,6 @@ contract = undefined trim _ _ tr = tr -- TODO: --- -- | Given a spanning tree of the graph that has diameter r, compute --- -- a separator of size at most 2r+1 --- planarSeparatorTree :: (Ord k --- , Show k --- ) => PlaneGraph k v e -> Tree k -> Separator k --- planarSeparatorTree gr tr = (sep, foldMap F.toList <$> trees) --- -- FIXME: continue searching --- where --- e = Set.findMin $ graphEdges gr `Set.difference` treeEdges tr --- (sep, trees) = traceShowWith ("separator: ",) --- $ fromSplitTree . splitLeaf gr e --- $ traceShowWith ("splitTree",e,) --- $ splitTree e $ traceShowWith ("TR",) tr - --------------------------------------------------------------------------------- --- * Spliting the tree - --- data SplitTree l a = RootSplit l [Tree a] (Path l a) [Tree a] --- | Prefix (Path (a, Split l a) a) --- deriving (Show,Eq) --- -- still not quite right, since now we can't represent rotosplits lower than the root . - --- newtype SplitTree a l = SplitTree (Path a (Split a l)) --- deriving (Show,Eq,Functor) - --- -- | A path in the tree that ends at a "leaf" in which we store something of type l --- newtype Path a l = MkPath (NonEmpty (PathNode a l)) --- deriving (Show,Eq,Functor) - --- data PathNode a l = PathLeaf l --- | PathNode a [Tree a] [Tree a] --- deriving (Show,Eq,Functor) - --- pattern Leaf :: l -> Path a l --- pattern Leaf l = MkPath (PathLeaf l :| []) - --- (<|) :: PathNode a l -> Path a l -> Path a l --- n <| (MkPath path) = MkPath $ n NonEmpty.<| path - --- pattern Path :: a -> [Tree a] -> Path a l -> [Tree a] -> Path a l --- pattern Path u before path after <- (unconsPath -> Just (u, before, after, path)) --- where --- Path u before path after = PathNode u before after <| path - - --- unconsPath :: Path a l -> Maybe (a, [Tree a], [Tree a], Path a l) --- unconsPath = \case --- MkPath (PathNode u before after :| path') -> (u,before,after,) . MkPath --- <$> NonEmpty.nonEmpty path' --- _ -> Nothing --- {-# COMPLETE Leaf, Path #-} - - --- -- | The split node where the two paths diverge --- data Split a l = --- RootSplit l -- ^ apparently root is the split we are looking for. --- [Tree a] (Path a l) [Tree a] --- | NodeSplit a -- ^ label of the node we are splitting --- [Tree a] -- ^ children before the left path --- (Path a l) --- -- ^ the value stored at the left node (i.e. the leaf) we argoing to, --- -- and the pato that goes there. --- [Tree a] -- ^ middle nodes --- (Path a l) --- -- ^ the value stored at the right node we argoing to, and the pato that --- -- goes there. --- [Tree a] --- deriving (Show,Eq,Functor) - --- -- | Given an non-tree edge (v,w), split the tree usign the root to v,w paths --- splitTree :: Eq a => (a,a) -> Tree a -> SplitTree a (Tree a) --- splitTree e t = case splitTree' e t of --- Both split -> split --- _ -> error "splitTree: absurd, didn't find both endpoints" - --- data ResultF a b = NotFound --- | Single a --- | Both b --- deriving (Show,Eq,Functor) - --- type Result a = ResultF (VW, Path a (Tree a) ) (SplitTree a (Tree a)) - --- data VW = V | W - --- other :: p -> p -> VW -> p --- other v w = \case --- V -> w --- W -> v - --- data Loc a b = Here a | There b deriving (Show,Eq) - --- -- | Implementation of splitTree; i.e. tries to find both endpoints of the given edge. --- splitTree' :: Eq a => (a,a) -> Tree a -> Result a --- splitTree' (v,w) = fmap SplitTree . go --- where --- -- Handle the cases that we find one of the elemtns (identified by 'found') here. --- here found tr chs = case findNodes w chs of --- Nothing -> Single (found, Leaf tr) --- Just (before, after, path) -> Both . Leaf $ RootSplit tr before path after - --- go tr@(Node u chs) --- | u == v = here V tr chs --- | u == w = here W tr chs --- | otherwise = case foldr process (NotFound, []) chs of --- (NotFound, _) -> NotFound --- (Single (middle, (x,path)),after) -> Single (x, PathNode u middle after <| path) --- (Both (before, both'), after) -> Both $ case both' of --- Here (lp,middle,rp) -> Leaf $ (NodeSplit u before lp middle rp after) --- There path -> PathNode u before after <| path - --- process ch@(Node u chs) = \case --- (NotFound, after) -> case go ch of --- NotFound -> (NotFound, ch:after) --- Single rightPath -> (Single ([], rightPath), after) --- Both split -> (Both ([], There split), after) - --- (Single (middle, path@(x, rightPath)), after) --- | other v w x == u -> (Both ([], Here (Leaf ch, middle, rightPath)), after) --- | otherwise -> case pathNode u <$> findNodes (other v w x) chs of --- Nothing -> (Single (ch:middle,path), after) --- Just leftPath -> (Both ([], Here (leftPath, middle, rightPath)), after) - --- (Both (before, split), after) -> (Both (ch:before, split), after) - --- -- | Search for a given element in a bunch of trees. Returns the path towards --- -- the node if we find it. --- findNodes :: Eq a => a -> [Tree a] -> Maybe ([Tree a], [Tree a], Path a (Tree a)) --- findNodes v = go --- where --- go chs = case foldr process (Nothing, []) chs of --- (Nothing, _) -> Nothing --- (Just (before, path), after) -> Just (before, after, path) - --- process ch = \case --- (Nothing, after) -> case findNode' ch of --- Nothing -> (Nothing, ch:after) --- Just path -> (Just ([],path), after) --- (Just (before, path), after) -> (Just (ch:before, path), after) - --- findNode' t@(Node u chs) --- | u == v = Just (Leaf t) --- | otherwise = pathNode u <$> go chs - --- -- | Smart constructor for producign a pathNode --- pathNode :: a -> ([Tree a], [Tree a], Path a l) -> Path a l --- pathNode u (before, after, path) = PathNode u before after <| path - ----------------------------------------- - --- type EndPoint a = (a, [Tree a], [Tree a]) - --- -- | Split the leaf of the path --- splitLeaf :: Ord k --- => PlaneGraph k v e --- -> (k,k) -> SplitTree k (Tree k) -> SplitTree k (EndPoint k) --- splitLeaf gr (v',w') = fmap $ \(Node u chs) -> split u chs (if u == v' then w' else v') --- where --- split v chs w = case List.break ((== w) . snd) adjacencies of --- (before, _:after) -> (v, mapMaybe fst before, mapMaybe fst after) --- _ -> error "splitLeaf: absurd. edge not found!?" --- where --- adjacencies = annotateSubSet root chs $ maybe [] (Map.elems . fst) (Map.lookup v gr) - --- -- | Given a tagging function, a subset, and the full set, tag the elements in the full set --- -- with whether or not they are present in the subset. Both sets should be sorted. --- annotateSubSet :: Eq b => (a -> b) -> [a] -> [b] -> [(Maybe a,b)] --- annotateSubSet f = go --- where --- go [] fullSet = map (Nothing,) fullSet --- go subSet@(x:xs) (y:ys) --- | f x == y = (Just x, y) : go xs ys --- | otherwise = (Nothing, y) : go subSet ys --- go _ [] = [] -- this case should not really happen if the first is a subset - - --- -- | Turn the split tree into a separator, and the trees inside the cycle, and outside the --- -- separator. --- fromSplitTree :: Eq a => SplitTree a (EndPoint a) -> ([a],Vector 2 [Tree a]) --- fromSplitTree (SplitTree t) = go t --- where --- go = \case --- Leaf split -> fromSplit split --- Path u before path after -> let (sep,Vector2 inside outside) = go path --- in (u : sep,Vector2 inside (before <> outside <> after)) - --- -- | Handling a split node --- fromSplit :: Eq a => Split a (EndPoint a) -> ([a],Vector 2 [Tree a]) --- fromSplit = \case --- RootSplit (v,beforeV,afterV) _ path _ -> case path of --- Leaf (_,_,_) -> error "w is a child of v, that shouldn't really happen" --- Path u _ path' _ -> case List.break ((== u) . root) beforeV of --- -- edge vw lies after the path from v via u to w --- (before, _:insideV) -> (v : u : sep, Vector2 inside outside) --- where --- (sep, Vector2 insideU beforeU) = fromPath After path' --- inside = insideU <> insideV --- outside = before <> beforeU <> afterV --- -- ede vw lies before the path from v via u to w --- _ -> case List.break ((== u) . root) afterV of --- (middle, _:afterU) -> (v : u : sep, Vector2 inside outside) --- where --- (sep, Vector2 insideU afterW) = fromPath Before path' --- inside = middle <> insideU --- outside = beforeV <> afterW <> afterU --- _ -> error "fromSplit. Rootsplit (v,w) not found" --- NodeSplit u before lp middle rp after -> (u : lSep <> rSep, Vector2 inside outside) --- where --- (lSep, Vector2 lInside lOutside) = fromPath After lp --- (rSep, Vector2 rInside rOutside) = fromPath Before rp - --- inside = lInside <> middle <> rInside --- outside = before <> lOutside <> rOutside <> after - -------------------------------------------------------------------------------- -- | Find the last element matching some predicate diff --git a/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Separator/Cycle.hs b/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Separator/Cycle.hs index 2ac063f9d..366ff2f85 100644 --- a/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Separator/Cycle.hs +++ b/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Separator/Cycle.hs @@ -15,7 +15,8 @@ module HGeometry.Plane.LowerEnvelope.Connected.Separator.Cycle , toCycle , splitTree , missingEdge - , toSeparator + , collectWith + , toSeparator, separatorWeight , annotateCycle , makeInsideHeaviest @@ -25,7 +26,7 @@ module HGeometry.Plane.LowerEnvelope.Connected.Separator.Cycle , CycleSplitPaths(..) , collectPathsWith , collectAll - , cycleSplitPathWeights + -- , cycleSplitPathWeights , endPoints , endPoints' @@ -74,16 +75,36 @@ missingEdge :: Cycle a [Tree a] -> (a, a) missingEdge (Cycle paths _ _ _) = endPoints' paths -- | Collects all 'a's -collectAll :: Cycle' a -> [a] -collectAll (Cycle paths bs ms as) = collectAllPaths paths <> flatten (bs <> ms <> as) +collectAll :: Show a => + Cycle' a -> [a] +collectAll = F.fold . toSeparator + +-- | Collect stuff about the separtor +collectWith :: (Show a, Show w, + Monoid w + ) + => (a -> w) + -> Cycle' a -> Separator w +collectWith f (Cycle paths before middle after) = here <> collectPathsWith f paths + where + f' = foldMap (foldMap f) + here = traceShowWith ("collectWith, here",) $ Separator mempty (f' middle) (f' $ before <> after) + + +---------------------------------------- -- | 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 +toSeparator :: Show a => + Cycle' a -> Separator [a] +toSeparator = fmap (getValue @Weight) . collectWith weigh + -- collectWith (:[]) + +-- | Computes the weight of the separator, interior, and exterior +separatorWeight :: Show a => + Cycle' a -> Separator Weight +separatorWeight = fmap getWeight . collectWith weigh + ---------------------------------------- @@ -114,29 +135,25 @@ instance Bifoldable CycleSplitPaths where -- | Collects all a's -collectAllPaths :: CycleSplitPaths a [Tree a] -> [a] +collectAllPaths :: Show a => + CycleSplitPaths a [Tree a] -> [a] collectAllPaths = F.fold . collectPathsWith (:[]) -- | Collects the paths into a (partial) separator -collectPathsWith :: Monoid w => (a -> w) -> CycleSplitPaths a [Tree a] -> Separator w +collectPathsWith :: (Show a, Show w, + 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) + PathSplit r lPath rPath -> let ll@(NodeSplit sepL before middleL) = collectPathWith f lPath + rr@(NodeSplit sepR middleR after) = collectPathWith f rPath + in traceShowWith ("collectPathsWith",r,lPath,rPath, + ll,rr, + ) $ + Separator (f r <> sepL <> sepR) (middleL <> middleR) (before <> after) --- | Computes the weights of the -cycleSplitPathWeights :: CycleSplitPaths a [Tree a]-> Weight -cycleSplitPathWeights = \case - RootSplit rs -> rootSplitWeight rs - 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 -- splitpath the root comes first. endPoints :: CycleSplitPaths a [Tree a] -> (a,a) @@ -259,80 +276,19 @@ annotateCycle :: Cycle a [Tree a] -> Cycle (Weighted Weight a) [Tree (Weighted W annotateCycle = bimap (Weighted 1) (fmap annotate) -- | Makes sure that the inside of the cycle is heaviest. -makeInsideHeaviest :: Cycle' a -> Cycle' a -makeInsideHeaviest split@(Cycle paths before inside after) - | weightOf inside < weightOf before + weightOf after = - Cycle (shift paths) [] (after <> before) inside - | otherwise = split +makeInsideHeaviest :: Show a => + Cycle' a -> Cycle' a +makeInsideHeaviest c@(Cycle paths before inside after) + | interiorWeight < exteriorWeight = Cycle (shift paths) [] (after <> before) inside + | otherwise = c where + Separator _ interiorWeight exteriorWeight = separatorWeight c -- shift the paths shift = \case RootSplit (RootBefore r path) -> RootSplit (RootAfter path r) RootSplit (RootAfter path r) -> RootSplit (RootBefore r path) PathSplit r lPath rPath -> PathSplit r rPath lPath - -- rev = mapPath rev' rev' - -- rev' (NodeSplit x before after) = NodeSplit x after befor - - --------------------------------------------------------------------------------- -{- --- | Search along a path; we search among the nodees on the path and in the subtrees --- hanging off the path on the given side. --- --- Note that splitLeaf should already be applied so that it only takes the remaining leaf -findNodeAlongPath :: ( Tree a -> NodeSplit a [Tree a]) - -> (a -> [Tree a] -> Maybe (Vector 2 [Tree a])) - -> (a -> Bool) - -> Side -- ^ indicates which subtrees to search - -> Path a [Tree a] (NodeSplit a [Tree a]) - -> Maybe ( Cycle' a - , Path a [Tree a] (Tree a) - ) -findNodeAlongPath splitLeaf splitChildren p side = - - - go - where - go = \case - Leaf (NodeSplit u before after) - | p u -> Just ( error "findNodeAlongPath; splitting the same leaf?" - , Leaf $ splitLeaf (Node u $ before <> after) - ) - | otherwise -> here u before after (RootSplit . flip RootAfter u) - (RootSplit . RootBefore u) - - Path (NodeSplit (u, path) before after) - | p u -> Just ( cycle' u path before after - , Leaf $ splitLeaf (Node u $ before <> after) - ) - | otherwise -> here u before after (\path' -> PathSplit u path' path) - (PathSplit u path) - <|> ( fmap (\path' -> Path $ NodeSplit (u,path') before after) - <$> go path) - - here u before after makeL makeR = case side of - L -> findNode' p before <&> \(NodeSplit path' before' after') -> - let path'' = splitLeaf <$> path' - in ( Split (makeL path'') before' after' after - , Path $ NodeSplit (u, path'') before' (after' <> after) - ) - -- Search on the left; i.e. in the before part - R -> findNode' p after <&> \(NodeSplit path' before' after') -> - let path'' = splitLeaf <$> path' - in ( Split (makeR path'') before before' after' - , Path $ NodeSplit (u, path'') (before <> before') after' - ) - - cycle' u path before after = case splitChildren u before of - Nothing -> case splitChildren u after of - Nothing -> error "toCycle" - Just (Vector2 middle after') -> - Split (RootSplit $ RootAfter path u) before middle after' - Just (Vector2 before' middle) -> - Split (RootSplit $ RootBefore u path) before' middle after --} - -------------------------------------------------------------------------------- -- * Splitting a Cycle diff --git a/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Separator/Path.hs b/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Separator/Path.hs index 0dfe2ac83..8244111fb 100644 --- a/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Separator/Path.hs +++ b/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Separator/Path.hs @@ -81,16 +81,16 @@ nodeSplitWeight :: (Functor f, Foldable f, Foldable tree, Functor tree, IsWeight => 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 (:[]) +-- -- | 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]) +collectWithWeight = collectNodeSplitWith weigh -- | Measure a nodesplit with a given measuring function. collectNodeSplitWith :: (Monoid w, Foldable f, Foldable tree) @@ -168,7 +168,7 @@ 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]) +pathWeight = bimap getWeight getWeight . collectPathWith weigh -- | Collect on a node split @@ -186,7 +186,7 @@ pathToTree = foldPath id (\ns ch -> nodeSplitToTreeWith ns [ch]) -- | Recombines a path ending in a nodesplit to a tree. pathToTree' :: Path a [Tree a] (NodeSplit a [Tree a]) -> Tree a pathToTree' = foldPath nodeSplitToTree (\ns ch -> nodeSplitToTreeWith ns [ch]) --- I coulud also have just used fmap nodeSplitToTree I guess. Hoping this may be slightly +-- I could also have just used fmap nodeSplitToTree I guess. Hoping this may be slightly -- more efficient. -- | Flatten the path into a list of elements diff --git a/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Separator/Weight.hs b/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Separator/Weight.hs index 84bbee257..2294bedb3 100644 --- a/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Separator/Weight.hs +++ b/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Separator/Weight.hs @@ -13,7 +13,7 @@ module HGeometry.Plane.LowerEnvelope.Connected.Separator.Weight ( HasWeight(..) , IsWeight(..) , Weighted(..) - , weightOf + , weigh , weightOf' , annotate ) where @@ -41,6 +41,10 @@ instance IsWeight Int where getWeight (Weighted w _) = w getValue (Weighted _ x) = x +-- | Weight some element +weigh :: (Num w, IsWeight w) => a -> Weighted w [a] +weigh x = withWeight 1 [x] + instance (Semigroup a, IsWeight w, Num w) => Semigroup (Weighted w a) where wx <> wy = withWeight (getWeight wx + getWeight wy) (getValue wx <> getValue wy) diff --git a/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Split.hs b/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Split.hs index 57ad03da7..acc71e597 100644 --- a/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Split.hs +++ b/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Split.hs @@ -21,6 +21,7 @@ module HGeometry.Plane.LowerEnvelope.Connected.Split , interiorWeight ) where +import Control.Lens (view) import Data.Bifunctor import qualified Data.Foldable as F import qualified Data.List as List @@ -76,7 +77,8 @@ initialCycle gr tr = withInteriorWeight . makeInsideHeaviest -- . annotateCycle e = Set.findMin $ graphEdges gr `Set.difference` treeEdges tr -- | Annotate the cycle with its interior weight -withInteriorWeight :: Cycle' k -> Weighted Weight (Cycle' k) +withInteriorWeight :: Show k => + Cycle' k -> Weighted Weight (Cycle' k) withInteriorWeight c = withWeight (interiorWeight c) c @@ -88,10 +90,10 @@ planarSeparatorCycle :: ( Ord k, Show k) -> Cycle' k planarSeparatorCycle allowedWeight gr = NonEmpty.last . showCycles - . NonEmpty.fromList . NonEmpty.take 10 -- remove this + . NonEmpty.fromList . NonEmpty.take 10 -- FIXME remove this . planarSeparatorCycles allowedWeight gr where - showCycles cs = traceShow ("CYCLES", fmap missingEdge cs + showCycles cs = traceShow ("CYCLES", fmap missingEdge cs, length cs ) cs @@ -122,7 +124,7 @@ planarSeparatorCycles allowedWeight gr tr = NonEmpty.unfoldr shrink $ initialCyc -- error $ -- ("planarSeparatorTree: impossible " <> show e' <> " not inside " <> -- show (commonNeighbours e' gr)) - res@(Just _) -> res + res@(Just _) -> traceShowWith ("shrunken",) res e = missingEdge c @@ -140,8 +142,10 @@ annotateWithMissingEdge c = ("withMissingEdge ",missingEdge c,"of ",c) -- | Compute the weight on the inside of the cycle -interiorWeight :: Cycle' a -> Weight -interiorWeight (Cycle paths _ inside _) = cycleSplitPathWeights paths + weightOf inside +interiorWeight :: Show a => + Cycle' a -> Weight +interiorWeight = view inside . separatorWeight + -------------------------------------------------------------------------------- diff --git a/hgeometry/test-with-ipe/test/Plane/LowerEnvelopeSpec.hs b/hgeometry/test-with-ipe/test/Plane/LowerEnvelopeSpec.hs index 3e65785fb..f5075f064 100644 --- a/hgeometry/test-with-ipe/test/Plane/LowerEnvelopeSpec.hs +++ b/hgeometry/test-with-ipe/test/Plane/LowerEnvelopeSpec.hs @@ -9,6 +9,7 @@ module Plane.LowerEnvelopeSpec ) where import Control.Lens +import Data.Bifunctor import Data.Foldable import Data.Foldable1 import qualified Data.List as List @@ -32,7 +33,7 @@ import qualified HGeometry.Plane.LowerEnvelope.Connected.Split as Split import HGeometry.Plane.LowerEnvelope.Connected.Split hiding (Path) import HGeometry.Plane.LowerEnvelope.ConnectedNew import HGeometry.Point -import HGeometry.PolyLine(PolyLine,polyLineFromPoints) +import HGeometry.PolyLine (PolyLine,polyLineFromPoints) import HGeometry.Polygon.Convex import HGeometry.Polygon.Simple import HGeometry.Vector @@ -45,7 +46,7 @@ import Test.Hspec.WithTempFile import Test.QuickCheck import Test.QuickCheck.Instances () -import Debug.Trace +import Debug.Trace -------------------------------------------------------------------------------- type R = RealNumber 5 @@ -126,7 +127,7 @@ spec = describe "lower envelope tests" $ do testIpeGraph [osp|foo.ipe|] [osp|foo_graph_out|] - +{- describe "planar separator tests" $ do prop "findNode on path the same" $ \(t :: Tree Int) -> @@ -135,20 +136,16 @@ spec = describe "lower envelope tests" $ do Nothing -> True Just path' -> pathToTree path' == t' in all (findNodeSame t) predicates - -- prop "pathWeight and collectPath agree" $ - -- \(t :: Tree Int) -> - -- let predicates = const False : [(== x) | x <- toList t] - -- findNodeSame t' p = case findNode p t' of - -- Nothing -> True - -- Just path' -> let SplitNode a b c = bimap length length $ collectPath path' - - -- in - - - -- pathToTree path' == t' - -- in all (findNodeSame t) predicates - - + prop "pathWeight and collectPath agree" $ + \(t :: Tree Int) k -> + let predicates = [(== x) | x <- toList t] + findNodeSame t' p = case findNode p t' of + Nothing -> True === True + Just path' -> + let path'' :: Split.Path Int [Tree Int] (NodeSplit Int [Tree Int]) + path'' = splitLeaf' k undefined <$> path' in + pathWeight path'' === (bimap length length $ pathValues path'') + in conjoin $ map (findNodeSame t) predicates prop "initialSplit identity" $ \(t :: Tree Int) -> onAllPairs t $ \e -> @@ -231,7 +228,7 @@ spec = describe "lower envelope tests" $ do theCycle = toCycle splitLeaf splitChildren $ initialSplit e t in collectAll' theCycle === allElems - +-} splitLeaf' k _ (Node z nodes) = NodeSplit z (take k nodes) (drop k nodes) @@ -246,7 +243,7 @@ myCycle = MkCycle (Split (PathSplit 0 (Leaf (NodeSplit 1 [] [Node {rootLabel = 2 counterexample' x = counterexample (show x) -collectAll' :: Ord a => Cycle' a -> Set a +collectAll' :: (Ord a, Show a) => Cycle' a -> Set a collectAll' = Set.fromList . collectAll @@ -436,7 +433,20 @@ testIpeGraph inFp outFp = do it "B is a set" $ length (Set.fromList bs) `shouldBe` (length bs) it "interiorWeight == size A" $ - length (Set.fromList as) `shouldBe` interiorWeight finalCycle + interiorWeight finalCycle `shouldBe` length as -- (Set.fromList as) + let w = collectWith weigh finalCycle :: Separator (Weighted' [Point 2 R]) + it ("interiorWeight and seprator consistent " <> show w) $ + separatorWeight finalCycle `shouldBe` (length <$> s) + it "paths disjoint" $ + let f = (:[]) + g = Set.singleton + Cycle paths _ _ _ = finalCycle + in case paths of + RootSplit _ -> True `shouldBe` True + PathSplit _ lPath rPath -> + (fold (collectPathWith g lPath) `Set.intersection` fold (collectPathWith g rPath)) + `shouldBe` Set.empty + it "separator is a separator" $ let aSet = Set.fromList as bSet = Set.fromList bs