{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Graphics.Rasterific.PathWalker( PathWalkerT
, PathWalker
, PathDrawer
, runPathWalking
, advanceBy
, currentPosition
, currentTangeant
, drawOrdersOnPath
) where
import Data.Monoid( (<>) )
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 (Monad, Applicative, Functor, MonadTrans)
type PathWalker a = PathWalkerT Identity a
newtype WalkerState = WalkerState
{ _walkerPrims :: [Primitive]
}
runPathWalking :: (Monad m) => Path -> PathWalkerT m a -> m a
runPathWalking path (PathWalkerT walker) = evalStateT walker initialState
where
initialState = WalkerState primsOfPath
primsOfPath = listOfContainer
. flatten
. containerOfList
$ pathToPrimitives path
advanceBy :: Monad m => Float -> PathWalkerT m ()
advanceBy by = PathWalkerT . modify $ \s ->
let (_, leftPrimitives) = splitPrimitiveUntil by $ _walkerPrims s in
s { _walkerPrims = leftPrimitives }
currentPosition :: (Monad m) => PathWalkerT m (Maybe Point)
currentPosition = PathWalkerT $ gets (currPos . _walkerPrims)
where
currPos [] = Nothing
currPos (prim:_) = Just $ firstPointOf prim
currentTangeant :: (Monad m) => PathWalkerT m (Maybe Vector)
currentTangeant = PathWalkerT $ gets (currTangeant . _walkerPrims)
where
currTangeant [] = Nothing
currTangeant (prim:_) = Just . normalize $ firstTangeantOf prim
type PathDrawer m px =
Transformation -> PlaneBound -> DrawOrder px -> m ()
drawOrdersOnPath :: Monad m
=> PathDrawer m px
-> Float
-> Float
-> Path
-> [DrawOrder px]
-> m ()
drawOrdersOnPath drawer startOffset baseline path orders =
runPathWalking path $ advanceBy startOffset >> go Nothing orders where
go _ [] = return ()
go prevX (img : rest) = do
let bounds = planeBounds img
width = boundWidth bounds
cx = fromMaybe startX prevX
V2 startX _ = boundLowerLeftCorner bounds
V2 endX _ = _planeMaxBound bounds
halfWidth = width / 2
spaceWidth = abs $ startX - cx
translation = V2 (negate startX - halfWidth) (- baseline)
if bounds == mempty then go prevX rest
else do
advanceBy (halfWidth + spaceWidth)
mayPos <- currentPosition
mayDir <- currentTangeant
case (,) <$> mayPos <*> mayDir of
Nothing -> return ()
Just (pos, dir) -> do
let imageTransform =
translate pos <> toNewXBase dir
<> translate translation
lift $ drawer imageTransform bounds img
advanceBy halfWidth
go (Just endX) rest