{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | This module help the walking of path of any shape,

-- being able to return the current position and the

-- actual orientation.

module Graphics.Rasterific.PathWalker( PathWalkerT
                                     , PathWalker
                                     , PathDrawer
                                     , runPathWalking
                                     , advanceBy
                                     , currentPosition
                                     , currentTangeant
                                     , drawOrdersOnPath
                                     ) where

import Control.Monad.Identity( Identity )
import Control.Monad.State( StateT
                          , MonadTrans
                          , lift
                          , evalStateT
                          , modify
                          , gets )
import Data.Maybe( fromMaybe )

import Graphics.Rasterific.Types
import Graphics.Rasterific.Linear
import Graphics.Rasterific.Transformations
import Graphics.Rasterific.StrokeInternal
import Graphics.Rasterific.PlaneBoundable
import Graphics.Rasterific.Immediate

-- | The walking transformer monad.

newtype PathWalkerT m a = PathWalkerT (StateT WalkerState m a)
    deriving (Applicative (PathWalkerT m)
a -> PathWalkerT m a
Applicative (PathWalkerT m)
-> (forall a b.
    PathWalkerT m a -> (a -> PathWalkerT m b) -> PathWalkerT m b)
-> (forall a b.
    PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m b)
-> (forall a. a -> PathWalkerT m a)
-> Monad (PathWalkerT m)
PathWalkerT m a -> (a -> PathWalkerT m b) -> PathWalkerT m b
PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m b
forall a. a -> PathWalkerT m a
forall a b. PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m b
forall a b.
PathWalkerT m a -> (a -> PathWalkerT m b) -> PathWalkerT m b
forall (m :: * -> *). Monad m => Applicative (PathWalkerT m)
forall (m :: * -> *) a. Monad m => a -> PathWalkerT m a
forall (m :: * -> *) a b.
Monad m =>
PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m b
forall (m :: * -> *) a b.
Monad m =>
PathWalkerT m a -> (a -> PathWalkerT m b) -> PathWalkerT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> PathWalkerT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> PathWalkerT m a
>> :: PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m b
>>= :: PathWalkerT m a -> (a -> PathWalkerT m b) -> PathWalkerT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
PathWalkerT m a -> (a -> PathWalkerT m b) -> PathWalkerT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (PathWalkerT m)
Monad, Functor (PathWalkerT m)
a -> PathWalkerT m a
Functor (PathWalkerT m)
-> (forall a. a -> PathWalkerT m a)
-> (forall a b.
    PathWalkerT m (a -> b) -> PathWalkerT m a -> PathWalkerT m b)
-> (forall a b c.
    (a -> b -> c)
    -> PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m c)
-> (forall a b.
    PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m b)
-> (forall a b.
    PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m a)
-> Applicative (PathWalkerT m)
PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m b
PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m a
PathWalkerT m (a -> b) -> PathWalkerT m a -> PathWalkerT m b
(a -> b -> c)
-> PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m c
forall a. a -> PathWalkerT m a
forall a b. PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m a
forall a b. PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m b
forall a b.
PathWalkerT m (a -> b) -> PathWalkerT m a -> PathWalkerT m b
forall a b c.
(a -> b -> c)
-> PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m c
forall (m :: * -> *). Monad m => Functor (PathWalkerT m)
forall (m :: * -> *) a. Monad m => a -> PathWalkerT m a
forall (m :: * -> *) a b.
Monad m =>
PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m a
forall (m :: * -> *) a b.
Monad m =>
PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m b
forall (m :: * -> *) a b.
Monad m =>
PathWalkerT m (a -> b) -> PathWalkerT m a -> PathWalkerT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m a
*> :: PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m b
liftA2 :: (a -> b -> c)
-> PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> PathWalkerT m a -> PathWalkerT m b -> PathWalkerT m c
<*> :: PathWalkerT m (a -> b) -> PathWalkerT m a -> PathWalkerT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
PathWalkerT m (a -> b) -> PathWalkerT m a -> PathWalkerT m b
pure :: a -> PathWalkerT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> PathWalkerT m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (PathWalkerT m)
Applicative, a -> PathWalkerT m b -> PathWalkerT m a
(a -> b) -> PathWalkerT m a -> PathWalkerT m b
(forall a b. (a -> b) -> PathWalkerT m a -> PathWalkerT m b)
-> (forall a b. a -> PathWalkerT m b -> PathWalkerT m a)
-> Functor (PathWalkerT m)
forall a b. a -> PathWalkerT m b -> PathWalkerT m a
forall a b. (a -> b) -> PathWalkerT m a -> PathWalkerT m b
forall (m :: * -> *) a b.
Functor m =>
a -> PathWalkerT m b -> PathWalkerT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> PathWalkerT m a -> PathWalkerT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> PathWalkerT m b -> PathWalkerT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> PathWalkerT m b -> PathWalkerT m a
fmap :: (a -> b) -> PathWalkerT m a -> PathWalkerT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> PathWalkerT m a -> PathWalkerT m b
Functor, m a -> PathWalkerT m a
(forall (m :: * -> *) a. Monad m => m a -> PathWalkerT m a)
-> MonadTrans PathWalkerT
forall (m :: * -> *) a. Monad m => m a -> PathWalkerT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> PathWalkerT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> PathWalkerT m a
MonadTrans)

-- | Simpler alias if monad transformers are not

-- needed.

type PathWalker a = PathWalkerT Identity a

-- | State of the path walker, just a bunch of primitives

-- with continuity guarantee. The continuity is guaranteed

-- by the Path used to derive this primitives.

newtype WalkerState = WalkerState
    { WalkerState -> [Primitive]
_walkerPrims :: [Primitive]
    }

-- | Create a path walker from a given path

runPathWalking :: (Monad m) => Path -> PathWalkerT m a -> m a
runPathWalking :: Path -> PathWalkerT m a -> m a
runPathWalking Path
path (PathWalkerT StateT WalkerState m a
walker) = StateT WalkerState m a -> WalkerState -> m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT WalkerState m a
walker WalkerState
initialState
  where
    initialState :: WalkerState
initialState = [Primitive] -> WalkerState
WalkerState [Primitive]
primsOfPath
    primsOfPath :: [Primitive]
primsOfPath = Container Primitive -> [Primitive]
forall a. Container a -> [a]
listOfContainer
                (Container Primitive -> [Primitive])
-> ([Primitive] -> Container Primitive)
-> [Primitive]
-> [Primitive]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Container Primitive -> Container Primitive
flatten
                (Container Primitive -> Container Primitive)
-> ([Primitive] -> Container Primitive)
-> [Primitive]
-> Container Primitive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Primitive] -> Container Primitive
forall a. [a] -> Container a
containerOfList
                ([Primitive] -> [Primitive]) -> [Primitive] -> [Primitive]
