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) import qualified Data.Text as Text 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) = liftA2 (<>) (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) doGlyphsNoDoctype :: [Word] -> Env -> Element doGlyphsNoDoctype 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 w = toPx width; h = toPx height viewBox = Text.unwords ["0", "0", toNoDim width, toNoDim height] in svg11_ content `with` [Width_ <<- w, Height_ <<- h, ViewBox_ <<- viewBox] doGlyphs :: [Word] -> Env -> Element doGlyphs gs e = doctype <> doGlyphsNoDoctype gs e 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} toNoDim :: Double -> Text toNoDim x = pack (showFFloat (Just 4) x "") toPx :: Double -> Text toPx x = pack (showFFloat (Just 4) x "px")