163 lines
4.5 KiB
Haskell
163 lines
4.5 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, 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}}
|
|
|
|
-- | 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' a = SizeInfo -> (Segs, a)
|
|
type Diacritic = Diacritic' Double
|
|
|
|
simpleDia :: Segs -> Diacritic
|
|
simpleDia ss (SI {width}) = (ss, width)
|
|
|
|
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
|
|
|
|
|
|
liftDia :: Diacritic -> Diacritic' SizeInfo
|
|
liftDia f sz@(SI {..}) = let (x, w) = f sz in (x, SI {width = w, ..})
|
|
|
|
glyphWidth :: EGlyph -> M Double
|
|
glyphWidth (G {size}, ss) =
|
|
let SI {width} = foldl (\x f -> snd $ liftDia f x) size ss in
|
|
(+) <$> withSize (* width) <*> 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, size}, dias) = do
|
|
let (segs', width') = placeDias size dias
|
|
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")
|