module Wumpus.Basic.Shapes.Base
(
Shape(..)
, drawShape
, ShapeCTM(..)
, identityCTM
, ctmDisplace
, ctmCenter
, ShapeLabel
, runShapeLabel
, nolabel
, shapelabel
) where
import Wumpus.Basic.Graphic
import Wumpus.Core
import Data.AffineSpace
import Control.Applicative
import Data.Monoid
data Shape u sh = Shape
{ src_ctm :: ShapeCTM u
, out_fun :: ShapeCTM u -> Image u sh
}
type instance DUnit (Shape u sh) = u
drawShape :: Shape u sh -> Image u sh
drawShape (Shape { src_ctm = ctm, out_fun = fn }) = fn ctm
instance (Real u, Floating u) => Rotate (Shape u sh) where
rotate r = updateCTM (rotateCTM r)
instance Num u => Scale (Shape u sh) where
scale x y = updateCTM (scaleCTM x y)
instance Num u => Translate (Shape u sh) where
translate x y = updateCTM (translateCTM x y)
updateCTM :: (ShapeCTM u -> ShapeCTM u) -> Shape u sh -> Shape u sh
updateCTM fn (Shape ctm out) = Shape (fn ctm) out
data ShapeCTM u = ShapeCTM
{ ctm_trans_x :: !u
, ctm_trans_y :: !u
, ctm_scale_x :: !u
, ctm_scale_y :: !u
, ctm_rotation :: Radian
}
deriving (Eq,Show)
type instance DUnit (ShapeCTM u) = u
identityCTM :: Num u => ShapeCTM u
identityCTM = ShapeCTM { ctm_trans_x = 0
, ctm_trans_y = 0
, ctm_scale_x = 1
, ctm_scale_y = 1
, ctm_rotation = 0 }
scaleCTM :: Num u => u -> u -> ShapeCTM u -> ShapeCTM u
scaleCTM sx sy =
(\s x y -> s { ctm_scale_x = x*sx, ctm_scale_y = y*sy })
<*> ctm_scale_x <*> ctm_scale_y
rotateCTM :: Radian -> ShapeCTM u -> ShapeCTM u
rotateCTM ang1 =
(\s ang -> s { ctm_rotation = circularModulo $ ang1+ang })
<*> ctm_rotation
translateCTM :: Num u => u -> u -> ShapeCTM u -> ShapeCTM u
translateCTM dx dy =
(\s x y -> s { ctm_trans_x = x+dx, ctm_trans_y = y+dy })
<*> ctm_trans_x <*> ctm_trans_y
ctmDisplace :: (Real u, Floating u) => Point2 u -> ShapeCTM u -> Point2 u
ctmDisplace (P2 x y) (ShapeCTM { ctm_trans_x = dx, ctm_trans_y = dy
, ctm_scale_x = sx, ctm_scale_y = sy
, ctm_rotation = theta }) =
translate dx dy $ rotate theta $ P2 (sx*x) (sy*y)
ctmCenter :: (Real u, Floating u) => ShapeCTM u -> Point2 u
ctmCenter = ctmDisplace zeroPt
newtype ShapeLabel u = ShapeLabel { getShapeLabel :: ShapeCTM u -> Graphic u }
runShapeLabel :: ShapeCTM u -> ShapeLabel u -> Graphic u
runShapeLabel ctm sl = getShapeLabel sl ctm
nolabel :: ShapeLabel u
nolabel = ShapeLabel $ \_ -> mempty
shapelabel :: (Real u, Floating u, FromPtSize u)
=> String -> ShapeLabel u
shapelabel text =
ShapeLabel $ \(ShapeCTM { ctm_trans_x=dx, ctm_trans_y=dy
, ctm_rotation = ang }) ->
monoVecToCenter text >>= \v ->
let ctr = P2 dx dy; bl = ctr .-^ v in
rotTextline ang text (rotateAbout ang ctr bl)
rotTextline :: (Real u, Floating u) => Radian -> String -> LocGraphic u
rotTextline theta ss baseline_left =
withTextAttr $ \rgb attr ->
singleH $ rotatePrim theta $ textlabel rgb attr ss baseline_left