{-# LANGUAGE GeneralizedNewtypeDeriving #-}
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
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)
type PathWalker a = PathWalkerT Identity a
newtype WalkerState = WalkerState
{ WalkerState -> [Primitive]
_walkerPrims :: [Primitive]
}
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
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 }
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
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
type PathDrawer m px =
Transformation -> PlaneBound -> DrawOrder px -> m ()
drawOrdersOnPath :: Monad m
=> PathDrawer m px
-> Float
-> Float
-> Path
-> [DrawOrder px]
-> 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 ()
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