{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Diagrams.Segment
(
Open, Closed
, Offset(..) , segOffset
, Segment(..), straight, bezier3, bézier3, reverseSegment, mapSegmentVectors
, openLinear, openCubic
, FixedSegment(..)
, mkFixedSeg, fromFixedSeg
, fixedSegIso
, SegCount(..)
, ArcLength(..)
, getArcLengthCached, getArcLengthFun, getArcLengthBounded
, TotalOffset(..)
, OffsetEnvelope(..), oeOffset, oeEnvelope
, SegMeasure
) where
import Control.Lens hiding (at, transform)
import Data.FingerTree
import Data.Monoid.MList
import Data.Semigroup
import Numeric.Interval.Kaucher (Interval (..))
import qualified Numeric.Interval.Kaucher as I
import Linear.Affine
import Linear.Metric
import Linear.Vector
import Control.Applicative
import Diagrams.Core hiding (Measured)
import Diagrams.Located
import Diagrams.Parametric
import Diagrams.Solve.Polynomial
import Data.Serialize (Serialize)
import qualified Data.Serialize as Serialize
data Open
data Closed
data Offset c v n where
OffsetOpen :: Offset Open v n
OffsetClosed :: v n -> Offset Closed v n
deriving instance Show (v n) => Show (Offset c v n)
deriving instance Eq (v n) => Eq (Offset c v n)
deriving instance Ord (v n) => Ord (Offset c v n)
instance Functor v => Functor (Offset c v) where
fmap _ OffsetOpen = OffsetOpen
fmap f (OffsetClosed v) = OffsetClosed (fmap f v)
instance Each (Offset c v n) (Offset c v' n') (v n) (v' n') where
each f (OffsetClosed v) = OffsetClosed <$> f v
each _ OffsetOpen = pure OffsetOpen
{-# INLINE each #-}
instance (Additive v, Num n) => Reversing (Offset c v n) where
reversing (OffsetClosed off) = OffsetClosed $ negated off
reversing a@OffsetOpen = a
type instance V (Offset c v n) = v
type instance N (Offset c v n) = n
instance Transformable (Offset c v n) where
transform _ OffsetOpen = OffsetOpen
transform t (OffsetClosed v) = OffsetClosed (apply t v)
data Segment c v n
= Linear !(Offset c v n)
| Cubic !(v n) !(v n) !(Offset c v n)
deriving (Functor, Eq, Ord)
instance Show (v n) => Show (Segment c v n) where
showsPrec d seg = case seg of
Linear (OffsetClosed v) -> showParen (d > 10) $
showString "straight " . showsPrec 11 v
Cubic v1 v2 (OffsetClosed v3) -> showParen (d > 10) $
showString "bézier3 " . showsPrec 11 v1 . showChar ' '
. showsPrec 11 v2 . showChar ' '
. showsPrec 11 v3
Linear OffsetOpen -> showString "openLinear"
Cubic v1 v2 OffsetOpen -> showParen (d > 10) $
showString "openCubic " . showsPrec 11 v1 . showChar ' '
. showsPrec 11 v2
instance Each (Segment c v n) (Segment c v' n') (v n) (v' n') where
each f (Linear offset) = Linear <$> each f offset
each f (Cubic v1 v2 offset) = Cubic <$> f v1 <*> f v2 <*> each f offset
{-# INLINE each #-}
instance (Additive v, Num n) => Reversing (Segment Closed v n) where
reversing = reverseSegment
mapSegmentVectors :: (v n -> v' n') -> Segment c v n -> Segment c v' n'
mapSegmentVectors = over each
type instance V (Segment c v n) = v
type instance N (Segment c v n) = n
instance Transformable (Segment c v n) where
transform = mapSegmentVectors . apply
instance Renderable (Segment c v n) NullBackend where
render _ _ = mempty
straight :: v n -> Segment Closed v n
straight = Linear . OffsetClosed
bezier3 :: v n -> v n -> v n -> Segment Closed v n
bezier3 c1 c2 x = Cubic c1 c2 (OffsetClosed x)
bézier3 :: v n -> v n -> v n -> Segment Closed v n
bézier3 = bezier3
type instance Codomain (Segment Closed v n) = v
instance (Additive v, Num n) => Parametric (Segment Closed v n) where
atParam (Linear (OffsetClosed x)) t = t *^ x
atParam (Cubic c1 c2 (OffsetClosed x2)) t = (3 * t'*t'*t ) *^ c1
^+^ (3 * t'*t *t ) *^ c2
^+^ ( t *t *t ) *^ x2
where t' = 1-t
instance Num n => DomainBounds (Segment Closed v n)
instance (Additive v, Num n) => EndValues (Segment Closed v n) where
atStart = const zero
atEnd (Linear (OffsetClosed v)) = v
atEnd (Cubic _ _ (OffsetClosed v)) = v
segOffset :: Segment Closed v n -> v n
segOffset (Linear (OffsetClosed v)) = v
segOffset (Cubic _ _ (OffsetClosed v)) = v
openLinear :: Segment Open v n
openLinear = Linear OffsetOpen
openCubic :: v n -> v n -> Segment Open v n
openCubic v1 v2 = Cubic v1 v2 OffsetOpen
instance (Metric v, OrderedField n) => Enveloped (Segment Closed v n) where
getEnvelope (s@(Linear {})) = mkEnvelope $ \v ->
maximum (map (\t -> (s `atParam` t) `dot` v) [0,1]) / quadrance v
getEnvelope (s@(Cubic c1 c2 (OffsetClosed x2))) = mkEnvelope $ \v ->
maximum .
map (\t -> ((s `atParam` t) `dot` v) / quadrance v) $
[0,1] ++
filter (liftA2 (&&) (>0) (<1))
(quadForm (3 * ((3 *^ c1 ^-^ 3 *^ c2 ^+^ x2) `dot` v))
(6 * (((-2) *^ c1 ^+^ c2) `dot` v))
((3 *^ c1) `dot` v))
instance (Additive v, Fractional n) => Sectionable (Segment Closed v n) where
splitAtParam (Linear (OffsetClosed x1)) t = (left, right)
where left = straight p
right = straight (x1 ^-^ p)
p = lerp t x1 zero
splitAtParam (Cubic c1 c2 (OffsetClosed x2)) t = (left, right)
where left = bezier3 a b e
right = bezier3 (c ^-^ e) (d ^-^ e) (x2 ^-^ e)
p = lerp t c2 c1
a = lerp t c1 zero
b = lerp t p a
d = lerp t x2 c2
c = lerp t d p
e = lerp t c b
reverseDomain = reverseSegment
reverseSegment :: (Num n, Additive v) => Segment Closed v n -> Segment Closed v n
reverseSegment (Linear (OffsetClosed v)) = straight (negated v)
reverseSegment (Cubic c1 c2 (OffsetClosed x2)) = bezier3 (c2 ^-^ x2) (c1 ^-^ x2) (negated x2)
member :: Ord a => a -> I.Interval a -> Bool
member x (I.I a b) = x >= a && x <= b
{-# INLINE member #-}
instance (Metric v, OrderedField n)
=> HasArcLength (Segment Closed v n) where
arcLengthBounded _ (Linear (OffsetClosed x1)) = I.singleton $ norm x1
arcLengthBounded m s@(Cubic c1 c2 (OffsetClosed x2))
| ub - lb < m = I lb ub
| otherwise = arcLengthBounded (m/2) l + arcLengthBounded (m/2) r
where (l,r) = s `splitAtParam` 0.5
ub = sum (map norm [c1, c2 ^-^ c1, x2 ^-^ c2])
lb = norm x2
arcLengthToParam m s _ | arcLength m s == 0 = 0.5
arcLengthToParam m s@(Linear {}) len = len / arcLength m s
arcLengthToParam m s@(Cubic {}) len
| len `member` I (-m/2) (m/2) = 0
| len < 0 = - arcLengthToParam m (fst (splitAtParam s (-1))) (-len)
| len `member` slen = 1
| len > I.sup slen = 2 * arcLengthToParam m (fst (splitAtParam s 2)) len
| len < I.sup llen = (*0.5) $ arcLengthToParam m l len
| otherwise = (+0.5) . (*0.5)
$ arcLengthToParam (9*m/10) r (len - I.midpoint llen)
where (l,r) = s `splitAtParam` 0.5
llen = arcLengthBounded (m/10) l
slen = arcLengthBounded m s
data FixedSegment v n = FLinear (Point v n) (Point v n)
| FCubic (Point v n) (Point v n) (Point v n) (Point v n)
deriving Show
type instance V (FixedSegment v n) = v
type instance N (FixedSegment v n) = n
instance Each (FixedSegment v n) (FixedSegment v' n') (Point v n) (Point v' n') where
each f (FLinear p0 p1) = FLinear <$> f p0 <*> f p1
each f (FCubic p0 p1 p2 p3) = FCubic <$> f p0 <*> f p1 <*> f p2 <*> f p3
{-# INLINE each #-}
instance Reversing (FixedSegment v n) where
reversing (FLinear p0 p1) = FLinear p1 p0
reversing (FCubic p0 p1 p2 p3) = FCubic p3 p2 p1 p0
instance (Additive v, Num n) => Transformable (FixedSegment v n) where
transform t = over each (papply t)
instance (Additive v, Num n) => HasOrigin (FixedSegment v n) where
moveOriginTo o = over each (moveOriginTo o)
instance (Metric v, OrderedField n) => Enveloped (FixedSegment v n) where
getEnvelope f = moveTo p (getEnvelope s)
where (p, s) = viewLoc $ fromFixedSeg f
instance (Metric v, OrderedField n)
=> HasArcLength (FixedSegment v n) where
arcLengthBounded m s = arcLengthBounded m (fromFixedSeg s)
arcLengthToParam m s = arcLengthToParam m (fromFixedSeg s)
mkFixedSeg :: (Num n, Additive v) => Located (Segment Closed v n) -> FixedSegment v n
mkFixedSeg ls =
case viewLoc ls of
(p, Linear (OffsetClosed v)) -> FLinear p (p .+^ v)
(p, Cubic c1 c2 (OffsetClosed x2)) -> FCubic p (p .+^ c1) (p .+^ c2) (p .+^ x2)
fromFixedSeg :: (Num n, Additive v) => FixedSegment v n -> Located (Segment Closed v n)
fromFixedSeg (FLinear p1 p2) = straight (p2 .-. p1) `at` p1
fromFixedSeg (FCubic x1 c1 c2 x2) = bezier3 (c1 .-. x1) (c2 .-. x1) (x2 .-. x1) `at` x1
fixedSegIso :: (Num n, Additive v) => Iso' (FixedSegment v n) (Located (Segment Closed v n))
fixedSegIso = iso fromFixedSeg mkFixedSeg
type instance Codomain (FixedSegment v n) = Point v
instance (Additive v, Num n) => Parametric (FixedSegment v n) where
atParam (FLinear p1 p2) t = lerp t p2 p1
atParam (FCubic x1 c1 c2 x2) t = p3
where p11 = lerp t c1 x1
p12 = lerp t c2 c1
p13 = lerp t x2 c2
p21 = lerp t p12 p11
p22 = lerp t p13 p12
p3 = lerp t p22 p21
instance Num n => DomainBounds (FixedSegment v n)
instance (Additive v, Num n) => EndValues (FixedSegment v n) where
atStart (FLinear p0 _) = p0
atStart (FCubic p0 _ _ _) = p0
atEnd (FLinear _ p1) = p1
atEnd (FCubic _ _ _ p1 ) = p1
instance (Additive v, Fractional n) => Sectionable (FixedSegment v n) where
splitAtParam (FLinear p0 p1) t = (left, right)
where left = FLinear p0 p
right = FLinear p p1
p = lerp t p1 p0
splitAtParam (FCubic p0 c1 c2 p1) t = (left, right)
where left = FCubic p0 a b cut
right = FCubic cut c d p1
a = lerp t c1 p0
p = lerp t c2 c1
d = lerp t p1 c2
b = lerp t p a
c = lerp t d p
cut = lerp t c b
reverseDomain (FLinear p0 p1) = FLinear p1 p0
reverseDomain (FCubic p0 c1 c2 p1) = FCubic p1 c2 c1 p0
newtype SegCount = SegCount (Sum Int)
deriving (Semigroup, Monoid)
instance Wrapped SegCount where
type Unwrapped SegCount = Sum Int
_Wrapped' = iso (\(SegCount x) -> x) SegCount
instance Rewrapped SegCount SegCount
newtype ArcLength n
= ArcLength (Sum (Interval n), n -> Sum (Interval n))
instance Wrapped (ArcLength n) where
type Unwrapped (ArcLength n) = (Sum (Interval n), n -> Sum (Interval n))
_Wrapped' = iso (\(ArcLength x) -> x) ArcLength
instance Rewrapped (ArcLength n) (ArcLength n')
getArcLengthCached :: ArcLength n -> Interval n
getArcLengthCached = getSum . fst . op ArcLength
getArcLengthFun :: ArcLength n -> n -> Interval n
getArcLengthFun = fmap getSum . snd . op ArcLength
getArcLengthBounded :: (Num n, Ord n)
=> n -> ArcLength n -> Interval n
getArcLengthBounded eps al
| I.width cached <= eps = cached
| otherwise = getArcLengthFun al eps
where
cached = getArcLengthCached al
deriving instance (Num n, Ord n) => Semigroup (ArcLength n)
deriving instance (Num n, Ord n) => Monoid (ArcLength n)
newtype TotalOffset v n = TotalOffset (v n)
instance Wrapped (TotalOffset v n) where
type Unwrapped (TotalOffset v n) = v n
_Wrapped' = iso (\(TotalOffset x) -> x) TotalOffset
instance Rewrapped (TotalOffset v n) (TotalOffset v' n')
instance (Num n, Additive v) => Semigroup (TotalOffset v n) where
TotalOffset v1 <> TotalOffset v2 = TotalOffset (v1 ^+^ v2)
instance (Num n, Additive v) => Monoid (TotalOffset v n) where
mempty = TotalOffset zero
mappend = (<>)
data OffsetEnvelope v n = OffsetEnvelope
{ _oeOffset :: !(TotalOffset v n)
, _oeEnvelope :: Envelope v n
}
makeLenses ''OffsetEnvelope
instance (Metric v, OrderedField n) => Semigroup (OffsetEnvelope v n) where
(OffsetEnvelope o1 e1) <> (OffsetEnvelope o2 e2)
= let !negOff = negated . op TotalOffset $ o1
e2Off = moveOriginBy negOff e2
!_unused = maybe () (\f -> f `seq` ()) $ appEnvelope e2Off
in OffsetEnvelope
(o1 <> o2)
(e1 <> e2Off)
type SegMeasure v n = SegCount
::: ArcLength n
::: OffsetEnvelope v n
::: ()
instance (Metric v, OrderedField n)
=> Measured (SegMeasure v n) (SegMeasure v n) where
measure = id
instance (OrderedField n, Metric v)
=> Measured (SegMeasure v n) (Segment Closed v n) where
measure s = (SegCount . Sum) 1
*: ArcLength ( Sum $ arcLengthBounded (stdTolerance/100) s
, Sum . flip arcLengthBounded s )
*: OffsetEnvelope (TotalOffset . segOffset $ s)
(getEnvelope s)
*: ()
instance (Serialize (v n)) => Serialize (Segment Open v n) where
{-# INLINE put #-}
put segment = case segment of
Linear OffsetOpen -> Serialize.put True
Cubic v w OffsetOpen -> do
Serialize.put False
Serialize.put v
Serialize.put w
{-# INLINE get #-}
get = do
isLinear <- Serialize.get
case isLinear of
True -> return (Linear OffsetOpen)
False -> do
v <- Serialize.get
w <- Serialize.get
return (Cubic v w OffsetOpen)
instance (Serialize (v n)) => Serialize (Segment Closed v n) where
{-# INLINE put #-}
put segment = case segment of
Linear (OffsetClosed z) -> do
Serialize.put z
Serialize.put True
Cubic v w (OffsetClosed z) -> do
Serialize.put z
Serialize.put False
Serialize.put v
Serialize.put w
{-# INLINE get #-}
get = do
z <- Serialize.get
isLinear <- Serialize.get
case isLinear of
True -> return (Linear (OffsetClosed z))
False -> do
v <- Serialize.get
w <- Serialize.get
return (Cubic v w (OffsetClosed z))