130 lines
3.5 KiB
Haskell
130 lines
3.5 KiB
Haskell
module GlyphsBase (module GlyphsBase, module Svg) where
|
|
|
|
import Svg hiding (shiftX, shiftY, shift, width, size)
|
|
import qualified Svg
|
|
|
|
import Data.List.NonEmpty (NonEmpty (..))
|
|
import Data.Semigroup (sconcat)
|
|
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 EGlyph = (Glyph, [Segs])
|
|
type Word = [EGlyph]
|
|
|
|
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", 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}, _) = (+) <$> 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@(G {path = path1}, segss) = do
|
|
gwidth <- glyphWidth g
|
|
path' <- joinSegs $ sconcat (path1 :| segss)
|
|
modify \s@(S {x}) -> s {x = x + gwidth}
|
|
pure $ path_ [D_ <<- path']
|
|
|
|
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")
|