lang/laantas-script/GlyphsBase.hs

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


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