diff --git a/hgeometry/src/HGeometry/LineSegment/Intersection/Types.hs b/hgeometry/src/HGeometry/LineSegment/Intersection/Types.hs index 62d858c8e..f2ca176e1 100644 --- a/hgeometry/src/HGeometry/LineSegment/Intersection/Types.hs +++ b/hgeometry/src/HGeometry/LineSegment/Intersection/Types.hs @@ -1,5 +1,4 @@ {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TemplateHaskell #-} -------------------------------------------------------------------------------- -- | -- Module : HGeometry.LineSegment.Intersection.Types @@ -58,9 +57,13 @@ import HGeometry.Point -- | Assumes that two segments have the same start point -newtype AroundStart a = AroundStart a deriving (Show,Read,NFData,Functor) +newtype AroundStart a = AroundStart a + deriving (Show,Read,NFData,Functor,Generic) -makeWrapped ''AroundStart +instance Wrapped (AroundStart a) where + type Unwrapped (AroundStart a) = a + +instance (AroundStart a ~ t) => Rewrapped (AroundStart a) t instance ( Point_ point 2 r, Eq r , HasEnd lineSegment point) => Eq (AroundStart lineSegment) where @@ -77,9 +80,12 @@ instance ( LineSegment_ lineSegment point ---------------------------------------- -- | Assumes that two segments have the same end point -newtype AroundEnd a = AroundEnd a deriving (Show,Read,NFData,Functor) +newtype AroundEnd a = AroundEnd a deriving (Show,Read,NFData,Functor,Generic) + +instance Wrapped (AroundEnd a) where + type Unwrapped (AroundEnd a) = a -makeWrapped ''AroundEnd +instance (AroundEnd a ~ t) => Rewrapped (AroundEnd a) t instance (Point_ point 2 r, Eq r, HasStart lineSegment point) => Eq (AroundEnd lineSegment) where -- | equality on endpoint @@ -96,9 +102,13 @@ instance ( LineSegment_ lineSegment point -------------------------------------------------------------------------------- -- | Assumes that two segments intersect in a single point. -newtype AroundIntersection a = AroundIntersection a deriving (Eq,Show,Read,NFData,Functor) +newtype AroundIntersection a = AroundIntersection a + deriving (Eq,Show,Read,NFData,Functor,Generic) -makeWrapped ''AroundIntersection +instance Wrapped (AroundIntersection a) where + type Unwrapped (AroundIntersection a) = a + +instance (AroundIntersection a ~ t) => Rewrapped (AroundIntersection a) t instance ( LineSegment_ lineSegment point , Point_ point 2 r @@ -168,7 +178,20 @@ type OrdArounds lineSegment = ( Ord (AroundStart lineSegment) , Ord (AroundEnd lineSegment) ) -makeLenses ''Associated +-- | Lens to access the segments for which this is a startPoint +startPointOf :: Lens' (Associated lineSegment) (Set.Set (AroundStart lineSegment)) +startPointOf f (Associated ss es is) = fmap (\ss' -> Associated ss' es is) (f ss) +{-# INLINE startPointOf #-} + +-- | Lens to access the segments for which this is an endPoint +endPointOf :: Lens' (Associated lineSegment) (Set.Set (AroundEnd lineSegment)) +endPointOf f (Associated ss es is) = fmap (\es' -> Associated ss es' is) (f es) +{-# INLINE endPointOf #-} + +-- | Lens to access the segments for which this point lies in the interior of the segment +interiorTo :: Lens' (Associated lineSegment) (Set.Set (AroundIntersection lineSegment)) +interiorTo f (Associated ss es is) = fmap (\is' -> Associated ss es is') (f is) +{-# INLINE interiorTo #-} -- | Fold over the segments associated with the intersection. @@ -247,7 +270,21 @@ data IntersectionPoint point lineSegment = IntersectionPoint { _intersectionPoint :: !point , _associatedSegs :: !(Associated lineSegment) } deriving stock (Show,Generic) -makeLenses ''IntersectionPoint + +-- | Lens to access the intersectionp oint +intersectionPoint :: Lens (IntersectionPoint point lineSegment) + (IntersectionPoint point' lineSegment) + point point' +intersectionPoint f (IntersectionPoint p ss) = fmap (\p' -> IntersectionPoint p' ss) (f p) +{-# INLINE intersectionPoint #-} + +-- | Lens to access the associated segments +associatedSegs :: Lens (IntersectionPoint point lineSegment) + (IntersectionPoint point lineSegment') + (Associated lineSegment) (Associated lineSegment') +associatedSegs f (IntersectionPoint p ss) = fmap (\ss' -> IntersectionPoint p ss') (f ss) +{-# INLINE associatedSegs #-} + deriving stock instance ( Eq (AroundStart lineSegment) , Eq (AroundIntersection lineSegment) diff --git a/hgeometry/src/HGeometry/VerticalRayShooting/PersistentSweep.hs b/hgeometry/src/HGeometry/VerticalRayShooting/PersistentSweep.hs index 9c217ec83..ca6c2617a 100644 --- a/hgeometry/src/HGeometry/VerticalRayShooting/PersistentSweep.hs +++ b/hgeometry/src/HGeometry/VerticalRayShooting/PersistentSweep.hs @@ -1,4 +1,3 @@ -{-# Language TemplateHaskell #-} -------------------------------------------------------------------------------- -- | -- Module : HGeometry.VerticalRayShooting.PersistentSweep @@ -21,6 +20,7 @@ module HGeometry.VerticalRayShooting.PersistentSweep import Control.Lens hiding (contains, below) import Data.Foldable (toList) +import Data.Functor.Contravariant (phantom) import qualified Data.List as List import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty @@ -50,10 +50,24 @@ data VerticalRayShootingStructure' r lineSegment = -- status structure is 's', i.e up to 'r' } deriving (Show,Eq) +-- TODO this is very similar to the 'Alternating' sequence structure; so see if we can reuse code + + -- | The status structure type StatusStructure lineSegment = SS.Set lineSegment -makeLensesWith (lensRules&generateUpdateableOptics .~ False) ''VerticalRayShootingStructure' +-- | Getter to access the leftmost coordinate. +leftMost :: Getter (VerticalRayShootingStructure' r lineSegment) r +leftMost f (VerticalRayShootingStructure x _) = phantom (f x) +{-# INLINE leftMost #-} + +-- | Getter to access the sweep structure +sweepStruct :: Getter (VerticalRayShootingStructure' r lineSegment) + (V.Vector (r :+ StatusStructure lineSegment)) +sweepStruct f (VerticalRayShootingStructure _ ss) = phantom (f ss) +{-# INLINE sweepStruct #-} + +-- more or less copied the above two implementations from the TH generated ones -------------------------------------------------------------------------------- -- * Building the DS