more lántas script (finish drawing glyphs)

laantas-script/GlyphsBase.hs

@@ -0,0 +1,115 @@
+module GlyphsBase (module GlyphsBase, module Svg) where
+
+import Svg hiding (shiftX, shiftY, shift, width)
+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}
+
+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
+
+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 (<>) = (:<>:)
+
+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}
+
+
+type EGlyph = (Glyph, [Segs])
+type Word   = [EGlyph]
+
+doGlyphs :: [Word] -> Env -> Element
+doGlyphs gs e = wrap $ run act e where
+  act = do
+    E {stroke} <- ask
+    let gattrs = [Stroke_ <<- "black", 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} <- get
+  E {width} <- ask
+  if x > margin' && x + wwidth > width then
+    newline *> placeWord w
+  else do
+    mconcat <$> traverse placeGlyph w <* space
+
+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}
+
+toPx :: Double -> Text
+toPx x = pack (showFFloat (Just 4) x "px")