start lántas script writer

This commit is contained in:
Rhiannon Morris 2020-11-04 19:06:54 +01:00
parent f6bf7b1f3d
commit 0dea4d358f
5 changed files with 766 additions and 1 deletions

View File

@ -1 +1,8 @@
packages: ./langfilter
packages:
./langfilter,
./laantas-script
source-repository-package
type: git
location: https://git.rhiannon.website/rhi/svg-builder
tag: 6bda613b538b08e9947913382f3b94235ca92149

508
laantas-script/Glyphs.hs Normal file
View File

@ -0,0 +1,508 @@
{-# OPTIONS_GHC -Wno-missing-signatures -Wno-name-shadowing #-}
module Glyphs where
import qualified Data.Map as Map
import Svg hiding (shiftX, shiftY, shift)
import qualified Svg
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 = [("t",t), ("tt",tt), ("tk",tk), ("tg",tg), ("td",td), ("",),
("tp",tp), ("tb",tb), ("ts",ts), ("",), ("tl",tl), ("tm",tm),
("tn",tn), ("tr",tr), ("",), ("",), ("tw",tw), ("th",th),
("tf",tf), ("tj",tj)]
t = G {path = tPath, width = 5}
tt = G {path = ttPath, width = 6}
tk = G {path = tkPath, width = 9}
tg = G {path = tgPath, width = 9}
td = G {path = tdPath, width = 9}
= G {path = tðPath, width = 9}
tp = G {path = tpPath, width = 9}
tb = G {path = tbPath, width = 10}
ts = G {path = tsPath, width = 9}
= G {path = tšPath, width = 9}
tl = G {path = tlPath, width = 9}
tm = G {path = tmPath, width = 10}
tn = G {path = tnPath, width = 9}
tr = G {path = trPath, width = 7}
= G {path = tčPath, width = 9}
= G {path = tǧPath, width = 10}
tw = G {path = twPath, width = 10}
th = G {path = thPath, width = 12}
tf = G {path = tfPath, width = 10}
tj = G {path = tjPath, 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)]
ttPath = P [mA (1,0), lR (0,5), mA (3,0), lR (0,5), mA (5,0), lR (0,5),
mA (0,0), lR (7,0), lR (0,5)]
tkPath = tPart 5 <> shiftX 5 kShort
tgPath = tPart 5 <> shiftX 5 gShort
tdPath = tPart 4 <> shiftX 4 dPath
tðPath = tdPath <> P [mA (6,-3), lR (3,0)]
tpPath = P [mA (2,-3), lR (0,8), mA (0,-3), lR (5.5,0)] <> shiftX 4 pPath
tbPath = tPart 6 <> shiftX 4 bPath
tsPath = tPart 4 <> shiftX 4 sPath
tšPath = tPart 4 <> shiftX 4 šPath
tlPath = tPart 5 <> shiftX 4 lPath
tmPath = tPart 4.5 <> shiftX 4 mPath
tnPath = tPart 6 <> shiftX 4 nPath
trPath = tPart 7 <> shiftX 4 rShort
tčPath = tPart 3 <> shiftX 3 čFlat
tǧPath = tPart 4 <> shiftX 5 ǧPath
twPath = tPart 6 <> shiftX 4 wPath
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)]
k = G {path = kPath, width = 5}
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)]
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)]
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)]
dBase = P [mA (0,0), lR (3.5,0), cR (0,1.5) (-3.5,3.5) (-3.5,5), lR (2,0)]
dFree = dBase <> P [mA (2,5), lR (1.5,0)]
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)]
ð = þ
þ = G {path = þPath, width = 5}
ðt = G {path = ðtPath, width = 10}
ðk = G {path = ðkPath, width = 9}
ðg = G {path = ðgPath, width = 9}
ðd = G {path = ðdPath, width = 10}
ðð = G {path = ððPath, width = 10}
ðp = G {path = ðpPath, width = 10}
ðb = G {path = ðbPath, width = 11}
ðs = G {path = ðsPath, width = 10}
ðš = G {path = ðšPath, width = 10}
ðl = G {path = ðlPath, width = 10}
ðm = G {path = ðmPath, width = 11}
ðn = G {path = ðnPath, width = 10}
ðr = G {path = ðrPath, width = 10}
ðč = G {path = ðčPath, width = 10}
ðǧ = G {path = ðǧPath, width = 10}
ðw = G {path = ðwPath, width = 11}
ðh = G {path = ðhPath, width = 13}
ðf = G {path = ðfPath, width = 11}
ðj = G {path = ðjPath, width = 7}
þPath = dPath <> P [mA (1,-3), lR (4,0)]
ðPath = þPath
ðtPath = dLong <> shiftX 5 tPath
ðkPath = dPart <> shiftX 5 kShort
ðgPath = dPart <> shiftX 5 gShort
ðdPath = dFree <> shiftX 5 dPath <> P [mA (1,-2), lR (2,0)]
ððPath = dFree <> shiftX 5 ðPath
ðpPath = dFree <> shiftX 5 pPath
ðbPath = dPart <> shiftX 5 bPath
ðsPath = dPart <> shiftX 5 sPath
ðšPath = dPart <> shiftX 5 šPath
ðlPath = dPart <> shiftX 5 lPath
ðmPath = dPart <> shiftX 5 mPath
ðnPath = dPart <> shiftX 5 nPath
ðrPath = dPart <> shiftX 5 rCursive
ðčPath = dFree <> shiftX 5 čPath
ðǧPath = dFree <> shiftX 5 ǧPath
ðwPath = dPart <> shiftX 5 wPath
ðhPath = dPart <> shiftX 5 hPath
ðfPath = dFree <> shiftX 4 fPath
ðjPath = dFree <> shiftX 4 fPath
p :: Glyph
p = G {path = pPath, width = 5}
pPath :: Segs
pPath = P [mA (1.5,-3), lR (0,8), sR (-1.5,-3) (-1.5,-5), lR (5,0), lR (0,5)]
b :: Glyph
b = G {path = bPath, width = 6}
bPath :: Segs
bPath = wPart <> P [mA (2,-3), lR (4,0), lR (0,8)]
sGlyphs = [("s",s), ("st",st), ("sk",sk), ("sg",sg), ("sd",sd), ("",),
("sp",sp), ("sb",sb), ("ss",ss), ("",), ("sl",sl), ("sm",sm),
("sn",sn), ("sr",sr), ("",), ("",), ("sw",sw), ("sh",sh),
("sf",sf), ("sj",sj), ("s0",s)]
s = G {path = sPath, width = 5}
st = G {path = stPath, width = 9}
sk = G {path = skPath, width = 9}
sg = G {path = sgPath, width = 9}
sd = G {path = sdPath, width = 9}
= G {path = sðPath, width = 9}
sp = G {path = spPath, width = 10}
sb = G {path = sbPath, width = 10}
ss = G {path = ssPath, width = 10}
= G {path = sšPath, width = 10}
sl = G {path = slPath, width = 10}
sm = G {path = smPath, width = 11}
sn = G {path = snPath, width = 10}
sr = G {path = srPath, width = 9}
= G {path = sčPath, width = 9}
= G {path = sǧPath, width = 10}
sw = G {path = swPath, width = 10}
sh = G {path = shPath, width = 13}
sf = G {path = sfPath, width = 10}
sj = G {path = sjPath, width = 6}
s0 = G {path = s0Path, width = 5}
sPath = sPartLine <> P [mA (5,0), lR (0,5)]
sPart = P [mA (0, 0), lR (0, 3.5), aR 1.5 1.5 0 Small CCW (3,0), lR (0,-3.5)]
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)]
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)]
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)]
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),
mA (3,0), lR (3,0), lR (0,5), mA (3,2), lR (3,0)]
s0Path = sPath <> P [mA (0.5,7), lR (4,0)]
š = G {path = šPath, width = 5}
šPath = sPath <> šLine
šLine = P [mA (1,-1.5), lR (2,0)]
l :: Glyph
l = G {path = lPath, width = 5}
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),
aR 1.25 1.25 0 Small CCW (0,2.5), lR (0.75,0)]
lPart = lBase <> dJoin
lPartFlat = lBaseFlat <> shiftX 1 dJoin
lBaseFlat = P [mA (4,0), lR (-2.75,0),
aR 1.25 1.25 0 Small CCW (0,2.5), lR (2,0), mR (-2,0),
aR 1.25 1.25 0 Small CCW (0,2.5), lR (2,0)]
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), lR (2,0), mR (-2,0),
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
m :: Glyph
m = G {path = mPath, 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)]
n :: Glyph
n = G {path = nPath, width = 5}
nt = G {path = ntPath, width = 10}
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
ntPath = nLong <> shiftX 5 tPath
r :: Glyph
r = G {path = rPath, width = 5}
rPath = rPart <> P [mA (5,-3), lR (0,8)]
rPart = P [mA (0,5), cR (3.5,0) (5,-1) (5,-2)]
rPartCursive = P [mA (0,3), cR (0,1) (1,2) (3,2), cR (1,0) (2,-1) (2,-2)]
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)]
č :: Glyph
č = G {path = čPath, width = 5}
č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 [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'
čFlat = čPartFlat <> shiftX 1 čJoin <> P [mA (6,0), lR (0,5)]
ǧ :: 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),
lR (-2,0), mR (2,0),
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)]
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}
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
f :: Glyph
f = G {path = fPath, width = 6}
fPath :: Segs
fPath = 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)]
j :: Glyph
j = G {path = jPath, width = 5}
jPath :: Segs
jPath = P [mA (0,0), lR (5,0), lR (0,5)]
a :: Glyph
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}
aiPath :: Segs
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, , di, , du, :: Segs
da = P [lR (0,5)]
= da <> adot (-3.5,-3) <> adot (2,0)
di = da <> P [cR (1,-2) (3,-3) (0,-3)]
= da <> P [cR (1,-2) (4,-3) (-4,-3)]
du = da <> P [lR (-4,0)]
= du <> P [mR (4,2), 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?
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),
aR 0.625 (-0.625) 0 Small CCW (1.5,0),
cR (0.125,-0.1) (0,-1.125) (-0.25,-1.375)]
= da <> P [mR (-3,-2.5), aR 1 1 0 Small CCW (0,2)]
= 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),
lR (1,0), mR (-1,0),
aR 0.625 0.625 0 Small CCW (0,1.5),
cR (0.1,0.125) (1.125,0) (1.375,-0.25)]
= da <> Shift (-3) 5 rPartShort

