149 lines
4.0 KiB
Haskell
149 lines
4.0 KiB
Haskell
module GlyphsBase (module GlyphsBase, module Svg) where
|
|
|
|
import Svg hiding (shiftX, shiftY, shift, width, size)
|
|
import qualified Svg
|
|
|
|
import Prelude hiding (Word)
|
|
import Data.Foldable
|
|
import Numeric
|
|
import Prelude hiding (Word)
|
|
|
|
|
|
data Glyph = G {path :: Segs, width :: Double}
|
|
|
|
-- | base amounts
|
|
charHeight', lineHeight', spaceWidth', gap' :: Double
|
|
charHeight' = 13
|
|
lineHeight' = 15
|
|
spaceWidth' = 4
|
|
gap' = 1.5
|
|
|
|
withSize :: MonadReader Env m => (Double -> a) -> m a
|
|
withSize f = asks \E {size} -> f size
|
|
|
|
-- | multiplied by size
|
|
charHeight, lineHeight, spaceWidth, margin, gap :: MonadReader Env m => m Double
|
|
charHeight = withSize (* charHeight')
|
|
lineHeight = withSize (* lineHeight')
|
|
spaceWidth = withSize (* spaceWidth')
|
|
margin = asks \E {stroke} -> stroke
|
|
gap = withSize (* gap')
|
|
|
|
data Segs = P [M Text] | Shift !Double !Double Segs | Segs :<>: Segs
|
|
|
|
instance Semigroup Segs where
|
|
P [] <> s = s
|
|
s <> P [] = s
|
|
P ss <> P ts = P $ ss <> ts
|
|
s <> t = s :<>: t
|
|
|
|
instance Monoid Segs where
|
|
mempty = P []
|
|
mappend = (<>)
|
|
|
|
joinSegs :: Segs -> M Text
|
|
joinSegs (P ps) = fmap mconcat $ sequence ps
|
|
joinSegs (Shift dx dy segs) = do
|
|
E {size} <- ask
|
|
localS (Svg.shift (size * dx, size * dy)) $ joinSegs segs
|
|
joinSegs (ss1 :<>: ss2) = liftM2 (<>) (joinSegs ss1) (joinSegs ss2)
|
|
|
|
localS :: MonadState s m => (s -> s) -> m a -> m a
|
|
localS f m = do old <- get; modify f; res <- m; put old; pure res
|
|
|
|
shiftX, shiftY :: Double -> Segs -> Segs
|
|
shiftX dx = Shift dx 0
|
|
shiftY dy = Shift 0 dy
|
|
|
|
space :: M ()
|
|
space = do
|
|
swidth <- spaceWidth
|
|
modify \s@(S {x}) -> s {x = x + swidth}
|
|
|
|
|
|
data TextSize = T {width, height :: !Double}
|
|
|
|
run :: M a -> Env -> (a, TextSize)
|
|
run m e@(E {size}) =
|
|
let (res, S {..}) = runState (runReaderT m e) s in
|
|
(res, T {width = textWidth, height = textHeight})
|
|
where
|
|
margin' = runReader margin e
|
|
ascHeight = size * 3
|
|
s = S {x = margin', y = margin' + ascHeight,
|
|
textWidth = 0, textHeight = 0, firstOnLine = True}
|
|
|
|
|
|
type Word = [EGlyph]
|
|
|
|
type EGlyph = (Glyph, [Diacritic])
|
|
|
|
type Diacritic = Double -> (Segs, Double)
|
|
|
|
simpleDia :: Segs -> Diacritic
|
|
simpleDia ss w = (ss, w)
|
|
|
|
doGlyphs :: [Word] -> Env -> Element
|
|
doGlyphs gs e = wrap $ run act e where
|
|
act = do
|
|
E {stroke, color} <- ask
|
|
let gattrs = [Stroke_ <<- color, Stroke_width_ <<- toPx stroke,
|
|
Stroke_linecap_ <<- "round", Stroke_linejoin_ <<- "round",
|
|
Fill_ <<- "none"]
|
|
g_ gattrs . mconcat <$> traverse placeWord gs <* newline
|
|
wrap (content, T {width, height}) =
|
|
let sattrs = [Height_ <<- toPx height, Width_ <<- toPx width] in
|
|
doctype <> svg11_ content `with` sattrs
|
|
|
|
|
|
glyphWidth :: EGlyph -> M Double
|
|
glyphWidth (G {width}, ss) =
|
|
let w = foldl (\x f -> snd $ f x) width ss in
|
|
(+) <$> withSize (* w) <*> gap
|
|
|
|
totalWidth :: Double -> M Double
|
|
totalWidth width = (+) <$> withSize (* width) <*> gap
|
|
|
|
wordWidth :: Word -> M Double
|
|
wordWidth = fmap sum . traverse glyphWidth
|
|
|
|
placeWord :: Word -> M Element
|
|
placeWord w = do
|
|
wwidth <- wordWidth w
|
|
margin' <- margin
|
|
S {x, firstOnLine} <- get
|
|
E {width} <- ask
|
|
let space' = if firstOnLine then pure () else space
|
|
e <- if x > margin' && x + wwidth > width then do
|
|
newline *> placeWord w
|
|
else do
|
|
mconcat <$> (space' *> traverse placeGlyph w)
|
|
modify \s -> s {firstOnLine = False}
|
|
pure e
|
|
|
|
placeGlyph :: EGlyph -> M Element
|
|
placeGlyph (G {path = path1, width = width1}, dias) = do
|
|
let (segs', width') = placeDia width1 dias
|
|
path <- joinSegs $ path1 <> segs'
|
|
width <- totalWidth width'
|
|
modify \s@(S {x}) -> s {x = x + width}
|
|
pure $ path_ [D_ <<- path]
|
|
|
|
placeDia :: Double -> [Diacritic] -> (Segs, Double)
|
|
placeDia w dias =
|
|
flip runState w $
|
|
fold <$> traverse state dias
|
|
|
|
newline :: M ()
|
|
newline = do
|
|
lh <- lineHeight
|
|
m <- margin
|
|
modify \s@(S {x, y, textWidth, textHeight}) ->
|
|
s {x = m, y = y + lh,
|
|
textWidth = textWidth `max` (x + m),
|
|
textHeight = textHeight + lh,
|
|
firstOnLine = True}
|
|
|
|
toPx :: Double -> Text
|
|
toPx x = pack (showFFloat (Just 4) x "px")
|