forall a b. (a -> b) -> a -> b
$ Path -> [Primitive]
pathToPrimitives Path
path

-- | Advance by the given amount of pixels on the path.

advanceBy :: Monad m => Float -> PathWalkerT m ()
advanceBy :: Float -> PathWalkerT m ()
advanceBy Float
by = StateT WalkerState m () -> PathWalkerT m ()
forall (m :: * -> *) a. StateT WalkerState m a -> PathWalkerT m a
PathWalkerT (StateT WalkerState m () -> PathWalkerT m ())
-> ((WalkerState -> WalkerState) -> StateT WalkerState m ())
-> (WalkerState -> WalkerState)
-> PathWalkerT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WalkerState -> WalkerState) -> StateT WalkerState m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WalkerState -> WalkerState) -> PathWalkerT m ())
-> (WalkerState -> WalkerState) -> PathWalkerT m ()
forall a b. (a -> b) -> a -> b
$ \WalkerState
s ->
  let ([Primitive]
_, [Primitive]
leftPrimitives) = Float -> [Primitive] -> ([Primitive], [Primitive])
splitPrimitiveUntil Float
by ([Primitive] -> ([Primitive], [Primitive]))
-> [Primitive] -> ([Primitive], [Primitive])
forall a b. (a -> b) -> a -> b
$ WalkerState -> [Primitive]
_walkerPrims WalkerState
s in
  WalkerState
