From 284094ec4fbfb92cc7519173d047e2af2e68510b Mon Sep 17 00:00:00 2001
From: Rhiannon Morris <rhi@rhiannon.website>
Date: Tue, 11 May 2021 00:52:17 +0200
Subject: [PATCH] make diacritics width-aware

---
 laantas-script/Glyphs.hs     | 69 +++++++++++++++++++-----------------
 laantas-script/GlyphsBase.hs | 37 +++++++++++++------
 laantas-script/Split.hs      | 18 +++++-----
 3 files changed, 72 insertions(+), 52 deletions(-)

diff --git a/laantas-script/Glyphs.hs b/laantas-script/Glyphs.hs
index e0de361..b5b1cf8 100644
--- a/laantas-script/Glyphs.hs
+++ b/laantas-script/Glyphs.hs
@@ -1,7 +1,7 @@
 {-# OPTIONS_GHC -Wno-missing-signatures -Wno-name-shadowing #-}
 
 module Glyphs
-  (Glyph (..), Segs (..), Piece, doGlyphs,
+  (Glyph (..), Diacritic, simpleDia, Segs (..), EGlyph, Word, doGlyphs,
    withSize,
    charHeight', lineHeight', spaceWidth', gap',
    charHeight, lineHeight, spaceWidth, gap,
@@ -9,13 +9,12 @@ module Glyphs
    initials, finals, vowels, medials, num, numbers, punctuation, wave)
 where
 
+import Prelude hiding (Word)
 import Data.Map (Map)
 import qualified Data.Map.Strict as Map
 import GlyphsBase
 
 
-type Piece = (Glyph, [Segs])
-
 initials :: Map Text Glyph
 initials = Map.fromList $
   tGlyphs <> kGlyphs <> ƶGlyphs <> sGlyphs <> šGlyphs <> lGlyphs <>
@@ -28,7 +27,7 @@ finals = Map.fromList $
   [("t",t0), ("ƶ", ƶ0), ("s",s0), ("š",š0), ("l",l0), ("m",m0),
    ("n", n0), ("r", r0), ("f", f0)]
 
-medials :: Map Text Segs
+medials :: Map Text [Diacritic]
 medials = Map.fromList $
   [("a", da), ("á", dá), ("i", di), ("í", dí), ("u", du), ("ú", dú),
    ("ai", dai), ("au", dau), ("ia", dia), ("ua", dua), ("ḿ", dḿ),
@@ -658,38 +657,42 @@ uaPath = uNarrow <> shiftX 4.5 aPath
 
 adot = P . circR 0.2
 
-da = P [lR (0,5)]
-dá = da <> adot (-3.5,-3) <> adot (2,0)
-di = da <> P [cR (1,-2) (3,-3) (0,-3)]
-dí = da <> P [cR (1,-2) (4,-3) (-4,-3)]
-du = da <> P [lR (-4,0)]
-dú = du <> P [mR (4,-3), lR (-3,0)]
+withWidth f w = (f w, w)
+sP = simpleDia . P
 
-dai = da <> P [mR (-4,-3), lR (2.5,0), lR (0,3)]
-dau = da <> P [mR (-3,-3.5),
-               cR (-1.5,0.25) (-1.5,3.25) (0,3),
-               cR (1.5,-0.25) (1.5,-3.25) (0,-3),
-               cR (1,-0.25) (2,0.5) (3,0)]
-dia = di <> adot (-1.5,0)
-dua = du <> adot (2,-2)
+-- dont move because letters like t have the join not quite at the edge
+da = [sP [lR (0,5)]]
+dá = da <> [withWidth \w -> P [mA (w/2-1,8), cR (0.75,-0.5) (1.25,0.5) (2,0)]]
+di = da <> [sP [cR (1,-2) (3,-3) (0,-3)]]
+dí = da <> [sP [cR (1,-2) (4,-3) (-4,-3)]]
+du = da <> [sP [lR (-4,0)]]
+dú = du <> [sP [mR (4,-3), lR (-3,0)]]
 
-dḿ = da <> P [mR (-4,-3), cR (-0.375,1.125) (-0.25,1.275) (-0.25,1.375),
-              aR 0.625 0.625 0 Small CCW (1.5,0),
-              lR (0,-1), mR (0,1),
-              aR 0.625 0.625 0 Small CCW (1.5,0),
-              cR (0.125,-0.1) (0,-1.125) (-0.25,-1.375)]
-dń = da <> P [mR (-2,-2.5),
-              qR (0.25,-0.625) (-0.5,-0.5),
-              cR (-1.5,0.25) (-1.5,2.75) (0,2.5),
-              qR (0.375,-0.0625) (0.5,-0.3)]
+dai = da <> [sP [mR (-4,-3), lR (2.5,0), lR (0,3)]]
+dau = da <> [sP [mR (-3,-3.5),
+                 cR (-1.5,0.25) (-1.5,3.25) (0,3),
+                 cR (1.5,-0.25) (1.5,-3.25) (0,-3),
+                 cR (1,-0.25) (2,0.5) (3,0)]]
+dia = di <> [withWidth \w -> adot (-w/2,0)]
+dua = du <> [withWidth \w -> P [mA (w/2,7)] <> adot (0,0)]
+
+dḿ = da <> [sP [mR (-4,-3), cR (-0.375,1.125) (-0.25,1.275) (-0.25,1.375),
+                aR 0.625 0.625 0 Small CCW (1.5,0),
+                lR (0,-1), mR (0,1),
+                aR 0.625 0.625 0 Small CCW (1.5,0),
+                cR (0.125,-0.1) (0,-1.125) (-0.25,-1.375)]]
+dń = da <> [sP [mR (-2,-2.5),
+                qR (0.25,-0.625) (-0.5,-0.5),
+                cR (-1.5,0.25) (-1.5,2.75) (0,2.5),
+                qR (0.375,-0.0625) (0.5,-0.3)]]
 dł = da <>
-  P [mR (-2,-2.75),
-     cR (0.125,-0.125) (0,-0.375) (-0.625,-0.25),
-     cR (-0.75,0.15) (-1,1.25) (0,1.25),
-     lR (0.375,0), mR (-0.625,0),
-     cR (-0.75,0.15) (-1,1.25) (0,1.25),
-     qR (1,0) (1.125,-0.375)]
-dŕ = da <> P [mR (-3,0), cR (1,0) (3,-1) (3,-2)]
+  [sP [mR (-2,-2.75),
+       cR (0.125,-0.125) (0,-0.375) (-0.625,-0.25),
+       cR (-0.75,0.15) (-1,1.25) (0,1.25),
+       lR (0.375,0), mR (-0.625,0),
+       cR (-0.75,0.15) (-1,1.25) (0,1.25),
+       qR (1,0) (1.125,-0.375)]]
+dŕ = da <> [sP [mR (-3,0), cR (1,0) (3,-1) (3,-2)]]
 
 punctuation :: Map Text Glyph
 punctuation = Map.fromList
diff --git a/laantas-script/GlyphsBase.hs b/laantas-script/GlyphsBase.hs
index 83c3606..e0e986d 100644
--- a/laantas-script/GlyphsBase.hs
+++ b/laantas-script/GlyphsBase.hs
@@ -3,8 +3,8 @@ 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 Prelude hiding (Word)
+import Data.Foldable
 import Numeric
 import Prelude hiding (Word)
 
@@ -74,8 +74,14 @@ run m e@(E {size}) =
            textWidth = 0, textHeight = 0, firstOnLine = True}
 
 
-type EGlyph = (Glyph, [Segs])
-type Word   = [EGlyph]
+type Word = [EGlyph]
+
+type EGlyph = (Glyph, [Diacritic])
+
+type Diacritic = Double -> (Segs, Double)
+
+simpleDia :: Segs -> Diacritic
+simpleDia ss w = (ss, w)
 
 doGlyphs :: [Word] -> Env -> Element
 doGlyphs gs e = wrap $ run act e where
@@ -91,7 +97,12 @@ doGlyphs gs e = wrap $ run act e where
 
 
 glyphWidth :: EGlyph -> M Double
-glyphWidth (G {width}, _) = (+) <$> withSize (* width) <*> gap
+glyphWidth (G {width}, ss) =
+  let w = foldl (\x f -> snd $ f x) width ss in
+  (+) <$> withSize (* w) <*> gap
+
+totalWidth :: Double -> M Double
+totalWidth width = (+) <$> withSize (* width) <*> gap
 
 wordWidth :: Word -> M Double
 wordWidth = fmap sum . traverse glyphWidth
@@ -111,11 +122,17 @@ placeWord w = do
   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']
+placeGlyph (G {path = path1, width = width1}, dias) = do
+  let (segs', width') = placeDia width1 dias
+  path <- joinSegs $ path1 <> segs'
+  width <- totalWidth width'
+  modify \s@(S {x}) -> s {x = x + width}
+  pure $ path_ [D_ <<- path]
+
+placeDia :: Double -> [Diacritic] -> (Segs, Double)
+placeDia w dias =
+  flip runState w $
+    fold <$> traverse state dias
 
 newline :: M ()
 newline = do
diff --git a/laantas-script/Split.hs b/laantas-script/Split.hs
index 8a05280..a904453 100644
--- a/laantas-script/Split.hs
+++ b/laantas-script/Split.hs
@@ -29,8 +29,8 @@ maxFrom name i = longestWith name \x -> Map.lookup x i
 initial :: P Glyph
 initial = maxFrom "initial" initials
 
-medial :: P Segs
-medial = P [] <$ chunk "\\" <|> maxFrom "medial" medials
+medial :: P [Diacritic]
+medial = [] <$ chunk "\\" <|> maxFrom "medial" medials
 
 final :: P Glyph
 final = maxFrom "final" finals
@@ -38,29 +38,29 @@ final = maxFrom "final" finals
 ivowel :: P Glyph
 ivowel = maxFrom "vowel" vowels
 
-word :: P [Piece]
+word :: P [EGlyph]
 word = [is <> f <> concat p | is <- some initMed, f <- fin, p <- many punct]
  where
   initMed = try $
-    [(i, [m]) | i <- initial, m <- medial] <|>
+    (,) <$> initial <*> medial <|>
     [(v, []) | v <- ivowel] <|>
     dash
   fin = maybe [] (\x -> [(x, [])]) <$> optional final
 
-number :: P [Piece]
+number :: P [EGlyph]
 number = some (digit <|> hash) where
   hash = (num, []) <$ chunk "#"
   digit = [(numbers ! Char.digitToInt i, []) | i <- digitChar]
 
-punct :: P [Piece]
+punct :: P [EGlyph]
 punct = [[(p, [])] | p <- maxFrom "punctuation" punctuation] <* space
 
-dash :: P Piece
+dash :: P EGlyph
 dash = (wave, []) <$ chunk "–"
 
-text :: P [[Piece]]
+text :: P [[EGlyph]]
 text = space *> many (segment <* space) <* eof where
   segment = punct <|> number <|> word
 
-split :: Text -> [[Piece]]
+split :: Text -> [[EGlyph]]
 split = either (error . errorBundlePretty) id . parse text ""