module Wumpus.Drawing.Shapes.Base
(
Shape
, DShape
, shapeMap
, makeShape
, strokedShape
, dblStrokedShape
, filledShape
, borderedShape
, rstrokedShape
, rfilledShape
, rborderedShape
, roundCornerShapePath
, updatePathAngle
, setDecoration
, ShapeCTM
, makeShapeCTM
, ctmCenter
, ctmAngle
, projectFromCtr
) where
import Wumpus.Drawing.Paths.Absolute
import Wumpus.Basic.Kernel
import Wumpus.Core
import Wumpus.Core.Colour ( white )
import Data.AffineSpace
import Control.Applicative
data Shape t u = Shape
{ shape_ans_fun :: LocThetaQuery u (t u)
, shape_path_fun :: LocThetaQuery u (AbsPath u)
, shape_decoration :: LocThetaGraphic u
}
type instance DUnit (Shape t u) = u
type DShape t = Shape t Double
shapeMap :: InterpretUnit u
=> (t u -> t' u) -> Shape t u -> Shape t' u
shapeMap f = (\s sf -> s { shape_ans_fun = qpromoteLocTheta $ \pt ang ->
fmap f $ qapplyLocTheta sf pt ang })
<*> shape_ans_fun
makeShape :: InterpretUnit u
=> LocThetaQuery u (t u) -> LocThetaQuery u (AbsPath u) -> Shape t u
makeShape f g = Shape { shape_ans_fun = f
, shape_path_fun = g
, shape_decoration = emptyLocThetaImage
}
strokedShape :: InterpretUnit u => Shape t u -> LocImage u (t u)
strokedShape = shapeToLoc (dcClosedPath STROKE)
dblStrokedShape :: InterpretUnit u => Shape t u -> LocImage u (t u)
dblStrokedShape sh = sdecorate back fore
where
img = shapeToLoc (dcClosedPath STROKE) sh
back = getLineWidth >>= \lw ->
localize (set_line_width $ lw * 3.0) img
fore = ignoreAns $ localize (stroke_colour white) img
filledShape :: InterpretUnit u => Shape t u -> LocImage u (t u)
filledShape = shapeToLoc (dcClosedPath FILL)
borderedShape :: InterpretUnit u => Shape t u -> LocImage u (t u)
borderedShape = shapeToLoc (dcClosedPath FILL_STROKE)
shapeToLoc :: InterpretUnit u
=> (PrimPath -> Graphic u) -> Shape t u -> LocImage u (t u)
shapeToLoc drawF sh = promoteLoc $ \pt ->
applyLocTheta (liftLocThetaQuery $ shape_ans_fun sh) pt 0 >>= \a ->
applyLocTheta (liftLocThetaQuery $ shape_path_fun sh) pt 0 >>= \spath ->
let g2 = atIncline (shape_decoration sh) pt 0
in replaceAns a (sdecorate g2 $ liftQuery (toPrimPath spath) >>= drawF)
rstrokedShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u)
rstrokedShape = shapeToLocTheta (dcClosedPath STROKE)
rfilledShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u)
rfilledShape = shapeToLocTheta (dcClosedPath FILL)
rborderedShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u)
rborderedShape = shapeToLocTheta (dcClosedPath FILL_STROKE)
shapeToLocTheta :: InterpretUnit u
=> (PrimPath -> Graphic u) -> Shape t u -> LocThetaImage u (t u)
shapeToLocTheta drawF sh = promoteLocTheta $ \pt theta ->
applyLocTheta (liftLocThetaQuery $ shape_ans_fun sh) pt theta >>= \a ->
applyLocTheta (liftLocThetaQuery $ shape_path_fun sh) pt theta >>= \spath ->
let g2 = atIncline (shape_decoration sh) pt theta
in replaceAns a $ sdecorate g2 (liftQuery (toPrimPath spath) >>= drawF)
roundCornerShapePath :: (Real u, Floating u, InterpretUnit u, Tolerance u)
=> u -> [Point2 u] -> Query u (AbsPath u)
roundCornerShapePath sz xs =
if sz `tEQ` 0 then return (vertexPath xs) else return (roundTrail sz xs)
updatePathAngle :: InterpretUnit u
=> (Radian -> Radian) -> Shape t u -> Shape t u
updatePathAngle f =
(\s fi -> s { shape_path_fun = qpromoteLocTheta $ \pt ang ->
qapplyLocTheta fi pt (mvTheta ang) })
<*> shape_path_fun
where
mvTheta = circularModulo . f
setDecoration :: LocThetaGraphic u -> Shape t u -> Shape t u
setDecoration gf = (\s -> s { shape_decoration = gf })
data ShapeCTM u = ShapeCTM
{ ctm_center :: Point2 u
, ctm_scale_x :: !Double
, ctm_scale_y :: !Double
, ctm_rotation :: Radian
}
deriving (Eq,Ord,Show)
type instance DUnit (ShapeCTM u) = u
instance Functor ShapeCTM where
fmap f = (\s i -> s { ctm_center = fmap f i }) <*> ctm_center
makeShapeCTM :: Point2 u -> Radian -> ShapeCTM u
makeShapeCTM pt ang = ShapeCTM { ctm_center = pt
, ctm_scale_x = 1
, ctm_scale_y = 1
, ctm_rotation = ang }
ctmCenter :: ShapeCTM u -> Point2 u
ctmCenter = ctm_center
ctmAngle :: ShapeCTM u -> Radian
ctmAngle = ctm_rotation
instance (Fractional u) => Scale (ShapeCTM u) where
scale sx sy = (\s x y pt -> s { ctm_scale_x = x*sx
, ctm_scale_y = y*sy
, ctm_center = scale sx sy pt })
<*> ctm_scale_x <*> ctm_scale_y <*> ctm_center
instance (Real u, Floating u) => Rotate (ShapeCTM u) where
rotate ang = (\s i pt -> let ctr = rotate ang pt
in s { ctm_rotation = circularModulo $ i+ang
, ctm_center = ctr })
<*> ctm_rotation <*> ctm_center
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 i -> s { ctm_center = translate dx dy i })
<*> ctm_center
projectFromCtr :: (Real u, Floating u) => Vec2 u -> ShapeCTM u -> Anchor u
projectFromCtr v (ShapeCTM { ctm_center = ctr
, ctm_scale_x = sx
, ctm_scale_y = sy
, ctm_rotation = theta }) =
let v1 = rotate theta $ scale sx sy $ v in ctr .+^ v1