API for computing tangent and normal vectors to segments and trails

diagrams-lib.cabal

@@ -40,6 +40,7 @@ Library
                        Diagrams.CubicSpline,
                        Diagrams.CubicSpline.Internal,
                        Diagrams.Solve,
+                       Diagrams.Tangent,
                        Diagrams.Transform,
                        Diagrams.BoundingBox,
                        Diagrams.Names,
@@ -91,6 +92,7 @@ Library
                        pretty >= 1.0.1.2 && < 1.2,
                        newtype >= 0.2 && < 0.3,
                        fingertree >= 0.1 && < 0.2,
-                       intervals >= 0.2.2 && < 0.3
+                       intervals >= 0.2.2 && < 0.3,
+                       lens >= 3.9 && < 3.10
   Hs-source-dirs:      src
   default-language:    Haskell2010

src/Diagrams/Tangent.hs

@@ -0,0 +1,188 @@
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE GADTs                #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Diagrams.Tangent
+-- Copyright   :  (c) 2013 diagrams-lib team (see LICENSE)
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  diagrams-discuss@googlegroups.com
+--
+-- Computing tangent and normal vectors for segments and trails.
+--
+-----------------------------------------------------------------------------
+module Diagrams.Tangent
+    ( tangentAtParam
+    , tangentAtStart
+    , tangentAtEnd
+    , normalAtParam
+    , normalAtStart
+    , normalAtEnd
+    , Tangent(..)
+    )
+    where
+
+import           Control.Lens         (cloneIso, (^.))
+
+import           Data.VectorSpace
+import           Diagrams.Core
+import           Diagrams.Located
+import           Diagrams.Parametric
+import           Diagrams.Segment
+import           Diagrams.Trail
+import           Diagrams.TwoD.Types  (R2)
+import           Diagrams.TwoD.Vector (perp)
+
+------------------------------------------------------------
+-- Tangent
+------------------------------------------------------------
+
+-- | A newtype wrapper used to give different instances of
+--   'Parametric' and 'EndValues' that compute tangent vectors.
+newtype Tangent t = Tangent t
+
+type instance V (Tangent t) = V t
+
+instance DomainBounds t => DomainBounds (Tangent t) where
+  domainLower (Tangent t) = domainLower t
+  domainUpper (Tangent t) = domainUpper t
+
+type instance Codomain (Tangent (Located t)) = Codomain (Tangent t)
+
+instance Parametric (Tangent t) => Parametric (Tangent (Located t)) where
+  Tangent l `atParam` p = Tangent (unLoc l) `atParam` p
+
+instance (DomainBounds t, EndValues (Tangent t))
+    => EndValues (Tangent (Located t)) where
+  atStart (Tangent l) = atStart (Tangent (unLoc l))
+  atEnd   (Tangent l) = atEnd   (Tangent (unLoc l))
+
+-- | Compute the tangent vector to a segment or trail at a particular
+--   parameter.
+--
+--   Examples of more specific types this function can have include
+--
+--   * @Segment Closed R2 -> Double -> R2@
+--
+--   * @Trail' Line R2 -> Double -> R2@
+--
+--   * @Located (Trail R2) -> Double -> R2@
+--
+--   See the instances listed for the 'Tangent' newtype for more.
+tangentAtParam :: Parametric (Tangent t) => t -> Scalar (V t) -> Codomain (Tangent t)
+tangentAtParam t p = Tangent t `atParam` p
+
+-- | Compute the tangent vector at the start of a segment or trail.
+tangentAtStart :: EndValues (Tangent t) => t -> Codomain (Tangent t)
+tangentAtStart = atStart . Tangent
+
+-- | Compute the tangent vector at the end of a segment or trail.
+tangentAtEnd :: EndValues (Tangent t) => t -> Codomain (Tangent t)
+tangentAtEnd = atEnd . Tangent
+
+--------------------------------------------------
+-- Segment
+
+type instance Codomain (Tangent (Segment Closed v)) = Codomain (Segment Closed v)
+
+instance (VectorSpace v, Num (Scalar v))
+    => Parametric (Tangent (Segment Closed v)) where
+  Tangent (Linear (OffsetClosed v)) `atParam` _ = v
+  Tangent (Cubic c1 c2 (OffsetClosed x2)) `atParam` p
+    = (3*(3*p*p-4*p+1))*^c1 ^+^ (3*(2-3*p)*p)*^c2 ^+^ (3*p*p)*^x2
+
+instance (VectorSpace v, Num (Scalar v))
+    => EndValues (Tangent (Segment Closed v)) where
+  atStart (Tangent (Linear (OffsetClosed v)))      = v
+  atStart (Tangent (Cubic c1 _ _))                 = c1
+  atEnd   (Tangent (Linear (OffsetClosed v)))      = v
+  atEnd   (Tangent (Cubic _ c2 (OffsetClosed x2))) = x2 ^-^ c2
+
+--------------------------------------------------
+-- Trail' and Trail
+
+type instance Codomain (Tangent (Trail' c v)) = Codomain (Trail' c v)
+
+instance ( Parametric (GetSegment (Trail' c v))
+         , VectorSpace v
+         , Num (Scalar v)
+         )
+    => Parametric (Tangent (Trail' c v)) where
+  Tangent tr `atParam` p =
+    case GetSegment tr `atParam` p of
+      Nothing                -> zeroV
+      Just (_, seg, reparam) -> Tangent seg `atParam` (p ^. cloneIso reparam)
+
+instance ( Parametric (GetSegment (Trail' c v))
+         , EndValues (GetSegment (Trail' c v))
+         , VectorSpace v
+         , Num (Scalar v)
+         )
+    => EndValues (Tangent (Trail' c v)) where
+  atStart (Tangent tr) =
+    case atStart (GetSegment tr) of
+      Nothing          -> zeroV
+      Just (_, seg, _) -> atStart (Tangent seg)
+  atEnd (Tangent tr) =
+    case atEnd (GetSegment tr) of
+      Nothing          -> zeroV
+      Just (_, seg, _) -> atEnd (Tangent seg)
+
+type instance Codomain (Tangent (Trail v)) = Codomain (Trail v)
+
+instance ( InnerSpace v
+         , OrderedField (Scalar v)
+         , RealFrac (Scalar v)
+         )
+    => Parametric (Tangent (Trail v)) where
+  Tangent tr `atParam` p
+    = withTrail
+        ((`atParam` p) . Tangent)
+        ((`atParam` p) . Tangent)
+        tr
+
+instance ( InnerSpace v
+         , OrderedField (Scalar v)
+         , RealFrac (Scalar v)
+         )
+    => EndValues (Tangent (Trail v)) where
+  atStart (Tangent tr) = withTrail (atStart . Tangent) (atStart . Tangent) tr
+  atEnd   (Tangent tr) = withTrail (atEnd   . Tangent) (atEnd   . Tangent) tr
+
+------------------------------------------------------------
+-- Normal
+------------------------------------------------------------
+
+-- | Compute the (unit) normal vector to a segment or trail at a
+--   particular parameter.
+--
+--   Examples of more specific types this function can have include
+--
+--   * @Segment Closed R2 -> Double -> R2@
+--
+--   * @Trail' Line R2 -> Double -> R2@
+--
+--   * @Located (Trail R2) -> Double -> P2@
+--
+--   See the instances listed for the 'Tangent' newtype for more.
+normalAtParam
+  :: (Codomain (Tangent t) ~ R2, Parametric (Tangent t))
+  => t -> Scalar (V t) -> R2
+normalAtParam t p = normize (t `tangentAtParam` p)
+
+-- | Compute the normal vector at the start of a segment or trail.
+normalAtStart
+  :: (Codomain (Tangent t) ~ R2, EndValues (Tangent t))
+  => t -> R2
+normalAtStart = normize . tangentAtStart
+
+-- | Compute the normal vector at the end of a segment or trail.
+normalAtEnd
+  :: (Codomain (Tangent t) ~ R2, EndValues (Tangent t))
+  => t -> R2
+normalAtEnd = normize . tangentAtEnd
+
+normize = negateV . perp . normalized

src/Diagrams/Trail.hs

@@ -91,9 +91,14 @@ module Diagrams.Trail
 
        , SegTree(..), trailMeasure, numSegs, offset
 
+         -- ** Extracting segments
+
+       , GetSegment(..), getSegment
+
        ) where
 
 import           Control.Arrow       ((***))
+import           Control.Lens        (AnIso', iso)
 import           Data.AffineSpace
 import           Data.FingerTree     (FingerTree, ViewL (..), ViewR (..), (<|),
                                       (|>))
@@ -376,12 +381,17 @@ instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v))
     => Parametric (Trail' l v) where
   atParam t p = withTrail'
                   (\(Line segT) -> segT `atParam` p)
-                  (\l -> cutLoop l `atParam` p')
+                  (\l -> cutLoop l `atParam` mod1 p)
                   t
-    where
-      pf = snd . properFraction $ p
-      p' | p >= 0    = pf
-         | otherwise = 1 + pf
+
+-- | Compute the remainder mod 1.  Convenient for constructing loop
+--   parameterizations that wrap around.
+mod1 :: RealFrac a => a -> a
+mod1 p = p'
+ where
+   pf = snd . properFraction $ p
+   p' | p >= 0    = pf
+      | otherwise = 1 + pf
 
 instance Num (Scalar v) => DomainBounds (Trail' l v)
 
@@ -409,6 +419,133 @@ instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v))
       (\lp -> arcLengthToParam eps (cutLoop lp) l)
       tr
 
+--------------------------------------------------
+-- Extracting segments
+
+-- | A newtype wrapper around trails which exists solely for its
+--   'Parametric', 'DomainBounds' and 'EndValues' instances.  The idea
+--   is that if @tr@ is a trail, you can write, /e.g./
+--
+--   > getSegment tr `atParam` 0.6
+--
+--   or
+--
+--   > atStart (getSegment tr)
+--
+--   to get the segment at parameter 0.6 or the first segment in the
+--   trail, respectively.
+--
+--   The codomain for 'GetSegment', /i.e./ the result you get from
+--   calling 'atParam', 'atStart', or 'atEnd', is @Maybe (v, Segment
+--   Closed v, AnIso' (Scalar v) (Scalar v))@.  @Nothing@ results if
+--   the trail is empty; otherwise, you get:
+--
+--   * the offset from the start of the trail to the beginning of the
+--     segment,
+--
+--   * the segment itself, and
+--
+--   * a reparameterization isomorphism: in the forward direction, it
+--     translates from parameters on the whole trail to a parameters
+--     on the segment.  Note that for technical reasons you have to
+--     call 'cloneIso' on the @AnIso'@ value to get a real isomorphism
+--     you can use.
+newtype GetSegment t = GetSegment t
+
+-- | Create a 'GetSegment' wrapper around a trail, after which you can
+--   call 'atParam', 'atStart', or 'atEnd' to extract a segment.
+getSegment :: t -> GetSegment t
+getSegment = GetSegment
+
+type instance V (GetSegment t) = V t
+type instance Codomain (GetSegment t)
+  = Maybe
+    ( V t                                   -- offset from trail start to segment start
+    , Segment Closed (V t)                  -- the segment
+    , AnIso' (Scalar (V t)) (Scalar (V t))  -- reparameterization, trail <-> segment
+    )
+
+-- | Parameters less than 0 yield the first segment; parameters
+--   greater than 1 yield the last.  A parameter exactly at the
+--   junction of two segments yields the second segment (/i.e./ the
+--   one with higher parameter values).
+instance (InnerSpace v, OrderedField (Scalar v))
+    => Parametric (GetSegment (Trail' Line v)) where
+  atParam (GetSegment (Line (SegTree ft))) p
+    | p <= 0
+    = case FT.viewl ft of
+        EmptyL    -> Nothing
+        seg :< _  -> Just (zeroV, seg, reparam 0)
+
+    | p >= 1
+    = case FT.viewr ft of
+        EmptyR     -> Nothing
+        ft' :> seg -> Just (offset ft', seg, reparam (n-1))
+
+    | otherwise
+    = let (before, after) = FT.split ((p*n <) . numSegs) $ ft
+      in  case FT.viewl after of
+            EmptyL   -> Nothing
+            seg :< _ -> Just (offset before, seg, reparam (numSegs before))
+    where
+      n = numSegs ft
+      reparam k = iso (subtract k . (*n))
+                      ((/n) . (+ k))
+
+-- | The parameterization for loops wraps around, /i.e./ parameters
+--   are first reduced \"mod 1\".
+instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v))
+    => Parametric (GetSegment (Trail' Loop v)) where
+  atParam (GetSegment l) p = atParam (GetSegment (cutLoop l)) (mod1 p)
+
+instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v))
+    => Parametric (GetSegment (Trail v)) where
+  atParam (GetSegment t) p
+    = withTrail
+      ((`atParam` p) . GetSegment)
+      ((`atParam` p) . GetSegment)
+      t
+
+instance DomainBounds t => DomainBounds (GetSegment t) where
+  domainLower (GetSegment t) = domainLower t
+  domainUpper (GetSegment t) = domainUpper t
+
+instance (InnerSpace v, OrderedField (Scalar v))
+    => EndValues (GetSegment (Trail' Line v)) where
+  atStart (GetSegment (Line (SegTree ft)))
+    = case FT.viewl ft of
+        EmptyL   -> Nothing
+        seg :< _ ->
+          let n = numSegs ft
+          in  Just (zeroV, seg, iso (*n) (/n))
+
+  atEnd (GetSegment (Line (SegTree ft)))
+    = case FT.viewr ft of
+        EmptyR     -> Nothing
+        ft' :> seg ->
+          let n = numSegs ft
+          in  Just (offset ft', seg, iso (subtract (n-1) . (*n))
+                                         ((/n) . (+ (n-1)))
+                   )
+
+instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v))
+    => EndValues (GetSegment (Trail' Loop v)) where
+  atStart (GetSegment l) = atStart (GetSegment (cutLoop l))
+  atEnd   (GetSegment l) = atEnd   (GetSegment (cutLoop l))
+
+instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v))
+    => EndValues (GetSegment (Trail v)) where
+  atStart (GetSegment t)
+    = withTrail
+      (\l -> atStart (GetSegment l))
+      (\l -> atStart (GetSegment l))
+      t
+  atEnd (GetSegment t)
+    = withTrail
+      (\l -> atEnd (GetSegment l))
+      (\l -> atEnd (GetSegment l))
+      t
+
 --------------------------------------------------
 -- The Trail type