lang/laantas-script/GlyphsBase.hs

131 lines
3.5 KiB
Haskell
Raw Normal View History

module GlyphsBase (module GlyphsBase, module Svg) where
2021-04-28 06:29:21 -04:00
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}
2021-04-28 06:29:21 -04:00
-- | 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
2021-04-28 06:29:21 -04:00
-- | 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
2021-04-29 05:55:54 -04:00
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
2021-04-29 05:55:54 -04:00
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")