diff --git a/laantas-script/Glyphs.hs b/laantas-script/Glyphs.hs index a0b66a6..a2e84ca 100644 --- a/laantas-script/Glyphs.hs +++ b/laantas-script/Glyphs.hs @@ -1,63 +1,34 @@ {-# OPTIONS_GHC -Wno-missing-signatures -Wno-name-shadowing #-} -module Glyphs where +module Glyphs + (module GlyphsBase, + glyphs, mods) +where import qualified Data.Map as Map -import Svg hiding (shiftX, shiftY, shift) -import qualified Svg +import GlyphsBase -data Glyph = G {path :: Segs, width :: Double} - -charHeight', lineHeight', spaceWidth' :: Double -charHeight' = 13 -lineHeight' = 15 -spaceWidth' = 4 - -withSize :: (Double -> a) -> M a -withSize f = asks \E {size} -> f size - -lineHeight :: M Double -lineHeight = withSize (* lineHeight') - -spaceWidth :: M Double -spaceWidth = withSize (* spaceWidth') - -margin :: M Double -margin = asks \E {stroke} -> stroke - -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} - glyphs :: Map.Map Text Glyph glyphs = Map.fromList $ - tGlyphs <> ðGlyphs <> sGlyphs + tGlyphs <> kGlyphs <> ðGlyphs <> sGlyphs <> šGlyphs <> lGlyphs <> + mGlyphs <> nGlyphs <> rGlyphs <> pGlyphs <> bGlyphs <> + čGlyphs <> hGlyphs <> fGlyphs <> vGlyphs <> + [("g", g), ("d", d), ("ǧ", ǧ), ("w", w), ("j", j)] <> + numbers <> punctuation + + +mods :: Map.Map Text Segs +mods = Map.fromList $ + [("a", da), ("á", dá), ("i", di), ("í", dí), ("u", du), ("ú", dú), + ("ai", dai), ("au", dau), ("ia", dia), ("ua", dua), ("ḿ", dḿ), + ("ń", dń), ("ł", dł), ("ŕ", dŕ)] tGlyphs = [("t",t), ("tt",tt), ("tk",tk), ("tg",tg), ("td",td), ("tð",tð), ("tp",tp), ("tb",tb), ("ts",ts), ("tš",tš), ("tl",tl), ("tm",tm), ("tn",tn), ("tr",tr), ("tč",tč), ("tǧ",tǧ), ("tw",tw), ("th",th), - ("tf",tf), ("tj",tj)] + ("tf",tf), ("tj",tj), ("t0",t0)] t = G {path = tPath, width = 5} tt = G {path = ttPath, width = 6} @@ -79,6 +50,7 @@ tw = G {path = twPath, width = 10} th = G {path = thPath, width = 12} tf = G {path = tfPath, width = 10} tj = G {path = tjPath, width = 5} +t0 = G {path = t0Path, width = 5} tPath = P [mA (1.5,0), lR (0,5), mA (0,0), lR (5,0), lR (0,5)] tPart ℓ = P [mA (2,0), lR (0,5), mA (0,0), lR (ℓ,0)] @@ -103,27 +75,30 @@ thPath = tPart 4 <> shiftX 4 hPath tfPath = tPart 4 <> shiftX 4 fPath tjPath = P [mA (2,0), lR (0,5), mA (0,0), lR (4,0), mA (0,-3), lR (5,0), lR (0,8)] +t0Path = tPath <> P [mA (1.5,7), lR (3.5,0)] +kGlyphs = [("k", k), ("kk", kk), ("ks", ks)] + k = G {path = kPath, width = 5} +kk = G {path = kkPath, width = 8} +ks = G {path = ksPath, width = 9} kPath = P [mA (0,0), lR (0,5), sR (3,0) (5,-0.5), mA (5,-3), lR (0,8)] kShortPart = P [mA (0,0), lR (0,5), sR (2.6,0) (4,-0.5)] kShort = kShortPart <> P [mA (4,-3), lR (0,8)] +kkPath = kShortPart <> shiftX 4 kShort +ksPath = kShortPart <> shiftX 4 sPath -g :: Glyph g = G {path = gPath, width = 5} -gPath, gShort :: Segs -gPath = kPath <> P [mA (2,-3), lR (3,0)] -gShort = kShort <> P [mA (1.5,-3), lR (2.5,0)] +gPath = kPath <> P [mA (2,-3), lR (3,0), mA (5,5)] +gShort = kShort <> P [mA (1.5,-3), lR (2.5,0), mA (4,5)] -d :: Glyph d = G {path = dPath, width = 5} -dPath, dPart, dBase, dJoin, dFree, dLong :: Segs dPath = dPart <> P [mA (5,-3), lR (0,8)] dPart = dBase <> dJoin dJoin = P [mA (2,5), cR (2,0) (3,-1) (3,-2)] @@ -134,7 +109,7 @@ dLong = dFree <> shiftX 1.5 dJoin ðGlyphs = [("ð",ð), ("þ",þ), ("ðt",ðt), ("ðk",ðk), ("ðg",ðg), ("ðd",ðd), ("ðð",ðð), ("ðp",ðp), ("ðb",ðb), ("ðs",ðs), ("ðš",ðš), ("ðl",ðl), ("ðm",ðm), ("ðn",ðn), ("ðr",ðr), ("ðč",ðč), ("ðǧ",ðǧ), ("ðw",ðw), - ("ðh",ðh), ("ðf",ðf), ("ðj",ðj)] + ("ðh",ðh), ("ðf",ðf), ("ðj",ðj), ("ð0", ð0)] ð = þ þ = G {path = þPath, width = 5} @@ -157,8 +132,9 @@ dLong = dFree <> shiftX 1.5 dJoin ðh = G {path = ðhPath, width = 13} ðf = G {path = ðfPath, width = 11} ðj = G {path = ðjPath, width = 7} +ð0 = G {path = ð0Path, width = 3.5} -þPath = dPath <> P [mA (1,-3), lR (4,0)] +þPath = dPath <> P [mA (1,-3), lR (4,0), mA (5,5)] ðPath = þPath ðtPath = dLong <> shiftX 5 tPath ðkPath = dPart <> shiftX 5 kShort @@ -179,26 +155,37 @@ dLong = dFree <> shiftX 1.5 dJoin ðhPath = dPart <> shiftX 5 hPath ðfPath = dFree <> shiftX 4 fPath ðjPath = dFree <> shiftX 4 fPath +ð0Path = dFree <> P [mA (0,7), lR (3.5,0)] -p :: Glyph +pGlyphs = [("p", p), ("pp", pp), ("ps", ps), ("pj", pj)] + p = G {path = pPath, width = 5} +pp = G {path = ppPath, width = 8} +ps = G {path = psPath, width = 10} +pj = G {path = pjPath, width = 9} -pPath :: Segs pPath = P [mA (1.5,-3), lR (0,8), sR (-1.5,-3) (-1.5,-5), lR (5,0), lR (0,5)] +ppPath = P [mA (1.5,-3), lR (0,8), sR (-1.5,-3) (-1.5,-5), + mA (4,-3), lR (0,8), mA (0,0), lR (8,0), lR (0,5)] +psPath = P [mA (1.5,-3), lR (0,8), sR (-1.5,-3) (-1.5,-5), lR (5,0)] + <> shiftX 5 sPath +pjPath = pPath <> P [mA (5,0), lR (4,0), lR (0,5)] -b :: Glyph +bGlyphs = [("b", b), ("bj", bj)] + b = G {path = bPath, width = 6} +bj = G {path = bjPath, width = 9} -bPath :: Segs bPath = wPart <> P [mA (2,-3), lR (4,0), lR (0,8)] +bjPath = bPath <> P [mA (6,-3), lR (3,0), lR (0,8)] sGlyphs = [("s",s), ("st",st), ("sk",sk), ("sg",sg), ("sd",sd), ("sð",sð), ("sp",sp), ("sb",sb), ("ss",ss), ("sš",sš), ("sl",sl), ("sm",sm), ("sn",sn), ("sr",sr), ("sč",sč), ("sǧ",sǧ), ("sw",sw), ("sh",sh), - ("sf",sf), ("sj",sj), ("s0",s)] + ("sf",sf), ("sj",sj), ("s0",s0)] s = G {path = sPath, width = 5} st = G {path = stPath, width = 9} @@ -228,19 +215,19 @@ sPartLine = sPart <> P [mA (3,0), lR (2,0)] stPath = sPartLine <> shiftX 4 tPath skPath = sPartLine <> shiftX 5 kShort sgPath = sPartLine <> shiftX 5 gShort -sdPath = sPart <> shiftX 4 dPath <> P [mA (3,0), lR (1,0)] -sðPath = sPart <> shiftX 4 ðPath <> P [mA (3,0), lR (1,0)] -spPath = sPart <> shiftX 5 pPath <> P [mA (3,0), lR (0,3.5)] +sdPath = sPart <> P [mA (3,0), lR (1,0)] <> shiftX 4 dPath +sðPath = sPart <> P [mA (3,0), lR (1,0)] <> shiftX 4 ðPath +spPath = sPart <> P [mA (3,0), lR (3.5,0)] <> shiftX 5 pPath sbPath = sPart <> shiftX 4 bPath <> P [mA (3,0), lR (0,-3), lR (3.5,0)] ssPath = sPartLine <> shiftX 5 sPath sšPath = sPartLine <> shiftX 5 šPath -slPath = sPart <> shiftX 5 lPath <> P [mA (3,0), lR (3,0)] -smPath = sPart <> shiftX 5 mPath <> P [mA (3,0), lR (2.5,0)] -snPath = sPart <> shiftX 5 nPath <> P [mA (3,0), lR (4,0)] -srPath = sPart <> shiftX 4 rShort <> P [mA (3,0), lR (4,0)] +slPath = sPart <> P [mA (3,0), lR (3,0)] <> shiftX 5 lPath +smPath = sPart <> P [mA (3,0), lR (2.5,0)] <> shiftX 5 mPath +snPath = sPart <> P [mA (3,0), lR (4,0)] <> shiftX 5 nPath +srPath = sPart <> P [mA (3,0), lR (4,0)] <> shiftX 4 rShort sčPath = sPart <> shiftX 3 čFlat sǧPath = sPart <> shiftX 4 ǧPath -swPath = sPart <> shiftX 4 wPath <> P [mA (3,0), lR (3.5,0)] +swPath = sPart <> P [mA (3,0), lR (3.5,0)] <> shiftX 4 wPath shPath = sPart <> shiftX 5 hPath sfPath = sPart <> shiftX 4 fPath sjPath = P [mA (0,0), lR (0,3.5), aR 1.5 1.5 0 Small CCW (3,0), lR (0,-1.5), @@ -248,16 +235,67 @@ sjPath = P [mA (0,0), lR (0,3.5), aR 1.5 1.5 0 Small CCW (3,0), lR (0,-1.5), s0Path = sPath <> P [mA (0.5,7), lR (4,0)] +šGlyphs = [("š",š), ("št",št), ("šk",šk), ("šg",šg), ("šd",šd), ("šð",šð), + ("šp",šp), ("šb",šb), ("šs",šs), ("šš",šš), ("šl",šl), ("šm",šm), + ("šn",šn), ("šr",šr), ("šč",šč), ("šǧ",šǧ), ("šw",šw), ("šh",šh), + ("šf",šf), ("šj",šj), ("š0",š0)] + š = G {path = šPath, width = 5} +šš = ss {path = ššPath} +šp = sp {path = špPath} +šb = sb {path = šbPath} +št = s2š st +šk = s2š sk +šg = s2š sg +šd = s2š sd +šð = s2š sð +šs = s2š ss +šl = s2š sl +šm = s2š sm +šn = s2š sn +šr = s2š sr +šč = s2š sč +šǧ = s2š sǧ +šw = s2š sw +šh = s2š sh +šf = s2š sf +šj = s2š sj +š0 = s2š s0 -šPath = sPath <> šLine -šLine = P [mA (1,-1.5), lR (2,0)] +šPath = sPath <> šLine <> P [mA (5,5)] +šLine = P [mA (0.5,-1.5), lR (2,0)] +ššPath = ssPath <> P [mA (1,-2), lR (7,0)] +špPath = spPath <> P [mA (0,-3), lR (3,0)] +šbPath = sPart <> šLine <> P [mA (3,0), lR (4,0)] <> shiftX 4 bPath +s2š g@(G {path}) = g {path = path <> šLine} -l :: Glyph +lGlyphs = [("l",l), ("lt",lt), ("lk",lk), ("lg",lg), ("ld",ld), ("lð",lð), + ("lp",lp), ("lb",lb), ("ls",ls), ("lš",lš), ("lm",lm), ("ln",ln), + ("lr",lr), ("lč",lč), ("lǧ",lǧ), ("lw",lw), ("lh",lh), ("lf",lf), + ("lj",lj), ("l0",l0)] + l = G {path = lPath, width = 5} +lt = G {path = ltPath, width = 10} +lk = G {path = lkPath, width = 9} +lg = G {path = lgPath, width = 9} +ld = G {path = ldPath, width = 10} +lð = G {path = lðPath, width = 10} +lp = G {path = lpPath, width = 10} +lb = G {path = lbPath, width = 11} +ls = G {path = lsPath, width = 10} +lš = G {path = lšPath, width = 10} +lm = G {path = lmPath, width = 11} +ln = G {path = lnPath, width = 10} +lr = G {path = lrPath, width = 10} +lč = G {path = lčPath, width = 10} +lǧ = G {path = lǧPath, width = 10} +lw = G {path = lwPath, width = 11} +lh = G {path = lhPath, width = 13} +lf = G {path = lfPath, width = 11} +lj = G {path = ljPath, width = 6} +l0 = G {path = l0Path, width = 4} -lPath, lPart, lBase, lPartFlat, lBaseFlat, lFree, lLong :: Segs lPath = lPart <> P [mA (4,4.5), lR (1,-0.7), mA (5,0), lR (0,5)] lBase = P [mA (4,0.5), cR (-2.25,-0.75) (-2.55,-0.5) (-2.75,-0.5), aR 1.25 1.25 0 Small CCW (0,2.5), lR (2,0), mR (-2,0), @@ -272,39 +310,163 @@ lFree = P [mA (4,0.5), cR (-2.25,-0.75) (-2.55,-0.5) (-2.75,-0.5), aR 1.25 1.25 0 Small CCW (0,2.5), cR (0.2,0.25) (2.25,0) (2.75,-0.5)] lLong = lBase <> P [mA (2,5), lR (2,0)] <> shiftX 1.5 dJoin +ltPath = lLong <> shiftX 5 tPath +lkPath = lPart <> shiftX 5 kShort +lgPath = lPart <> shiftX 5 gShort +ldPath = lFree <> shiftX 5 dPath +lðPath = lFree <> shiftX 5 ðPath +lpPath = lFree <> shiftX 5 pPath +lbPath = lPart <> shiftX 5 bPath +lsPath = lPart <> shiftX 5 sPath +lšPath = lPart <> shiftX 5 šPath +lmPath = lPart <> shiftX 5 mPath +lnPath = lPart <> shiftX 5 nPath +lrPath = lPart <> shiftX 5 rCursive +lčPath = lFree <> shiftX 5 čPath +lǧPath = lFree <> shiftX 5 ǧPath +lwPath = lPart <> shiftX 5 wPath +lhPath = lPart <> shiftX 5 hPath +lfPath = lFree <> shiftX 5 fPath +ljPath = lPartFlat <> P [mA (4,0), lR (2,0), lR (0,5)] +l0Path = lFree <> P [mA (0.25,7), lR (3.5,0)] -m :: Glyph +mGlyphs = [("m",m), ("mt",mt), ("mk",mk), ("mg",mg), ("md",md), ("mð",mð), + ("mp",mp), ("mb",mb), ("ms",ms), ("mš",mš), ("ml",ml), ("mm",mm), + ("mn",mn), ("mr",mr), ("mč",mč), ("mǧ",mǧ), ("mw",mw), ("mh",mh), + ("mf",mf), ("mj",mj), ("m0",m0)] + m = G {path = mPath, width = 6} +mt = G {path = mtPath, width = 10} +mk = G {path = mkPath, width = 10} +mg = G {path = mgPath, width = 10} +md = G {path = mdPath, width = 12} +mð = G {path = mðPath, width = 12} +mp = G {path = mpPath, width = 12} +mb = G {path = mbPath, width = 12} +ms = G {path = msPath, width = 11} +mš = G {path = mšPath, width = 11} +ml = G {path = mlPath, width = 11} +mm = G {path = mmPath, width = 12} +mn = G {path = mnPath, width = 11} +mr = G {path = mrPath, width = 9} +mč = G {path = mčPath, width = 12} +mǧ = G {path = mǧPath, width = 12} +mw = G {path = mwPath, width = 12} +mh = G {path = mhPath, width = 14} +mf = G {path = mfPath, width = 13} +mj = G {path = mjPath, width = 9} +m0 = G {path = m0Path, width = 6} -mPath, mPart, mLong :: Segs mPath = mPart <> P [mA (6,0), lR (0,5)] -mPart = P [mA (0.5,0), cR (-0.25,0.2) (-0.5,2.25) (-0.5,3.5), - aR 1.5 1.5 0 Small CCW (3,0), - lR (0,-2), mR (0,2), - aR 1.5 1.5 0 Small CCW (3,0)] -mLong = P [mA (0.5,0), cR (-0.25,0.2) (-0.5,2.25) (-0.5,3.5), - aR 1.5 1.5 0 Small CCW (1.5,1.5), - lR (0,-2), mR (0,2), - aR 1.5 1.5 0 Small CCW (1.5,1.5), - cR (2,0) (2,-1) (2,-2)] +mInit = P [mA (0.5,0), cR (-0.25,0.2) (-0.5,2.25) (-0.5,3.5)] +mBump' = P [aR 1.5 1.5 0 Small CCW (3,0)] +mBump = mBump' <> P [lR (0,-2), mR (0,2)] +mPart = mInit <> mBump <> mBump' +mLong = mInit <> mBump <> mBump' <> P [cR (2,0) (2,-1) (2,-2)] +mtPath = mLong <> shiftX 5 tPath +mkPath = mPart <> shiftX 6 kShort +mgPath = mPart <> shiftX 6 gShort +mdPath = ḿPath <> shiftX 7 dPath +mðPath = ḿPath <> shiftX 7 ðPath +mpPath = ḿPath <> shiftX 7 pPath +mbPath = mPart <> shiftX 6 bPath +msPath = mPart <> shiftX 6 sPath +mšPath = mPart <> shiftX 6 šPath +mlPath = mPart <> shiftX 6 lPath +mmPath = mInit <> mBump <> mBump <> mBump <> mBump' <> P [mR (0,-3.5), lR (0,5)] +mnPath = mPart <> shiftX 6 nPath +mrPath = mInit <> mBump <> mBump <> mBump' <> P [mR (0,-6.5), lR (0,8)] +mčPath = ḿPath <> shiftX 7 čPath +mǧPath = ḿPath <> shiftX 7 ǧPath +mwPath = mPart <> shiftX 6 wPath +mhPath = mPart <> shiftX 6 hPath +mfPath = ḿPath <> shiftX 7 fPath +mjPath = ḿPath <> P [mA (5.5,0), lR (3.5,0), lR (0,5)] +m0Path = ḿPath <> P [mA (0.5,7), lR (5,0)] -n :: Glyph +nGlyphs = [("n", n), ("nt", nt), ("nk", nk), ("ng", ng), ("nd", nd), ("nð", nð), + ("np", np), ("nb", nb), ("ns", ns), ("nš", nš), ("nl", nl), + ("nm", nm), ("nn", nn), ("nr", nr), ("nč", nč), ("nǧ", nǧ), + ("nw", nw), ("nh", nh), ("nf", nf), ("nj", nj), ("n0", n0)] + n = G {path = nPath, width = 5} nt = G {path = ntPath, width = 10} +nk = G {path = nkPath, width = 9} +ng = G {path = ngPath, width = 9} +nd = G {path = ndPath, width = 10} +nð = G {path = nðPath, width = 10} +np = G {path = npPath, width = 9.5} +nb = G {path = nbPath, width = 11} +ns = G {path = nsPath, width = 10} +nš = G {path = nšPath, width = 10} +nl = G {path = nlPath, width = 10} +nm = G {path = nmPath, width = 11} +nn = G {path = nnPath, width = 10} +nr = G {path = nrPath, width = 6} +nč = G {path = nčPath, width = 10} +nǧ = G {path = nǧPath, width = 9.5} +nw = G {path = nwPath, width = 11} +nh = G {path = nhPath, width = 13} +nf = G {path = nfPath, width = 10.5} +nj = G {path = njPath, width = 5} +n0 = G {path = n0Path, width = 3.5} -nPath, nPart, nPart', nLong :: Segs nPath = nPart <> P [mA (5,0), lR (0,5)] nPart = nPart' <> dJoin nPart' = P [mA (3.5,1.5), cR (0,-1) (-0.5,-1.5) (-1,-1.5), aR 2.5 2.5 0 Large CCW (0,5)] nLong = nPart' <> P [mA (2.5,5), lR (1.5,0)] <> shiftX 1.5 dJoin +nFlat = P [mA (5,0), lR (-2.5,0), aR 2.5 2.5 0 Large CCW (0,5), + cR (0.5,0) (1,-0.5) (1,-1.5)] ntPath = nLong <> shiftX 5 tPath +nkPath = nFlat <> shiftX 5 kShort +ngPath = nFlat <> shiftX 5 gShort +ndPath = nFlat <> shiftX 5 dPath +nðPath = nFlat <> shiftX 5 ðPath +npPath = ńPath <> shiftX 4.5 pPath +nbPath = nFlat <> P [mA (5,0), lR (2,0)] <> shiftX 5 bPath +nsPath = nFlat <> shiftX 5 sPath +nšPath = nFlat <> shiftX 5 šPath +nlPath = nFlat <> P [mA (5,0), lR (1,0)] <> shiftX 5 lPath +nmPath = nFlat <> P [mA (5,0), lR (0.5,0)] <> shiftX 5 mPath +nnPath = nFlat <> P [mA (5,0), lR (2,0)] <> shiftX 5 nPath +nrPath = nPart' <> P [mA (2.5,5), lR (0.5,0)] <> shiftX 3 rShort +nčPath = nFlat <> shiftX 4 čFlat +nǧPath = ńPath <> shiftX 4.5 ǧPath +nwPath = nFlat <> P [mA (5,0), lR (2,0)] <> shiftX 5 wPath +nhPath = nFlat <> shiftX 5 hPath +nfPath = ńPath <> shiftX 4.5 fPath +njPath = ńPath <> P [mA (1,-3), lR (4,0), lR (0,8)] +n0Path = ńPath <> P [mA (0.5,7), lR (3,0)] -r :: Glyph +rGlyphs = [("r", r), ("rt", rt), ("rk", rk), ("rg", rg), ("rd", rd), ("rð", rð), + ("rp", rp), ("rb", rb), ("rs", rs), ("rš", rš), ("rl", rl), + ("rm", rm), ("rr", rr), ("rč", rč), ("rǧ", rǧ), ("rw", rw), + ("rh", rh), ("rf", rf), ("rj", rj), ("r0", r0)] + r = G {path = rPath, width = 5} +rt = G {path = rtPath, width = 7} +rk = G {path = rkPath, width = 7} +rg = G {path = rgPath, width = 7} +rd = G {path = rdPath, width = 9.5} +rð = G {path = rðPath, width = 9.5} +rp = G {path = rpPath, width = 9.5} +rb = G {path = rbPath, width = 10.5} +rs = G {path = rsPath, width = 9.5} +rš = G {path = ršPath, width = 9.5} +rl = G {path = rlPath, width = 9.5} +rm = G {path = rmPath, width = 10.5} +rr = G {path = rrPath, width = 6} +rč = G {path = rčPath, width = 9.5} +rǧ = G {path = rǧPath, width = 9.5} +rw = G {path = rwPath, width = 10.5} +rh = G {path = rhPath, width = 12.5} +rf = G {path = rfPath, width = 10.5} +rj = G {path = rjPath, width = 7.5} +r0 = G {path = r0Path, width = 5} rPath = rPart <> P [mA (5,-3), lR (0,8)] rPart = P [mA (0,5), cR (3.5,0) (5,-1) (5,-2)] @@ -313,25 +475,48 @@ rCursive = rPartCursive <> P [mA (5,-3), lR (0,8)] rPartMid = P [mA (0,5), cR (1.25,0) (3.5,-1) (3.5,-2)] rPartShort = P [mA (0,5), cR (1,0) (3,-1) (3,-2)] rShort = rPartShort <> P [mA (3,-3), lR (0,8)] +rtPath = rPartMid <> shiftX 2 tPath +rkPath = rPartShort <> shiftX 3 kShort +rgPath = rPartShort <> shiftX 3 gShort +rdPath = rMid <> shiftX 4.5 dPath +rðPath = rMid <> shiftX 4.5 ðPath +rpPath = rMid <> shiftX 4.5 pPath +rbPath = rMid <> shiftX 4.5 bPath +rsPath = rMid <> shiftX 4.5 sPath +ršPath = rMid <> shiftX 4.5 šPath +rlPath = rMid <> shiftX 4.5 lPath +rmPath = rMid <> shiftX 4.5 mPath +rrPath = rShort <> shiftX 3 rShort +rčPath = rMid <> shiftX 4.5 čPath +rǧPath = rMid <> shiftX 4.5 ǧPath +rwPath = rMid <> shiftX 4.5 wPath +rhPath = rMid <> shiftX 4.5 hPath +rfPath = rMid <> shiftX 4.5 fPath +rjPath = rMid <> P [mA (3.5,0), lR (4,0), lR (0,5)] +rMid = rPartMid <> P [mA (3.5,0), lR (0,5)] +r0Path = ŕPath <> P [mA (0.5,7), lR (4,0)] -č :: Glyph +čGlyphs = [("č", č), ("čs", čs), ("čč", čč)] + č = G {path = čPath, width = 5} +čs = G {path = čsPath, width = 10} +čč = G {path = ččPath, width = 10} čPath = čPart <> čJoin <> P [mA (5,0), lR (0,5)] -čPart = P [mA (0,0.5), cR (2.25,-0.75) (2.55,-0.5) (-2.75,-0.5)] <> čPart' +čPart = P [mA (0,0.5), cR (2.25,-0.75) (2.55,-0.5) (2.75,-0.5)] <> čPart' čPart' = P [aR 1.25 1.25 0 Small CW (0,2.5), lR (-2,0), mR (2,0), aR 1.25 1.25 0 Small CW (0,2.5), cR (-0.2,0.25) (-2.25,0) (-2.75,-0.5)] -- FIXME? čJoin = P [mA (2.5,5), cR (1.5,0) (2.5,-0.5) (2.5,-1)] -čPartFlat = P [mA (0,0.5), lR (3.5,0)] <> čPart' +čPartFlat = P [mA (0,0), lR (3.5,0)] <> čPart' čFlat = čPartFlat <> shiftX 1 čJoin <> P [mA (6,0), lR (0,5)] +čsPath = čPart <> shiftX 5 sPath +ččPath = čPart <> shiftX 5 čPath -ǧ :: Glyph ǧ = G {path = ǧPath, width = 5} -ǧPath, ǧPart :: Segs ǧPath = ǧPart <> čJoin <> P [mA (5,-3), lR (0,8)] ǧPart = P [mA (0,-2), cR (2.25,-0.75) (2.55,-0.5) (2.75,-0.5), aR 1.25 1.25 0 Small CW (0,2.5), @@ -342,158 +527,101 @@ rShort = rPartShort <> P [mA (3,-3), lR (0,8)] cR (-0.2,0.25) (-2.25,0) (-2.75,-0.5)] -w :: Glyph w = G {path = wPath, width = 6} -wPath, wPart :: Segs wPath = wPart <> P [mA (6,0), lR (0,5)] wPart = P $ circA 2.5 (2.5,2.5) <> [mA (2.5,0), lR (3.5,0)] -h :: Glyph -h = G {path = hPath, width = 8} +hGlyphs = [("h", h), ("hh", hh), ("hn", hn), ("hm", hm)] + +h = G {path = hPath, width = 8} +hh = G {path = hhPath, width = 16} +hn = G {path = hnPath, width = 14} +hm = G {path = hmPath, width = 15} -hPath, hPart :: Segs hPath = hPart <> P [mA (5,-3), lR (3,0), lR (0,8)] hPart = sPart <> P [mA (3,0), lR (1,0)] <> shiftX 4 sPart +hhPath = hPart <> P [mA (7,0), lR (1,0)] <> shiftX 8 hPart <> + P [mA (12,-3), lR (4,0), lR (0,8)] +hnPath = hPath <> shiftX 9 nPath +hmPath = hPath <> shiftX 9 mPath -f :: Glyph +fGlyphs = [("f", f), ("fn", fn), ("fm", fm)] + f = G {path = fPath, width = 6} +fn = G {path = fnPath, width = 12} +fm = G {path = fmPath, width = 12} -fPath :: Segs -fPath = P [mA (3.5,2.5), lR (-1, 0), lR (0,2.5), +fPath = fPart <> P [lR (0,2.5)] +fPart = P [mA (3.5,2.5), lR (-1, 0), lR (0,2.5), aR 2.5 2.5 0 Large CW (0,-5), lR (1,0), - aR 2.5 2.5 0 Small CW (2.5, 2.5), lR (0,2.5)] + aR 2.5 2.5 0 Small CW (2.5, 2.5)] +fnPath = fPath <> shiftX 7 nPath +fmPath = fPart <> P [lR (0,1)] <> mBump <> mBump' <> P [mA (12,0), lR (0,5)] -j :: Glyph j = G {path = jPath, width = 5} -jPath :: Segs jPath = P [mA (0,0), lR (5,0), lR (0,5)] -a :: Glyph +vGlyphs = [("a", a), ("á", á), ("i", i), ("í", í), ("u", u), ("ú", ú), + ("ai", ai), ("au", au), ("ia", ia), ("ua", ua), ("ḿ", ḿ), + ("ń", ń), ("ł", ł), ("ŕ", ŕ)] + a = G {path = aPath, width = 0} - -aPath :: Segs -aPath = P [mA (0,0), lR (5,0)] - - -á :: Glyph á = G {path = áPath, width = 3} - -áPath :: Segs -áPath = P [mA (0,0), lR (5,0), mA (3,0), lR (5,0)] - - -i :: Glyph i = j - - -í :: Glyph í = G {path = íPath, width = 5} - -íPath :: Segs -íPath = P [mA (0,0), lR (3,0), lR (0,5), mR (0,-5), lR (2,0), lR (0,5)] - - -u :: Glyph u = G {path = uPath, width = 5} - -uPath :: Segs -uPath = P $ circA 2.5 (2.5,2.5) - - -ú :: Glyph ú = G {path = úPath, width = 6} - -úPath :: Segs -úPath = P $ ellipseA 1.5 2.5 (1.5,2.5) <> ellipseA 1.5 2.5 (4.5,2.5) - - -ai :: Glyph ai = G {path = aiPath, width = 5} +au = G {path = auPath, width = 5} +ia = G {path = iaPath, width = 5} +ua = G {path = uaPath, width = 5} +ḿ = G {path = ḿPath, width = 6} +ń = G {path = ńPath, width = 3} +ł = G {path = łPath, width = 4} +ŕ = G {path = ŕPath, width = 5} -aiPath :: Segs +aPath = P [mA (0,0), lR (5,0)] +áPath = P [mA (0,0), lR (5,0), mA (3,0), lR (5,0)] +íPath = P [mA (0,0), lR (3,0), lR (0,5), mR (0,-5), lR (2,0), lR (0,5)] +uPath = P $ circA 2.5 (2.5,2.5) +úPath = P $ ellipseA 1.5 2.5 (1.5,2.5) <> ellipseA 1.5 2.5 (4.5,2.5) aiPath = P [mA (0,0), lR (0,5), mR (2,-5), lR (3,0), lR (0,5), mA (2.5,7), lR (2,0)] - - -au :: Glyph -au = G {path = auPath, width = 5} - -auPath :: Segs auPath = P $ [mA (0,0), lR (0,5)] <> ellipseA 1.5 2.5 (3.5,2.5) <> [mA (2.5,7), lR (2,0)] - - -ia :: Glyph -ia = G {path = iaPath, width = 5} - -iaPath :: Segs iaPath = P [mA (0,0), lR (3,0), lR (0,5), mA (5,0), lR (0,5)] - - -ua :: Glyph -ua = G {path = uaPath, width = 5} - -uaPath :: Segs uaPath = P $ ellipseA 1.5 2.5 (1.5,2.5) <> [mA (5,0), lR (0,5)] - - -ḿ :: Glyph -ḿ = G {path = ḿPath, width = 6} - -ḿPath :: Segs ḿPath = P [mA (0.5,0), cR (-0.25,0.2) (-0.5,2.25) (-0.5,3.5), aR 1.5 1.5 0 Small CCW (3,0), lR (0,-2), mA (5.5,0), cR (0.25,0.2) (0.5,2.25) (0.5,3.5), aR 1.5 1.5 0 Small CW (-3,0)] - - -ń :: Glyph -ń = G {path = ńPath, width = 4} - -ńPath :: Segs ńPath = P [mA (3.5,1.5), cR (0,-1) (-0.5,-1.5) (-1,-1.5), aR 2.5 2.5 0 Large CCW (0,5), cR (0.5,0) (1,-0.5) (1,-1.5)] - - -ł :: Glyph -ł = G {path = łPath, width = 4} - -łPath :: Segs łPath = lFree - - -ŕ :: Glyph -ŕ = G {path = ŕPath, width = 5} - -ŕPath :: Segs ŕPath = rPart <> P [mA (5,0), lR (0,5)] -adot :: Point -> Segs adot = P . circR 0.2 -da, dá, di, dí, du, dú :: Segs 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,2), lR (-3,0)] +dú = du <> P [mR (4,-3), lR (-3,0)] -dai, dau, dia, dua :: Segs dai = da <> P [mR (-4,-3), lR (2.5,0), lR (0,3)] dau = da <> P (circR 1 (-2,-2)) <> P [mR (-1,0), lR (2,0)] -dia = di <> adot (-1,0) -dua = du <> adot (-1,0) -- FIXME? +dia = di <> adot (-1.5,0) +dua = du <> adot (2,-2) -- FIXME? -dḿ, dń, dł, dŕ :: Segs 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), @@ -506,3 +634,23 @@ dł = da <> P [mR (-1.5,-3.5), cR (-1.125,-0.375) (-1.275,-0.25) (-1.375,-0.25), aR 0.625 0.625 0 Small CCW (0,1.5), cR (0.1,0.125) (1.125,0) (1.375,-0.25)] dŕ = da <> Shift (-3) 5 rPartShort + +punctuation = [(".", eos), (",", eop), ("#", num)] + +eos = G {path = eosPath, width = 8} +eosPath = P $ circA 1 (4,1) <> circA 1 (4,4) + +eop = G {path = eopPath, width = 4} +eopPath = P $ circA 1 (2,2.5) + +num = G {path = P [mA (0,0), lR (0,5)], width = 0} + +numbers = zipWith (\n p -> (pack $ show n, p)) [0..9::Int] + [u, t, n2, G dFree 3, n4, n5, ł, ḿ, ń, f] +n2 = G n2Path 5 +n2Path = P [mA (0,0), lR (0,5), sR (3,0) (5,-0.5), mA (5,0), lR (0,5)] +n4 = G n4Path 5 +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)] diff --git a/laantas-script/GlyphsBase.hs b/laantas-script/GlyphsBase.hs new file mode 100644 index 0000000..5405c09 --- /dev/null +++ b/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") diff --git a/laantas-script/Main.hs b/laantas-script/Main.hs new file mode 100644 index 0000000..a609d7e --- /dev/null +++ b/laantas-script/Main.hs @@ -0,0 +1,33 @@ +{-# OPTIONS_GHC -fdefer-typed-holes #-} + +import Prelude hiding (Word) +import Svg +import qualified Glyphs as G +import Options.Applicative +import Data.Functor + + +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 + +main :: IO () +main = do + Opts {..} <- options + let lántas = _ + let res = G.doGlyphs [lántas, lántas] (E {..}) + writeFile "/home/niss/e.svg" $ show res diff --git a/laantas-script/Svg.hs b/laantas-script/Svg.hs index c12abaa..3701b2e 100644 --- a/laantas-script/Svg.hs +++ b/laantas-script/Svg.hs @@ -1,6 +1,6 @@ module Svg (module Svg, - Text, + Text, pack, module Graphics.Svg, module Control.Monad.Reader, module Control.Monad.State) @@ -10,12 +10,12 @@ import Control.Monad.Reader import Control.Monad.State import qualified Graphics.Svg as Base import Graphics.Svg hiding (mA, mR, lA, lR, cA, cR, sA, sR, aA, aR) -import Data.Text (Text) +import Data.Text (Text, pack) data Env = E {width, size, stroke :: !Double} -data St = S {x, y, textWidth, textHeight' :: !Double} --- nb textHeight' is one lineheight less than the actual height +data St = S {x, y, textWidth, textHeight :: !Double} +-- nb textHeight is one lineheight less than the actual height -- unless ending with a 'newline' type M = ReaderT Env (State St) diff --git a/laantas-script/laantas-script.cabal b/laantas-script/laantas-script.cabal index 9b5b554..ced4948 100644 --- a/laantas-script/laantas-script.cabal +++ b/laantas-script/laantas-script.cabal @@ -9,15 +9,17 @@ maintainer: Rhiannon Morris executable laantas-script hs-source-dirs: . - main-is: laantas-script.hs + main-is: Main.hs other-modules: Svg, - Glyphs + Glyphs, + GlyphsBase default-language: Haskell2010 default-extensions: BlockArguments, DisambiguateRecordFields, DuplicateRecordFields, + FlexibleContexts, LambdaCase, NamedFieldPuns, OverloadedStrings, diff --git a/laantas-script/laantas-script.hs b/laantas-script/laantas-script.hs deleted file mode 100644 index b53c159..0000000 --- a/laantas-script/laantas-script.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# 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