module Wumpus.Drawing.Paths.Base.RelPath
(
RelPath
, DRelPath
, empty
, line1
, curve1
, vertexPath
, curvedPath
, circular
, null
, append
, consLineTo
, snocLineTo
, consCurveTo
, snocCurveTo
, fromPathAlgVertices
, fromPathAlgCurves
, toPrimPath
, toAbsPath
, strokeRelPath
) where
import Wumpus.Drawing.Paths.Base.AbsPath ( AbsPath )
import qualified Wumpus.Drawing.Paths.Base.AbsPath as Abs
import Wumpus.Basic.Geometry
import Wumpus.Basic.Kernel
import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl, join )
import qualified Wumpus.Basic.Utils.JoinList as JL
import Wumpus.Core
import Data.AffineSpace
import qualified Data.Foldable as F
import Data.Monoid
import qualified Data.Traversable as T
import Prelude hiding ( null )
newtype RelPath u = RelPath { getRelPath :: JoinList (RelPathSeg u) }
deriving (Eq,Show)
type instance DUnit (RelPath u) = u
type DRelPath = RelPath Double
data RelPathSeg u = RelLineSeg (Vec2 u)
| RelCurveSeg (Vec2 u) (Vec2 u) (Vec2 u)
deriving (Eq,Show)
type instance DUnit (RelPathSeg u) = u
instance Functor RelPath where
fmap f = RelPath . fmap (fmap f) . getRelPath
instance Functor RelPathSeg where
fmap f (RelLineSeg v1) =
RelLineSeg (fmap f v1)
fmap f (RelCurveSeg v1 v2 v3) =
RelCurveSeg (fmap f v1) (fmap f v2) (fmap f v3)
instance Monoid (RelPath u) where
mempty = empty
mappend = append
empty :: RelPath u
empty = RelPath mempty
line1 :: Vec2 u -> RelPath u
line1 = RelPath . JL.one . RelLineSeg
curve1 :: Vec2 u -> Vec2 u -> Vec2 u -> RelPath u
curve1 v1 v2 v3 = RelPath $ JL.one $ RelCurveSeg v1 v2 v3
vertexPath :: [Vec2 u] -> RelPath u
vertexPath [] = empty
vertexPath (x:xs) = go (line1 x) xs
where
go acc [] = acc
go acc (v:vs) = go (acc `snocLineTo` v) vs
curvedPath :: [Vec2 u] -> RelPath u
curvedPath xs = case xs of
(v1:v2:v3:vs) -> go (curve1 v1 v2 v3) vs
_ -> empty
where
go acc (v1:v2:v3:vs) = go (acc `append` curve1 v1 v2 v3) vs
go acc _ = acc
circular :: Floating u => u -> RelPath u
circular = snd . fromPathAlgCurves . circlePathAlg
null :: RelPath u -> Bool
null = JL.null . getRelPath
infixr 1 `append`
append :: RelPath u -> RelPath u -> RelPath u
append (RelPath se0) (RelPath se1) = RelPath $ se0 `join` se1
consLineTo :: Vec2 u -> RelPath u -> RelPath u
consLineTo v1 (RelPath se) = RelPath $ JL.cons (RelLineSeg v1) se
snocLineTo :: RelPath u -> Vec2 u -> RelPath u
snocLineTo (RelPath se) v1 = RelPath $ JL.snoc se (RelLineSeg v1)
consCurveTo :: Vec2 u -> Vec2 u -> Vec2 u -> RelPath u -> RelPath u
consCurveTo v1 v2 v3 (RelPath se) = RelPath $ JL.cons (RelCurveSeg v1 v2 v3) se
snocCurveTo :: RelPath u -> Vec2 u -> Vec2 u -> Vec2 u -> RelPath u
snocCurveTo (RelPath se) v1 v2 v3 = RelPath $ JL.snoc se (RelCurveSeg v1 v2 v3)
fromPathAlgVertices :: Num u => PathAlg u -> (Vec2 u, RelPath u)
fromPathAlgVertices = bimap fn vertexPath . runPathAlgVec
where
fn = maybe (V2 0 0) id
fromPathAlgCurves :: Num u => PathAlg u -> (Vec2 u, RelPath u)
fromPathAlgCurves = bimap fn curvedPath . runPathAlgVec
where
fn = maybe (V2 0 0) id
toPrimPath :: InterpretUnit u => Point2 u -> RelPath u -> Query PrimPath
toPrimPath start (RelPath segs) =
uconvertCtxF start >>= \dstart ->
T.mapM uconvertCtxF segs >>= \dsegs ->
return $ relPrimPath dstart $ F.foldr fn [] dsegs
where
fn (RelLineSeg v1) ac = relLineTo v1 : ac
fn (RelCurveSeg v1 v2 v3) ac = relCurveTo v1 v2 v3 : ac
toAbsPath :: (Floating u, Ord u, Tolerance u)
=> Point2 u -> RelPath u -> AbsPath u
toAbsPath start (RelPath segs) = step1 start $ viewl segs
where
step1 p0 EmptyL = Abs.empty p0
step1 p0 (RelLineSeg v1 :< se) =
let (pth,end) = aline p0 v1 in step2 end pth (viewl se)
step1 p0 (RelCurveSeg v1 v2 v3 :< se) =
let (pth,end) = acurve p0 v1 v2 v3 in step2 end pth (viewl se)
step2 _ acc EmptyL = acc
step2 p0 acc (RelLineSeg v1 :< se) =
let (s1,end) = aline p0 v1
in step2 end (acc `Abs.append` s1) (viewl se)
step2 p0 acc (RelCurveSeg v1 v2 v3 :< se) =
let (s1,end) = acurve p0 v1 v2 v3
in step2 end (acc `Abs.append` s1) (viewl se)
aline p0 v1 =
let p1 = p0 .+^ v1 in (Abs.line1 p0 p1, p1)
acurve p0 v1 v2 v3 =
let p1 = p0 .+^ v1
p2 = p1 .+^ v2
p3 = p2 .+^ v3
in (Abs.curve1 p0 p1 p2 p3, p3)
strokeRelPath :: InterpretUnit u => RelPath u -> LocGraphic u
strokeRelPath rp =
promoteR1 $ \start -> toPrimPath start rp >>= openStroke