module Wumpus.Drawing.Shapes.Base
(
Shape
, DShape
, makeShape
, strokedShape
, filledShape
, borderedShape
, rstrokedShape
, rfilledShape
, rborderedShape
, roundCornerShapePath
, updatePathAngle
, setDecoration
, ShapeCTM
, makeShapeCTM
, ctmCenter
, ctmAngle
, displaceCenter
) where
import Wumpus.Drawing.Paths
import Wumpus.Basic.Kernel
import Wumpus.Core
import Data.AffineSpace
import Control.Applicative
data Shape u a = Shape
{ shape_ans_fun :: LocThetaCF u a
, shape_path_fun :: LocThetaCF u (Path u)
, shape_decoration :: LocThetaGraphic u
}
type DShape a = Shape Double a
type instance DUnit (Shape u a) = u
instance Functor (Shape u) where
fmap f = (\s i -> s { shape_ans_fun = fmap f i })
<*> shape_ans_fun
makeShape :: Num u => LocThetaCF u a -> LocThetaCF u (Path u) -> Shape u a
makeShape f g = Shape { shape_ans_fun = f
, shape_path_fun = g
, shape_decoration = emptyLocThetaGraphic
}
strokedShape :: Num u => Shape u a -> LocImage u a
strokedShape = shapeToLoc closedStroke
filledShape :: Num u => Shape u a -> LocImage u a
filledShape = shapeToLoc filledPath
borderedShape :: Num u => Shape u a -> LocImage u a
borderedShape = shapeToLoc borderedPath
shapeToLoc :: Num u
=> (PrimPath u -> Graphic u) -> Shape u a -> LocImage u a
shapeToLoc pathF sh = promoteR1 $ \pt ->
atRot (shape_ans_fun sh) pt 0 >>= \a ->
atRot (shape_path_fun sh) pt 0 >>= \spath ->
let g1 = pathF $ toPrimPath spath
g2 = atRot (shape_decoration sh) pt 0
in intoImage (pure a) (g1 `oplus` g2)
rstrokedShape :: Num u => Shape u a -> LocThetaImage u a
rstrokedShape = shapeToLocTheta closedStroke
rfilledShape :: Num u => Shape u a -> LocThetaImage u a
rfilledShape = shapeToLocTheta filledPath
rborderedShape :: Num u => Shape u a -> LocThetaImage u a
rborderedShape = shapeToLocTheta borderedPath
shapeToLocTheta :: Num u
=> (PrimPath u -> Graphic u) -> Shape u a -> LocThetaImage u a
shapeToLocTheta pathF sh = promoteR2 $ \pt theta ->
atRot (shape_ans_fun sh) pt theta >>= \a ->
atRot (shape_path_fun sh) pt theta >>= \spath ->
let g1 = pathF $ toPrimPath spath
g2 = atRot (shape_decoration sh) pt theta
in intoImage (pure a) (g1 `oplus` g2)
roundCornerShapePath :: (Real u, Floating u, FromPtSize u)
=> [Point2 u] -> CF (Path u)
roundCornerShapePath xs = getRoundCornerSize >>= \sz ->
if sz == 0 then return (traceLinePoints xs)
else return (roundTrail sz xs)
updatePathAngle :: (Radian -> Radian) -> Shape u a -> Shape u a
updatePathAngle f =
(\s i -> s { shape_path_fun = moveTheta (circularModulo . f) i})
<*> shape_path_fun
setDecoration :: LocThetaGraphic u -> Shape u a -> Shape u a
setDecoration gf = (\s -> s { shape_decoration = gf })
moveTheta :: (Radian -> Radian) -> LocThetaCF u a -> LocThetaCF u a
moveTheta f ma = promoteR2 $ \pt theta -> apply2R2 ma pt (f theta)
data ShapeCTM u = ShapeCTM
{ ctm_center :: Point2 u
, ctm_scale_x :: !u
, ctm_scale_y :: !u
, ctm_rotation :: Radian
}
deriving (Eq,Ord,Show)
type instance DUnit (ShapeCTM u) = u
makeShapeCTM :: Num u => Point2 u -> Radian -> ShapeCTM u
makeShapeCTM pt ang = ShapeCTM { ctm_center = pt
, ctm_scale_x = 1
, ctm_scale_y = 1
, ctm_rotation = ang }
instance Num u => Scale (ShapeCTM u) where
scale sx sy = (\s x y -> s { ctm_scale_x = x*sx, ctm_scale_y = y*sy })
<*> ctm_scale_x <*> ctm_scale_y
instance Rotate (ShapeCTM u) where
rotate ang = (\s i -> s { ctm_rotation = circularModulo $ i+ang })
<*> ctm_rotation
instance (Real u, Floating u) => RotateAbout (ShapeCTM u) where
rotateAbout ang pt =
(\s ctr i -> s { ctm_rotation = circularModulo $ i+ang
, ctm_center = rotateAbout ang pt ctr })
<*> ctm_center <*> ctm_rotation
instance Num u => Translate (ShapeCTM u) where
translate dx dy = (\s (P2 x y) -> s { ctm_center = P2 (x+dx) (y+dy) })
<*> ctm_center
ctmCenter :: ShapeCTM u -> Point2 u
ctmCenter = ctm_center
ctmAngle :: ShapeCTM u -> Radian
ctmAngle = ctm_rotation
displaceCenter :: (Real u, Floating u) => Vec2 u -> ShapeCTM u -> Point2 u
displaceCenter v0 (ShapeCTM { ctm_center = ctr0
, ctm_scale_x = sx
, ctm_scale_y = sy
, ctm_rotation = theta }) = ctr .+^ v
where
ctr = rotate theta $ scale sx sy ctr0
v = rotateAbout theta ctr $ scale sx sy v0