105 lines
2.9 KiB
Haskell
105 lines
2.9 KiB
Haskell
{-# OPTIONS_GHC -fdefer-typed-holes #-}
|
|
|
|
import Prelude hiding (Word)
|
|
import Svg
|
|
import Glyphs (Glyph (..), Segs)
|
|
import qualified Glyphs as G
|
|
import Options.Applicative
|
|
import qualified Data.Text as Text
|
|
import Data.Functor
|
|
import Numeric
|
|
import Data.List.NonEmpty (NonEmpty (..))
|
|
import Data.Semigroup (sconcat)
|
|
|
|
|
|
data Options =
|
|
Opts { width, size, stroke :: {-# UNPACK #-} !Double }
|
|
deriving Show
|
|
|
|
options :: IO Options
|
|
options = execParser desc where
|
|
desc = info (opts <**> helper) $
|
|
fullDesc <> header "render lántas text as svg"
|
|
opts =
|
|
Opts <$> dimOpt 'W' "width" Nothing
|
|
<*> (dimOpt' 'S' "size" "text size" (Just 10)
|
|
<&> (/ G.lineHeight'))
|
|
<*> dimOpt' 'K' "stroke" "line thickness" (Just 2)
|
|
dimOpt s l d = dimOpt' s l l d
|
|
dimOpt' s l n d = option auto $ mconcat $
|
|
[short s, long l, help $ n <> " in pixels", metavar "SIZE"] <>
|
|
maybe [] (\x -> [value x]) d
|
|
|
|
toPx :: Double -> Text
|
|
toPx x = Text.pack (showFFloat (Just 4) x "px")
|
|
|
|
|
|
data TextSize = T {width, height :: !Double}
|
|
|
|
run :: M a -> Env -> (a, TextSize)
|
|
run m e@(E {size, stroke}) =
|
|
let (res, S {..}) = runState (runReaderT m e) s in
|
|
(res, T {width = textWidth + 2 * margin, height = textHeight'})
|
|
where
|
|
margin = stroke
|
|
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
|
|
|
|
|
|
eglyphWidth :: EGlyph -> M Double
|
|
eglyphWidth (G {width}, _) = G.withSize (* width)
|
|
|
|
wordWidth :: Word -> M Double
|
|
wordWidth = fmap sum . traverse eglyphWidth
|
|
|
|
placeWord :: Word -> M Element
|
|
placeWord w = do
|
|
wwidth <- wordWidth w
|
|
margin <- G.margin
|
|
S {x} <- get
|
|
E {width} <- ask
|
|
if x > margin && x + wwidth > width then
|
|
newline *> placeWord w
|
|
else do
|
|
mconcat <$> traverse placeGlyph w <* G.space
|
|
|
|
placeGlyph :: EGlyph -> M Element
|
|
placeGlyph (G {path = path1, width = w}, segss) = do
|
|
E {size} <- ask
|
|
S {x} <- get
|
|
gwidth <- G.withSize (* w)
|
|
path' <- G.joinSegs $ sconcat (path1 :| segss)
|
|
modify \s -> s {x = x + gwidth + size}
|
|
pure $ path_ [D_ <<- path']
|
|
|
|
newline :: M ()
|
|
newline = do
|
|
lh <- G.lineHeight
|
|
E {stroke = margin} <- ask
|
|
modify \s@(S {x, y, textWidth, textHeight'}) ->
|
|
s {x = margin, y = y + lh,
|
|
textWidth = textWidth `max` x,
|
|
textHeight' = textHeight' + lh}
|
|
|
|
main :: IO ()
|
|
main = do
|
|
Opts {..} <- options
|
|
let lántas = [(G.l, [G.dá]), (G.nt, [G.da]), (G.s0, [])]
|
|
let res = doGlyphs [lántas, lántas] (E {..})
|
|
writeFile "/home/niss/e.svg" $ show res
|