module Diagrams.Path
(
PathLike(..), fromSegments, fromOffsets, fromVertices, segmentsFromVertices
, pathLikeFromTrail
, Closeable(..)
, Trail(..)
, trailSegments'
, trailOffsets, trailOffset
, trailVertices, reverseTrail
, addClosingSegment
, fixTrail
, Path(..)
, pathFromTrail
, pathFromTrailAt
, pathVertices
, pathOffsets
, pathCentroid
, expandPath
, reversePath
, fixPath
, explodeTrail
, explodePath
, (~~)
) where
import Graphics.Rendering.Diagrams
import Graphics.Rendering.Diagrams.Points
import Diagrams.Align
import Diagrams.Segment
import Diagrams.Points
import Diagrams.Transform
import Data.VectorSpace
import Data.AffineSpace
import Control.Newtype hiding (under)
import Data.Semigroup
import qualified Data.Foldable as F
import Data.List (mapAccumL)
import Control.Arrow ((***), first, second)
class (Monoid' p, VectorSpace (V p)) => PathLike p where
pathLike :: Point (V p)
-> Bool
-> [Segment (V p)]
-> p
instance VectorSpace v => PathLike [Point v] where
pathLike start cl segs = trailVertices start (pathLike start cl segs)
fromSegments :: PathLike p => [Segment (V p)] -> p
fromSegments = pathLike origin False
fromOffsets :: PathLike p => [V p] -> p
fromOffsets = pathLike origin False . map Linear
fromVertices :: PathLike p => [Point (V p)] -> p
fromVertices [] = mempty
fromVertices vvs@(v:_) = pathLike v False (segmentsFromVertices vvs)
segmentsFromVertices :: AdditiveGroup v => [Point v] -> [Segment v]
segmentsFromVertices [] = []
segmentsFromVertices vvs@(_:vs) = map Linear (zipWith (flip (.-.)) vvs vs)
class PathLike p => Closeable p where
open :: p -> p
close :: p -> p
instance VectorSpace v => Closeable (Trail v) where
close (Trail segs _) = Trail segs True
open (Trail segs _) = Trail segs False
instance VectorSpace v => Closeable (Path v) where
close = (over Path . map . second) close
open = (over Path . map . second) open
data Trail v = Trail { trailSegments :: [Segment v]
, isClosed :: Bool
}
deriving (Show, Functor, Eq, Ord)
type instance V (Trail v) = v
instance Semigroup (Trail v) where
Trail t1 c1 <> Trail t2 c2 = Trail (t1 ++ t2) (c1 || c2)
instance Monoid (Trail v) where
mempty = Trail [] False
mappend = (<>)
instance VectorSpace v => PathLike (Trail v) where
pathLike _ cl segs = Trail segs cl
instance HasLinearMap v => Transformable (Trail v) where
transform t (Trail segs c) = Trail (transform t segs) c
instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Trail v) where
getEnvelope (Trail segs _) =
foldr (\seg bds -> moveOriginTo (P . negateV . segOffset $ seg) bds <> getEnvelope seg)
mempty
segs
instance HasLinearMap v => Renderable (Trail v) NullBackend where
render _ _ = mempty
trailSegments' :: AdditiveGroup v => Trail v -> [Segment v]
trailSegments' t | isClosed t = trailSegments t
++ [straight . negateV . trailOffset $ t]
| otherwise = trailSegments t
trailOffsets :: Trail v -> [v]
trailOffsets (Trail segs _) = map segOffset segs
trailOffset :: AdditiveGroup v => Trail v -> v
trailOffset = sumV . trailOffsets
trailVertices :: AdditiveGroup v => Point v -> Trail v -> [Point v]
trailVertices p = scanl (.+^) p . trailOffsets
reverseTrail :: AdditiveGroup v => Trail v -> Trail v
reverseTrail t@(Trail {trailSegments = []}) = t
reverseTrail t@(Trail {trailSegments = ss})
| isClosed t = t { trailSegments = straight (trailOffset t) : reverseSegs ss }
| otherwise = t { trailSegments = reverseSegs ss }
where reverseSegs = fmap reverseSegment . reverse
reverseRootedTrail :: AdditiveGroup v => (Point v, Trail v) -> (Point v, Trail v)
reverseRootedTrail (p, t)
| isClosed t = (p, reverseTrail t)
| otherwise = (p .+^ trailOffset t, reverseTrail t)
pathLikeFromTrail :: PathLike p => Trail (V p) -> p
pathLikeFromTrail t = pathLike origin (isClosed t) (trailSegments t)
addClosingSegment :: AdditiveGroup v => Trail v -> Trail v
addClosingSegment t | isClosed t = Trail (trailSegments t ++ [closeSeg]) False
| otherwise = t
where closeSeg = Linear . negateV $ trailOffset t
fixTrail :: AdditiveGroup v => Point v -> Trail v -> [FixedSegment v]
fixTrail start t = zipWith mkFixedSeg (trailVertices start t)
(trailSegments $ addClosingSegment t)
newtype Path v = Path { pathTrails :: [(Point v, Trail v)] }
deriving (Show, Semigroup, Monoid, Eq, Ord)
type instance V (Path v) = v
instance Newtype (Path v) [(Point v, Trail v)] where
pack = Path
unpack = pathTrails
instance VectorSpace v => HasOrigin (Path v) where
moveOriginTo = over Path . map . first . moveOriginTo
instance VectorSpace v => PathLike (Path v) where
pathLike s cl segs = Path [(s, pathLike origin cl segs)]
instance HasLinearMap v => Transformable (Path v) where
transform t = (over Path . map) (transform t *** transform t)
instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Path v) where
getEnvelope = F.foldMap trailEnvelope . pathTrails
where trailEnvelope :: (Point v, Trail v) -> Envelope v
trailEnvelope (p, t) = moveOriginTo ((1) *. p) (getEnvelope t)
instance (InnerSpace v, OrderedField (Scalar v)) => Juxtaposable (Path v) where
juxtapose = juxtaposeDefault
instance (InnerSpace v, OrderedField (Scalar v)) => Alignable (Path v) where
alignBy = alignByDefault
instance HasLinearMap v => Renderable (Path v) NullBackend where
render _ _ = mempty
pathFromTrail :: AdditiveGroup v => Trail v -> Path v
pathFromTrail t = Path [(origin, t)]
pathFromTrailAt :: Trail v -> Point v -> Path v
pathFromTrailAt t p = Path [(p, t)]
pathVertices :: AdditiveGroup v => Path v -> [[Point v]]
pathVertices = map (uncurry trailVertices) . pathTrails
pathOffsets :: AdditiveGroup v => Path v -> [v]
pathOffsets = map (trailOffset . snd) . pathTrails
pathCentroid :: (VectorSpace v, Fractional (Scalar v)) => Path v -> Point v
pathCentroid = centroid . concat . pathVertices
expandPath :: (HasLinearMap v, VectorSpace v, Fractional (Scalar v), Eq (Scalar v))
=> Scalar v -> Path v -> Path v
expandPath d p = (scale d `under` translation (origin .-. pathCentroid p)) p
reversePath :: AdditiveGroup v => Path v -> Path v
reversePath = (over Path . map) reverseRootedTrail
fixPath :: AdditiveGroup v => Path v -> [[FixedSegment v]]
fixPath = map (uncurry fixTrail) . unpack
explodeTrail :: (VectorSpace (V p), PathLike p) => Point (V p) -> Trail (V p) -> [p]
explodeTrail start = snd . mapAccumL mkPath start . trailSegments'
where mkPath p seg = (p .+^ segOffset seg, pathLike p False [seg])
explodePath :: (VectorSpace (V p), PathLike p) => Path (V p) -> [[p]]
explodePath = map (uncurry explodeTrail) . pathTrails
(~~) :: PathLike p => Point (V p) -> Point (V p) -> p
p1 ~~ p2 = fromVertices [p1, p2]