Data type for representing a Polygon with holes

hgeometry-combinatorial/hgeometry-combinatorial.cabal

@@ -117,6 +117,8 @@ library
 
         HGeometry.Foldable.Sort
         HGeometry.Foldable.Util
+        -- HGeometry.Foldable.NonEmpty
+
         HGeometry.Indexed
 
         HGeometry.Lens.Util

hgeometry-combinatorial/src/HGeometry/Cyclic.hs

@@ -24,6 +24,7 @@ import           Control.DeepSeq (NFData)
 import           Control.Lens
 import           Control.Monad (forM_)
 import qualified Data.Foldable as F
+import           Data.Functor.Apply (Apply, (<.*>), (<*.>), MaybeApply(..))
 import qualified Data.List.NonEmpty as NonEmpty
 import           Data.Maybe (isJust)
 import           Data.Semigroup.Foldable
@@ -33,8 +34,10 @@ import qualified Data.Vector.Mutable as MV
 import qualified Data.Vector.NonEmpty as NV
 import           GHC.Generics (Generic)
 import           HGeometry.Foldable.Util
+import           HGeometry.Sequence.NonEmpty
 import           HGeometry.StringSearch.KMP (isSubStringOf)
 import           HGeometry.Vector.NonEmpty.Util ()
+
 --------------------------------------------------------------------------------
 
 -- | A cyclic sequence type
@@ -69,7 +72,7 @@ type instance Index   (Cyclic v a) = Index   (v a)
 type instance IxValue (Cyclic v a) = IxValue (v a)
 
 instance (Index (v a) ~ Int, Foldable v, Ixed (v a)) => Ixed (Cyclic v a) where
-  ix i = \f (Cyclic v) -> let n = F.length v
+  ix i = \f (Cyclic v) -> let n  = F.length v
                           in Cyclic <$> ix (i `mod` n) f v
 
 -- | Turn the cyclic vector into a circular Vector
@@ -105,6 +108,30 @@ instance HasDirectedTraversals NV.NonEmptyVector where
       n        = F.length v
       indices' = NonEmpty.fromList [s,s-1..(s-n+1)]
 
