module Wumpus.Basic.Text.LRText
(
TextM
, runTextM
, text
, char
, kern
, newline
, bracketFontFace
) where
import Wumpus.Basic.Graphic
import Wumpus.Basic.Utils.Combinators
import Wumpus.Core
import Control.Applicative
data Idx = Idx { idx_x :: !Int, idx_y :: !Int }
deriving (Eq,Ord,Show)
rightn :: Int -> Idx -> Idx
rightn n = star (\s i -> s { idx_x = i+n }) idx_x
down1 :: Idx -> Idx
down1 = star (\s i -> s { idx_y = i1, idx_x =0 }) idx_y
data St u = St
{ xy_pos :: Idx
, font_desc :: FontAttr
, horizontal_disp :: PtSize
, acc_graphic :: TGraphicF u
}
type VDist = PtSize
type Env = (VDist, DRGB)
newtype TextM u a = TextM { getTextM :: Env -> St u -> (a, St u) }
newtype TGraphicF u = TGraphicF { getTGraphicF :: GraphicF u }
consT :: Num u => (Vec2 u, GraphicF u) -> TGraphicF u -> TGraphicF u
consT (V2 x y, f) tg = TGraphicF $ (f . disp x y) `cc` (getTGraphicF tg)
instance Functor (TextM u) where
fmap f mf = TextM $ \r s -> let (a,s') = getTextM mf r s in (f a,s')
instance Applicative (TextM u) where
pure a = TextM $ \_ s -> (a,s)
mf <*> ma = TextM $ \r s -> let (f,s') = getTextM mf r s
(a,s'') = getTextM ma r s'
in (f a,s'')
instance Monad (TextM u) where
return a = TextM $ \_ s -> (a,s)
m >>= k = TextM $ \r s -> let (a,s') = getTextM m r s
in (getTextM . k) a r s'
runTextM :: (Num u, FromPtSize u)
=> PtSize -> (DRGB,FontAttr) -> (TextM u a) -> (a,GraphicF u)
runTextM vdistance (rgb,font) ma = post $ getTextM ma env st
where
post (a,s) = let gf = getTGraphicF $ acc_graphic s
h = fromIntegral $ idx_y $ xy_pos s
in (a, gf . vdisp (negate $ h * fromPtSize vdistance))
env = (vdistance,rgb)
st = St { xy_pos = Idx 0 0
, font_desc = font
, horizontal_disp = 0
, acc_graphic = TGraphicF (const emptyG) }
setFontAttr :: FontAttr -> TextM u ()
setFontAttr fa = TextM $ \_ s -> ((), s { font_desc = fa })
setsFontAttr :: (FontAttr -> FontAttr) -> TextM u ()
setsFontAttr fn = TextM $ \_ st -> ((), upd st)
where
upd = star (\s i -> s { font_desc = fn i} ) font_desc
getFontAttr :: TextM u FontAttr
getFontAttr = TextM $ \_ s -> (font_desc s,s)
makeDisplacement :: (Num u, FromPtSize u)
=> FontSize -> PtSize -> PtSize -> Idx -> (Vec2 u)
makeDisplacement font_sz lefth vdist (Idx x y) =
vec (txt_width + fromPtSize lefth)
(fromPtSize vdist * fromIntegral y)
where
txt_width = fromPtSize $ textWidth font_sz x
text :: (Num u, FromPtSize u) => String -> TextM u ()
text str = TextM $ \r s -> ((), upd r s)
where
upd (vdist,rgb) s@(St idx font h acc) =
let g1 = textline (rgb,font) str
v = makeDisplacement (font_size font) h vdist idx
in s { xy_pos = rightn (length str) idx
, acc_graphic = (v,g1) `consT` acc }
char :: (Num u, FromPtSize u) => Char -> TextM u ()
char ch = TextM $ \r s -> ((), upd r s)
where
upd (vdist,rgb) s@(St idx font h acc) =
let g1 = textline (rgb,font) [ch]
v = makeDisplacement (font_size font) h vdist idx
in s { xy_pos = rightn 1 idx
, acc_graphic = (v,g1) `consT` acc }
kern :: (Num u, FromPtSize u) => PtSize -> TextM u ()
kern h = TextM $ \_ s -> ((), upd s)
where
upd = star (\s i -> s { horizontal_disp = i + h }) horizontal_disp
newline :: TextM u ()
newline = TextM $ \_ s -> ((), upd s)
where
upd = star (\s idx -> s { xy_pos = down1 idx, horizontal_disp = 0})
xy_pos
bracketFontFace :: FontFace -> TextM u a -> TextM u a
bracketFontFace face mf = do
old <- getFontAttr
setsFontAttr fn
ans <- mf
setFontAttr old
return ans
where
fn attr = attr { font_face = face }