s { _walkerPrims :: [Primitive]
_walkerPrims = [Primitive]
leftPrimitives }

-- | Obtain the current position if we are still on the

-- path, if not, return Nothing.

currentPosition :: (Monad m) => PathWalkerT m (Maybe Point)
currentPosition :: PathWalkerT m (Maybe Point)
currentPosition = StateT WalkerState m (Maybe Point) -> PathWalkerT m (Maybe Point)
forall (m :: * -> *) a. StateT WalkerState m a -> PathWalkerT m a
PathWalkerT (StateT WalkerState m (Maybe Point) -> PathWalkerT m (Maybe Point))
-> StateT WalkerState m (Maybe Point)
-> PathWalkerT m (Maybe Point)
forall a b. (a -> b) -> a -> b
$ (WalkerState -> Maybe Point) -> StateT WalkerState m (Maybe Point)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ([Primitive] -> Maybe Point
currPos ([Primitive] -> Maybe Point)
-> (WalkerState -> [Primitive]) -> WalkerState -> Maybe Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WalkerState -> [Primitive]
_walkerPrims)
  where
    currPos :: [Primitive] -> Maybe Point
currPos [] = Maybe Point
forall a. Maybe a
Nothing
    currPos (Primitive
prim:[Primitive]
_) = Point -> Maybe Point
forall a. a -> Maybe a
Just (Point -> Maybe Point) -> Point -> Maybe Point
forall a b. (a -> b) -> a -> b
$ Primitive -> Point
firstPointOf Primitive
prim

-- | Obtain the current tangeant of the path if we're still

-- on it. Return Nothing otherwise.

currentTangeant :: (Monad m) => PathWalkerT m (Maybe Vector)
currentTangeant :: PathWalkerT m (Maybe Point)
currentTangeant = StateT WalkerState m (Maybe Point) -> PathWalkerT m (Maybe Point)
forall (m :: * -> *) a. StateT WalkerState m a -> PathWalkerT m a
PathWalkerT (StateT WalkerState m (Maybe Point) -> PathWalkerT m (Maybe Point))
-> StateT WalkerState m (Maybe Point)
-> PathWalkerT m (Maybe Point)
forall a b. (a -> b) -> a -> b
$ (WalkerState -> Maybe Point) -> StateT WalkerState m (Maybe Point)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ([Primitive] -> Maybe Point
currTangeant ([Primitive] -> Maybe Point)
-> (WalkerState -> [Primitive]) -> WalkerState -> Maybe Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WalkerState -> [Primitive]
_walkerPrims)
  where
    currTangeant :: [Primitive] -> Maybe Point
currTangeant [] = Maybe Point
forall a. Maybe a
Nothing
    currTangeant (Primitive
prim:[Primitive]
_) = Point -> Maybe Point
forall a. a -> Maybe a
Just (Point -> Maybe Point) -> (Point -> Point) -> Point -> Maybe Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Point
forall a (f :: * -> *).
(Floating a, Metric f, Epsilon a) =>
f a -> f a
normalize (Point -> Maybe Point) -> Point -> Maybe Point
forall a b. (a -> b) -> a -> b
$ Primitive -> Point
firstTangeantOf Primitive
prim

-- | Callback function in charge to transform the DrawOrder

-- given the transformation to place it on the path.

type PathDrawer m px =
    Transformation -> PlaneBound -> DrawOrder px -> m ()

-- | This function is the workhorse of the placement, it will

-- walk the path and calculate the appropriate transformation

-- for every order.

drawOrdersOnPath :: Monad m
                 => PathDrawer m px  -- ^ Function handling the placement of the order.

                 -> Float            -- ^ Starting offset

                 -> Float            -- ^ Baseline vertical position in the orders.

                 -> Path             -- ^ Path on which to place the orders.

                 -> [DrawOrder px]   -- ^ Orders to place on a path.

                 -> m ()
drawOrdersOnPath :: PathDrawer m px -> Float -> Float -> Path -> [DrawOrder px] -> m ()
drawOrdersOnPath PathDrawer m px
drawer Float
startOffset Float
baseline Path
path [DrawOrder px]
orders =
    Path -> PathWalkerT m () -> m ()
