lang/laantas-script/GlyphsBase.hs
Rhiannon Morris f243311e64 adjust space handling to avoid a gap on the right
...which made the images not centred propertly
2021-04-29 12:02:06 +02:00

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")