rhi/lang
1
0
Fork 0
Code Issues 2 Pull requests Releases Wiki Activity

more lántas script (finish drawing glyphs)

Browse source
This commit is contained in:
Rhiannon Morris 2020-11-10 15:39:45 +01:00
parent 0dea4d358f
commit 13836bac8b
6 changed files with 490 additions and 296 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

520
laantas-script/Glyphs.hs
View file

@ -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)]

115
laantas-script/GlyphsBase.hs Normal file
View file

@ -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")

33
laantas-script/Main.hs Normal file
View file

@ -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

8
laantas-script/Svg.hs
View file

@ -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)

6
laantas-script/laantas-script.cabal
View file

@ -9,15 +9,17 @@ maintainer: Rhiannon Morris <rhi@rhiannon.website>
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,

104
laantas-script/laantas-script.hs
View file

@ -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