forall (m :: * -> *) a. Monad m => Path -> PathWalkerT m a -> m a
runPathWalking Path
path (PathWalkerT m () -> m ()) -> PathWalkerT m () -> m ()
forall a b. (a -> b) -> a -> b
$ Float -> PathWalkerT m ()
forall (m :: * -> *). Monad m => Float -> PathWalkerT m ()
advanceBy Float
startOffset PathWalkerT m () -> PathWalkerT m () -> PathWalkerT m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Float -> [DrawOrder px] -> PathWalkerT m ()
go Maybe Float
forall a. Maybe a
Nothing [DrawOrder px]
orders where
  go :: Maybe Float -> [DrawOrder px] -> PathWalkerT m ()
go Maybe Float
_ [] = () -> PathWalkerT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  go Maybe Float
prevX (DrawOrder px
img : [DrawOrder px]
rest) = do
    let bounds :: PlaneBound
bounds = DrawOrder px -> PlaneBound
forall a. PlaneBoundable a => a -> PlaneBound
planeBounds DrawOrder px
img
        width :: Float
width = PlaneBound -> Float
boundWidth PlaneBound
bounds
        cx :: Float
cx = Float -> Maybe Float -> Float
forall a. a -> Maybe a -> a
fromMaybe Float
startX Maybe Float
prevX
        V2 Float
startX Float
_ = PlaneBound -> Point
boundLowerLeftCorner PlaneBound
bounds
        V2 Float
endX Float
_ = PlaneBound -> Point
_planeMaxBound PlaneBound
bounds
        halfWidth :: Float
halfWidth = Float
width Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
        spaceWidth :: Float
spaceWidth = Float -> Float
forall a. Num a => a -> a
abs (Float -> Float) -> Float -> Float
forall a b. (a -> b) -> a -> b
$ Float
startX Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
cx
        translation :: Point
translation = Float -> Float -> Point
forall a. a -> a -> V2 a
V2 (Float -> Float
forall a. Num a => a -> a
negate Float
startX Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
halfWidth) (- Float
baseline)

    if PlaneBound
bounds PlaneBound -> PlaneBound -> Bool
forall a. Eq a => a -> a -> Bool
== PlaneBound
forall a. Monoid a => a
mempty then Maybe Float -> [DrawOrder px] -> PathWalkerT m ()
go Maybe Float
prevX [DrawOrder px]
rest
    else do
      Float -> PathWalkerT m ()
forall (m :: * -> *). Monad m => Float -> PathWalkerT m ()
advanceBy (Float
halfWidth Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
spaceWidth)
      Maybe Point
mayPos <- PathWalkerT m (Maybe Point)
forall (m :: * -> *). Monad m => PathWalkerT m (Maybe Point)
currentPosition
      Maybe Point
mayDir <- PathWalkerT m (Maybe Point)
forall (m :: * -> *). Monad m => PathWalkerT m (Maybe Point)
currentTangeant
      case (,) (Point -> Point -> (Point, Point))
-> Maybe Point -> Maybe (Point -> (Point, Point))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Point
mayPos Maybe (Point -> (Point, Point))
-> Maybe Point -> Maybe (Point, Point)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Point
mayDir of
        Maybe (Point, Point)
Nothing -> () -> PathWalkerT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- out of path, stop drawing

        Just (Point
pos, Point
dir) -> do
          let imageTransform :: Transformation
imageTransform =
                  Point -> Transformation
translate Point
pos Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Point -> Transformation
toNewXBase Point
dir
                                Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Point -> Transformation
translate Point
translation
          m () -> PathWalkerT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> PathWalkerT m ()) -> m () -> PathWalkerT m ()
forall a b. (a -> b) -> a -> b
$ PathDrawer m px
drawer Transformation
imageTransform PlaneBound
bounds DrawOrder px
img
          Float -> PathWalkerT m ()
forall (m :: * -> *). Monad m => Float -> PathWalkerT m ()
advanceBy Float
halfWidth
          Maybe Float -> [DrawOrder px] -> PathWalkerT m ()
go (Float -> Maybe Float
forall a. a -> Maybe a
Just Float
endX) [DrawOrder px]
rest