add script to lántas pages

laantas-script/Glyphs.hs

@@ -2,11 +2,11 @@
 
 module Glyphs
   (Glyph (..), Segs (..), Piece, doGlyphs,
-   withSize, size,
+   withSize,
    charHeight', lineHeight', spaceWidth', gap',
    charHeight, lineHeight, spaceWidth, gap,
 
-   initials, finals, vowels, medials, num, numbers, punctuation)
+   initials, finals, vowels, medials, num, numbers, punctuation, wave)
 where
 
 import Data.Map (Map)
@@ -668,3 +668,7 @@ n4Path = P [mA (1.5,0), lR (0,5), sR (-1.5,-3) (-1.5,-5), lR (5,0), lR (0,5)]
 n5 = G n5Path 4
 n5Path = P [mA (0,0), lR (0,3.5), aR 1.5 1.5 0 Small CCW (1.5,1.5),
             lR (1,0), aR 1.5 1.5 0 Small CCW (1.5,-1.5), lR (0,-3.5)]
+
+wave :: Glyph
+wave = G {path = wavePath, width = 4} where
+  wavePath = P [mA (0,2.5), cR (1.5,-2) (2.5,2) (4,0)]

laantas-script/GlyphsBase.hs

@@ -21,9 +21,6 @@ gap'        = 1.5
 withSize :: MonadReader Env m => (Double -> a) -> m a
 withSize f = asks \E {size} -> f size
 
-size :: MonadReader Env m => m Double
-size = withSize id
-
 -- | multiplied by size
 charHeight, lineHeight, spaceWidth, margin, gap :: MonadReader Env m => m Double
 charHeight = withSize (* charHeight')
@@ -34,7 +31,15 @@ gap = withSize (* gap')
 
 data Segs = P [M Text] | Shift !Double !Double Segs | Segs :<>: Segs
 
-instance Semigroup Segs where (<>) = (:<>:)
+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
@@ -74,8 +79,8 @@ 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,
+    E {stroke, color} <- ask
+    let gattrs = [Stroke_ <<- color, Stroke_width_ <<- toPx stroke,
                   Stroke_linecap_ <<- "round", Fill_ <<- "none"]
     g_ gattrs . mconcat <$> traverse placeWord gs <* newline
   wrap (content, T {width, height}) =

laantas-script/Main.hs

@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -fdefer-typed-holes #-}
-
 import Prelude hiding (getContents, readFile, writeFile, putStrLn)
 import Svg
 import Glyphs (doGlyphs, lineHeight')
@@ -13,8 +11,9 @@ import Data.Text.Lazy.IO (writeFile, putStrLn)
 data Options =
   Opts {
     width, size, stroke :: {-# UNPACK #-} !Double,
-    inFile, outFile :: Maybe FilePath,
-    text   :: Maybe Text
+    inFile, outFile     :: Maybe FilePath,
+    text                :: Maybe Text,
+    color               :: Text
   }
   deriving Show
 
@@ -29,6 +28,7 @@ options = execParser desc where
          <*> filePath 'i' "input"
          <*> filePath 'o' "output"
          <*> text
+         <*> color
   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", value d]
@@ -37,6 +37,9 @@ options = execParser desc where
   text = optional $ option str $ mconcat
     [short 't', long "text", help $ "use given text instead of a file",
      metavar "TEXT"]
+  color = option str $ mconcat
+    [short 'C', long "color", help $ "set stroke color (any css syntax)",
+     metavar "COLOR", value "black"]
 
 main :: IO ()
 main = do

laantas-script/Split.hs

@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -fdefer-typed-holes #-}
-
 module Split (split) where
 
 import Glyphs
@@ -16,11 +14,14 @@ import Data.Void
 type P = Parsec Void Text
 
 
+lcChar :: P Char
+lcChar = Char.toLower <$> anySingle
+
 longestWith :: String -> (Text -> Maybe a) -> P a
-longestWith name p = try $ go . Text.singleton =<< anySingle where
+longestWith name p = try $ go . Text.singleton =<< lcChar where
   go acc = case p acc of
     Nothing -> fail $ "longestWith " <> name <> ": " <> show acc
-    Just x  -> try (do c <- anySingle; go $ Text.snoc acc c) <|> pure x
+    Just x  -> try (do c <- lcChar; go $ Text.snoc acc c) <|> pure x
 
 maxFrom :: String -> Map Text a -> P a
 maxFrom name i = longestWith name \x -> Map.lookup x i
@@ -29,7 +30,7 @@ initial :: P Glyph
 initial = maxFrom "initial" initials
 
 medial :: P Segs
-medial = maxFrom "medial" medials
+medial = P [] <$ chunk "\\" <|> maxFrom "medial" medials
 
 final :: P Glyph
 final = maxFrom "final" finals
@@ -40,18 +41,22 @@ ivowel = maxFrom "vowel" vowels
 word :: P [Piece]
 word = (<>) <$> some initMed <*> fin where
   initMed = try $
-    [(i, ms) | i <- initial, ms <- some medial] <|>
-    [(v, []) | v <- ivowel]
+    [(i, [m]) | i <- initial, m <- medial] <|>
+    [(v, []) | v <- ivowel] <|>
+    dash
   fin = maybe [] (\x -> [(x, [])]) <$> optional final
 
 number :: P [Piece]
-number = [[h1] <> ns <> [h2] | h1 <- hash, ns <- some digit, h2 <- hash] where
+number = some (digit <|> hash) where
   hash = (num, []) <$ chunk "#"
   digit = [(numbers ! Char.digitToInt i, []) | i <- digitChar]
 
 punct :: P [Piece]
 punct = [[(p, [])] | p <- maxFrom "punctuation" punctuation]
 
+dash :: P Piece
+dash = (wave, []) <$ chunk "–"
+
 text :: P [[Piece]]
 text = space *> many (segment <* space) <* eof where
   segment = punct <|> number <|> word

laantas-script/Svg.hs

@@ -13,7 +13,7 @@ import Graphics.Svg hiding (mA, mR, lA, lR, cA, cR, sA, sR, aA, aR)
 import Data.Text (Text, pack)
 
 
-data Env = E {width, size, stroke :: !Double}
+data Env = E {width, size, stroke :: !Double, color :: !Text}
 data St = S {x, y, textWidth, textHeight :: !Double}
 -- nb textHeight is one lineheight less than the actual height
 -- unless ending with a 'newline'