module Wumpus.Basic.Shapes.Plaintext
(
PlaintextAnchor
, DPlaintextAnchor
, Plaintext
, DPlaintext
, plaintext
, drawText
) where
import Wumpus.Basic.Anchors
import Wumpus.Basic.Graphic
import Wumpus.Basic.Shapes.Base
import Wumpus.Basic.Shapes.Derived
import Wumpus.Core
import Data.AffineSpace
import Control.Applicative
newtype PlaintextAnchor u = PlaintextAnchor { getPlaintext :: Rectangle u }
type DPlaintextAnchor = PlaintextAnchor Double
type instance DUnit (PlaintextAnchor u) = u
data Plaintext u = Plaintext
{ text_text :: String
, text_x :: !u
, text_y :: !u
, text_ang :: !Radian
}
deriving (Eq,Ord,Show)
type DPlaintext = Plaintext Double
type instance DUnit (Plaintext u) = u
instance (Real u, Floating u) => CenterAnchor (PlaintextAnchor u) where
center = center . getPlaintext
instance (Real u, Floating u) => CardinalAnchor (PlaintextAnchor u) where
north = north . getPlaintext
south = south . getPlaintext
east = east . getPlaintext
west = west . getPlaintext
instance (Real u, Floating u) => CardinalAnchor2 (PlaintextAnchor u) where
northeast = northeast . getPlaintext
southeast = southeast . getPlaintext
southwest = southwest . getPlaintext
northwest = northwest . getPlaintext
instance (Real u, Floating u) => RadialAnchor (PlaintextAnchor u) where
radialAnchor theta = radialAnchor theta . getPlaintext
instance Rotate (Plaintext u) where
rotate dr = (\s i -> s { text_ang = i+dr }) <*> text_ang
instance Num u => Translate (Plaintext u) where
translate dx dy = (\s x y -> s { text_x = x+dx, text_y = y+dy })
<*> text_x <*> text_y
plaintext :: Num u => String -> Plaintext u
plaintext ss = Plaintext { text_text = ss
, text_x = 0
, text_y = 0
, text_ang = 0 }
drawText :: (Real u, Floating u, FromPtSize u)
=> Plaintext u -> Image u (PlaintextAnchor u)
drawText x = intoImage (oneLineRect x) (drawOneLine x)
oneLineRect :: (Fractional u, Ord u, FromPtSize u)
=> Plaintext u -> DrawingR (PlaintextAnchor u)
oneLineRect ptext =
monoTextDimensions (text_text ptext) >>= \(w,h) ->
return (PlaintextAnchor $ mkRectangle (0.5*w) (0.5*h) ctm)
where
ctm = ShapeCTM { ctm_trans_x = text_x ptext
, ctm_trans_y = text_y ptext
, ctm_scale_x = 1
, ctm_scale_y = 1
, ctm_rotation = text_ang ptext
}
drawOneLine :: (Real u, Floating u, FromPtSize u)
=> Plaintext u -> Graphic u
drawOneLine (Plaintext { text_text = ss, text_x=dx, text_y=dy
, text_ang = ang }) =
monoVecToCenter ss >>= \v ->
let ctr = P2 dx dy; bl = ctr .-^ v in
rotTextline ang ss (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