lang/laantas-script/GlyphsBase.hs

163 lines
4.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
2021-05-10 18:52:17 -04:00
import Prelude hiding (Word)
import Data.Foldable
import Numeric
import Prelude hiding (Word)
data Glyph = G {path :: Segs, size :: SizeInfo}
data SizeInfo = SI {
width :: Double, -- ^ total width
right :: Double, -- ^ attachment point for e.g. a
center :: Double -- ^ attachment point for e.g. á
}
simpleG :: Segs -> Double -> Glyph
simpleG path width =
G {path, size = SI {width, right = width, center = width/2}}
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}
2021-05-10 18:52:17 -04:00
type Word = [EGlyph]
type EGlyph = (Glyph, [Diacritic])
type Diacritic' a = SizeInfo -> (Segs, a)
type Diacritic = Diacritic' Double
2021-05-10 18:52:17 -04:00
simpleDia :: Segs -> Diacritic
simpleDia ss (SI {width}) = (ss, width)
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,
2021-04-30 07:45:18 -04:00
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
liftDia :: Diacritic -> Diacritic' SizeInfo
liftDia f sz = let (x, w) = f sz in (x, sz {width = w} :: SizeInfo)
glyphWidth :: EGlyph -> M Double
glyphWidth (G {size}, ss) =
let SI {width} = foldl (\x f -> snd $ liftDia f x) size ss in
(+) <$> withSize (* width) <*> gap
2021-05-10 18:52:17 -04:00
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, size}, dias) = do
let (segs', width') = placeDias size dias
2021-05-10 18:52:17 -04:00
path <- joinSegs $ path1 <> segs'
width <- totalWidth width'
modify \s@(S {x}) -> s {x = x + width}
pure $ path_ [D_ <<- path]
placeDias :: SizeInfo -> [Diacritic] -> (Segs, Double)
placeDias sz =
unlift . flip runState sz . fmap fold . traverse (state . liftDia)
where unlift (x, SI {width}) = (x, width)
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")