+-- | Helper to build traversal1's
+wrapMaybeApply :: (Indexable Int p, Apply f) => p a (f b) -> p a (MaybeApply f b)
+wrapMaybeApply = rmap (MaybeApply . Left)
+
+
+instance HasDirectedTraversals ViewL1 where
+  traverseRightFrom i = \paFb xs -> let i'    = i `mod` F.length xs
+                                        paFb' = wrapMaybeApply paFb
+                                        combine (x :<< sa) sb = x :<< (sa <> sb)
+                                    in case splitL1At i' xs of
+      Nothing            -> traversed1 paFb xs
+      Just (pref,x,suff) -> combine <$>  reindexed (+i') traversed1 paFb (x :<< suff)
+                                    <.*> itraversed paFb' pref
+
+  traverseLeftFrom i = \paFb xs ->
+                         let i'    = i `mod` F.length xs
+                             paFb' = wrapMaybeApply paFb
+                             combine r1 rs = viewl1 $ r1 <>> rs
+                         in case splitL1At i' xs of
+      Nothing            -> backwards traversed1 paFb xs
+      Just (pref,x,suff) -> combine <$>  backwards traversed1 paFb (pref :>> x)
+                                    <.*> backwards (reindexed (\j -> 1 + i' + j) itraversed)
+                                                   paFb' suff
+
 -- | traverse the vector in the given order
 traverseByOrder                 :: NonEmpty.NonEmpty Int
                                 -> IndexedTraversal1' Int (NV.NonEmptyVector a) a

hgeometry-combinatorial/src/HGeometry/Foldable/NonEmpty.hs

@@ -0,0 +1,80 @@
+{-# LANGUAGE UndecidableInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  HGeometry.Polygon.Simple.Sample
+-- Copyright   :  (C) Frank Staals
+-- License     :  see the LICENSE file
+-- Maintainer  :  Frank Staals
+--
+-- Newtype to wrap some foldable structure promissing it is non-empty.
+--
+--------------------------------------------------------------------------------
+module HGeometry.Foldable.NonEmpty
+  ( NonEmptyF(..)
+  ) where
+
+import           Control.Lens
+import           Data.Foldable1
+import           Data.Functor.Apply (Apply, (<.*>), MaybeApply(..))
+import           Data.Semigroup.Traversable
+import           Data.Sequence (Seq(..))
+import qualified Data.Sequence as Seq
+import           GHC.Generics (Generic)
+
+--------------------------------------------------------------------------------
+
+-- | We promise that the structure is non-empty
+newtype NonEmptyF f a = NonEmptyF (f a)
+  deriving newtype (Functor,Foldable)
+  deriving Generic
+
+_NonEmptyF :: Iso (NonEmptyF f a) (NonEmptyF f b) (f a) (f b)
+_NonEmptyF = coerced
+
+instance Traversable f => Traversable (NonEmptyF f)  where
+  traverse f (NonEmptyF s) = NonEmptyF <$> traverse f s
+
+type instance Index   (NonEmptyF f a) = Index   (f a)
+type instance IxValue (NonEmptyF f a) = IxValue (f a)
+
+instance Ixed (f a) => Ixed (NonEmptyF f a) where
+  ix i = _NonEmptyF . ix i
+
+instance Wrapped   (NonEmptyF f a)
+
+instance Rewrapped (NonEmptyF f a) (NonEmptyF f b)
+
+instance FunctorWithIndex i f => FunctorWithIndex i (NonEmptyF f) where
+  imap f (NonEmptyF s) = NonEmptyF $ imap f s
+
+instance FoldableWithIndex i f => FoldableWithIndex i (NonEmptyF f) where
+  ifoldMap f (NonEmptyF s) = ifoldMap f s
+
+instance TraversableWithIndex i f => TraversableWithIndex i (NonEmptyF f) where
+  itraverse f (NonEmptyF s) = NonEmptyF <$> itraverse f s
+
+-- instance Foldable1 (NonEmptyF f) where
+--   foldMap1 = foldMap1Default
+
+-- instance Traversable1 (NonEmptyF f)  where
+--   traverse1 f (NonEmptyF s) = NonEmptyF f  <$> traverse1Seq f s
+
+-- instance HasFromFoldable1 (NonEmptyF f)  where
+--   fromNonEmpty = Seq1 . fromNonEmpty
+
+-- --------------------------------------------------------------------------------
+-- -- * Instances specific to Seq
+
+-- instance Traversable1 (NonEmptyF Seq)  where
+--   traverse1 f (NonEmptyF s) = NonEmptyF <$> traverse1Seq f s
+
+-- instance Foldable1 (NonEmptyF Seq) where
+--   foldMap1 = foldMap1Default
+
+
+
+-- -- | Traverse a non-empty sequence
+-- traverse1Seq   :: Apply f => (a -> f b) -> Seq a -> f (Seq b)
+-- traverse1Seq f = \case
+--   Seq.Empty -> error "traverse1Seq: precondition violated"
+--   (x :<| s) -> (:<|) <$> f x <.*> traverse1Maybe f s

hgeometry-combinatorial/src/HGeometry/Sequence/NonEmpty.hs

@@ -13,6 +13,9 @@ module HGeometry.Sequence.NonEmpty
   , viewl1, viewr1
   , (|>>)
   , (<>>)
+  -- , (<<>)
+  , splitL1At
+  , splitR1At
   ) where
 
 import           Control.DeepSeq
@@ -93,7 +96,6 @@ instance IsList (ViewL1 a) where
   fromList = maybe (error "ViewL1 fromList; empty List") fromNonEmpty . NonEmpty.nonEmpty
   {-# INLINE fromList #-}
 
-
 --------------------------------------------------------------------------------
 
 -- | NonEmpty ViewR
@@ -166,12 +168,15 @@ instance IsList (ViewR1 a) where
 infixl 5 |>>
 infixl 5 <>>
 
--- | Append a Sequence to a ViewR
+-- | Append a Sequence to a ViewR1
 (<>>)               :: ViewR1 a -> Seq a -> ViewR1 a
 l@(ys :>> y) <>> rs = case Sequence.viewr rs of
                         Sequence.EmptyR   -> l
                         rs' Sequence.:> r -> (ys <> (y :<| rs')) :>> r
 
+
+
+
 -- | View the leftmost element
 viewl1            :: ViewR1 a -> ViewL1 a
 viewl1 (xs :>> r) = case Sequence.viewl xs of
@@ -187,6 +192,29 @@ viewr1 (l :<< ls) = case Sequence.viewr ls of
 
 --------------------------------------------------------------------------------
 
+-- | Given an index i, and a viewL1 s, attempts to split s at index i. Returns nothing if
+-- the index is out of range.
+splitL1At             :: Int -> ViewL1 a -> Maybe (Seq a, a, Seq a)
+splitL1At i (x :<< s) = clampRange i (x <| s) <&> \s' -> case Sequence.splitAt i s' of
+  (pref, y :<| suff) -> (pref, y, suff)
+  _                  -> error "splitL1At: absurd"
+
+-- | Given an index i, and a viewL1 s, attempts to split s at index i. Returns nothing if
+-- the index is out of range.
+splitR1At             :: Int -> ViewR1 a -> Maybe (Seq a, a, Seq a)
+splitR1At i (s :>> x) = clampRange i (s |> x) <&> \s' -> case Sequence.splitAt i s' of
+  (pref, y :<| suff) -> (pref, y, suff)
+  _                  -> error "splitR1At: absurd"
+
+-- | Helper to make sure the index is within range.
+clampRange :: Foldable t => Int -> t a -> Maybe (t a)
+clampRange i s
+  | i < 0           = Nothing
+  | i >= F.length s = Nothing
+  | otherwise       = Just s
+
+--------------------------------------------------------------------------------
+