113
laantas-script/Svg.hs Normal file
View File

@ -0,0 +1,113 @@
module Svg
(module Svg,
Text,
module Graphics.Svg,
module Control.Monad.Reader,
module Control.Monad.State)
where
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)
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
-- unless ending with a 'newline'
type M = ReaderT Env (State St)
type Point = (Double, Double)
mA :: Point -> M Text
mA (x', y') =
ReaderT \E {size} -> gets \S {x, y} ->
Base.mA (x + x' * size) (y + y' * size)
mR :: Point -> M Text
mR (x', y') = reader \E {size} -> Base.mR (x' * size) (y' * size)
lA :: Point -> M Text
lA (x', y') =
ReaderT \E {size} -> gets \S {x, y} ->
Base.lA (x + x' * size) (y + y' * size)
lR :: Point -> M Text
lR (x', y') = reader \E {size} -> Base.lR (x' * size) (y' * size)
sA :: Point -> Point -> M Text
sA (x1, y1) (x2, y2) =
ReaderT \E {size} -> gets \S {x, y} ->
Base.sA (x + x1 * size) (y + y1 * size)
(x + x2 * size) (y + y2 * size)
sR :: Point -> Point -> M Text
sR (x1, y1) (x2, y2) =
reader \E {size} ->
Base.sR (x1 * size) (y1 * size) (x2 * size) (y2 * size)
cA :: Point -> Point -> Point -> M Text
cA (x1, y1) (x2, y2) (x3, y3) =
ReaderT \E {size} -> gets \S {x, y} ->
Base.cA (x + x1 * size) (y + y1 * size)
(x + x2 * size) (y + y2 * size)
(x + x3 * size) (y + y3 * size)
<> " " -- lmao
cR :: Point -> Point -> Point -> M Text
cR (x1, y1) (x2, y2) (x3, y3) =
reader \E {size} ->
Base.cR (x1 * size) (y1 * size)
(x2 * size) (y2 * size)
(x3 * size) (y3 * size)
<> " " -- lmao
data Arc = Large | Small
data Sweep = CW | CCW
arcToFlag :: Num a => Arc -> a
arcToFlag = \case Large -> 1; Small -> 0
sweepToFlag :: Num a => Sweep -> a
sweepToFlag = \case CW -> 1; CCW -> 0
aA :: Double -> Double -> Double -> Arc -> Sweep -> Point -> M Text
aA rx ry θ arc sweep (x', y') =
ReaderT \E {size} -> gets \S {x, y} ->
Base.aA (rx * size) (ry * size) θ (arcToFlag arc) (sweepToFlag sweep)
(x + x' * size) (y + y' * size)
aR :: Double -> Double -> Double -> Arc -> Sweep -> Point -> M Text
aR rx ry θ arc sweep (x', y') =
reader \E {size} ->
Base.aR (rx * size) (ry * size) θ (arcToFlag arc) (sweepToFlag sweep)
(x' * size) (y' * size)
ellipseX :: (Point -> M Text) -> Double -> Double -> Point -> [M Text]
ellipseX mX rx ry (x', y') =
[mX (x' - rx, y'), aR rx ry 0 Large CW (0,0.0001), pure z]
ellipseR, ellipseA :: Double -> Double -> Point -> [M Text]
ellipseR = ellipseX mR
ellipseA = ellipseX mA
circR :: Double -> Point -> [M Text]
circR r = ellipseR r r
circA :: Double -> Point -> [M Text]
circA r = ellipseA r r
shiftX :: Double -> St -> St
shiftX dx s@(S {x}) = s {x = x + dx}
shiftY :: Double -> St -> St
shiftY dy s@(S {y}) = s {y = y + dy}
shift :: (Double, Double) -> St -> St
shift (dx, dy) = shiftX dx . shiftY dy

View File

@ -0,0 +1,33 @@
cabal-version: 2.2
name: laantas-script
version: 0.1.0
synopsis: write lántas script
license: AGPL-3.0-or-later
author: Rhiannon Morris <rhi@rhiannon.website>
maintainer: Rhiannon Morris <rhi@rhiannon.website>
executable laantas-script
hs-source-dirs: .
main-is: laantas-script.hs
other-modules:
Svg,
Glyphs
default-language: Haskell2010
default-extensions:
BlockArguments,
DisambiguateRecordFields,
DuplicateRecordFields,
LambdaCase,
NamedFieldPuns,
OverloadedStrings,
RecordWildCards
build-depends:
base ^>= 4.14.0.0,
containers ^>= 0.6.2.1,
mtl ^>= 2.2.2,
svg-builder ^>= 0.1.1,
optparse-applicative ^>= 0.16.0.0,
text ^>= 1.2.3.2
ghc-options:
-Wall -threaded -rtsopts -with-rtsopts=-N

View File

@ -0,0 +1,104 @@
{-# 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.]), (G.nt, [G.da]), (G.s0, [])]
let res = doGlyphs [lántas, lántas] (E {..})
writeFile "/home/niss/e.svg" $ show res