{-# 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), ("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)]

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}
tð = G {path = tðPath, width = 9}
tp = G {path = tpPath, width = 9}
tb = G {path = tbPath, width = 10}
ts = G {path = tsPath, width = 9}
tš = 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}
tč = G {path = tčPath, width = 9}
tǧ = 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), ("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)]

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}
sð = G {path = sðPath, width = 9}
sp = G {path = spPath, width = 10}
sb = G {path = sbPath, width = 10}
ss = G {path = ssPath, width = 10}
sš = 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}
sč = G {path = sčPath, width = 9}
sǧ = 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, 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)]

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ḿ, 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),
              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 (-3,-2.5), aR 1 1 0 Small CCW (0,2)]
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),
              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)]
dŕ = da <> Shift (-3) 5 rPartShort