module Wumpus.Basic.Text.LRText
(
LRText
, runLRText
, execLRText
, kern
, char
, escInt
, escName
, symb
, symbEscInt
, symbEscName
) where
import Wumpus.Basic.Graphic
import Wumpus.Basic.SafeFonts
import Wumpus.Basic.Utils.HList
import Wumpus.Core
import Control.Applicative
import Control.Monad
import Data.Monoid
data St u = St
{ delta_chr :: !u
, delta_sym :: !u
, acc_chr :: H (KerningChar u)
, acc_sym :: H (KerningChar u)
}
data Env u = Env
{ char_width :: !u
, spacer_width :: !u
}
newtype LRText u a = LRText { getLRText :: Env u -> St u -> (a, St u) }
type instance MonUnit (LRText u) = u
instance Functor (LRText u) where
fmap f mf = LRText $ \r s -> let (a,s') = getLRText mf r s in (f a,s')
instance Applicative (LRText u) where
pure a = LRText $ \_ s -> (a,s)
mf <*> ma = LRText $ \r s -> let (f,s') = getLRText mf r s
(a,s'') = getLRText ma r s'
in (f a,s'')
instance Monad (LRText u) where
return a = LRText $ \_ s -> (a,s)
m >>= k = LRText $ \r s -> let (a,s') = getLRText m r s
in (getLRText . k) a r s'
runLRText :: (Num u, FromPtSize u) => LRText u a -> LocImage u a
runLRText ma = \pt -> envZero >>= \e1 ->
let (a,st) = getLRText ma e1 st_zero
in mkline pt (acc_chr st) >>= \g1 ->
localize (fontface symbol) (mkline pt (acc_sym st)) >>= \g2 ->
return (a,g1 `mappend` g2)
where
mkline pt h = case toListH h of
[] -> return mempty
xs -> hkernline xs pt
execLRText :: (Num u, FromPtSize u) => LRText u a -> LocGraphic u
execLRText ma = \pt -> liftM snd (runLRText ma pt)
st_zero :: Num u => St u
st_zero = St { delta_chr = 0
, delta_sym = 0
, acc_chr = emptyH
, acc_sym = emptyH }
envZero :: FromPtSize u => DrawingR (Env u)
envZero = (\sz -> Env { char_width = fromPtSize $ charWidth sz
, spacer_width = fromPtSize $ spacerWidth sz })
<$> fontSize
gets :: (St u -> a) -> LRText u a
gets fn = LRText $ \_ s -> (fn s, s)
charMove :: Num u => LRText u ()
charMove = LRText $ \(Env {char_width=cw, spacer_width=sw}) s ->
let step_width = cw + sw
d_sym = (delta_sym s) + step_width
in ((), s { delta_chr = step_width, delta_sym = d_sym })
symbMove :: Num u => LRText u ()
symbMove = LRText $ \(Env {char_width=cw, spacer_width=sw}) s ->
let step_width = cw + sw
d_chr = (delta_chr s) + step_width
in ((), s { delta_chr = d_chr, delta_sym = step_width })
snocSymb :: KerningChar u -> LRText u ()
snocSymb kc = LRText $ \_ s -> ((), upd s)
where
upd = (\s a -> s { acc_sym = a `snocH` kc}) <*> acc_sym
snocChar :: KerningChar u -> LRText u ()
snocChar kc = LRText $ \_ s -> ((), upd s)
where
upd = (\s a -> s { acc_chr = a `snocH` kc}) <*> acc_chr
kern :: Num u => u -> LRText u ()
kern dx = LRText $ \_ s -> ((), upd s)
where
upd = (\s a b -> s { delta_chr = a+dx, delta_sym = b+dx})
<*> delta_chr <*> delta_sym
char :: Num u => Char -> LRText u ()
char ch = gets delta_chr >>= \u ->
snocChar (kernchar u ch) >> charMove
escInt :: Num u => Int -> LRText u ()
escInt i = gets delta_chr >>= \u ->
snocChar (kernEscInt u i) >> charMove
escName :: Num u => String -> LRText u ()
escName s = gets delta_chr >>= \u ->
snocChar (kernEscName u s) >> charMove
symb :: Num u => Char -> LRText u ()
symb sy = gets delta_sym >>= \u ->
snocSymb (kernchar u sy) >> symbMove
symbEscInt :: Num u => Int -> LRText u ()
symbEscInt i = gets delta_sym >>= \u ->
snocSymb (kernEscInt u i) >> symbMove
symbEscName :: Num u => String -> LRText u ()
symbEscName s = gets delta_sym >>= \u ->
snocSymb (kernEscName u s) >> symbMove