{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Drawing.Shapes.Base -- Copyright : (c) Stephen Tetley 2010-2011 -- License : BSD3 -- -- Maintainer : Stephen Tetley -- Stability : highly unstable -- Portability : GHC -- -- Common core for shapes -- -- -------------------------------------------------------------------------------- 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 -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core import Data.AffineSpace -- package: vector-space import Control.Applicative -- | Shape is a record of three /LocTheta/ functions - -- functions /from Point and Angle to answer/. -- -- The @shape_path_fun@ returns a path. When the Shape is drawn, -- the rendering function (@strokedShape@, etc.) uses the path for -- drawing and returns the polymorphic answer @a@ of the -- @shape_ans_fun@. Lastly the @shape_decoration@ function can -- instantiated to add decoration (e.g. text) to the Shape as it -- is rendered. -- -- The @a@ of the @shape_ans_fun@ represents some concrete shape -- object (e.g. a Rectangle, Triangle etc.). Crucial for shape -- objects is that they support Anchors - this allows connectors -- to address specific locations on the Shape border so -- \"node and link\" diagrams can be made easily. -- 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 -- Note - there are no instances of Applicative, Monad, -- DrawingCtxM... so Shapes cannot have localized drawing props. -- -- @localize@ must be performed in the context of @strokeShape@, -- @fillShape@ etc. -- -------------------------------------------------------------------------------- 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) -- | Draw the shape path with round corners. -- 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) -- | The path angle can be modified. This allows /inverse/ -- versions of shapes (e.g. InvTriangle) to be made by -- wrapping a base Shape but rotating the path prior to drawing -- it. -- -- Only the Path needs rotating, the decoration takes the original -- angle. The anchors are typically implemented by rotating the -- correspoding anchor of the wrapped Shape about its center. -- 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 }) -- For Wumpus-Basic... -- | Move the /rotation/ of a LocThetaImage with the supplied -- displacement function. -- moveTheta :: (Radian -> Radian) -> LocThetaCF u a -> LocThetaCF u a moveTheta f ma = promoteR2 $ \pt theta -> apply2R2 ma pt (f theta) -------------------------------------------------------------------------------- -- CTM -- Note - all shapes need a location (usually/always the center) -- so this needs to be stored in the CTM. -- 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