{- |
  JSON font loader for bitmaps and SDFs

  Generator: https://evanw.github.io/font-texture-generator/

  Usage (WebGL): https://evanw.github.io/font-texture-generator/example-webgl/
-}

module Resource.Font.EvanW
  ( load
  , Container(..)
  , Character(..)

  , putLine
  , PutChar(..)
  ) where

import RIO

import Data.Aeson (FromJSON, eitherDecodeStrict')
import Foreign qualified
import Geomancy (Vec2, vec2, pattern WithVec2)
import GHC.Stack (withFrozenCallStack)
import RIO.HashMap qualified as HashMap
import RIO.Text qualified as Text
import Vulkan.NamedType ((:::))

import Engine.UI.Layout qualified as Layout
import Resource.Source (Source)
import Resource.Source qualified as Source

-- * Loading

newtype FontError = FontError Text
  deriving (FontError -> FontError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FontError -> FontError -> Bool
$c/= :: FontError -> FontError -> Bool
== :: FontError -> FontError -> Bool
$c== :: FontError -> FontError -> Bool
Eq, Eq FontError
FontError -> FontError -> Bool
FontError -> FontError -> Ordering
FontError -> FontError -> FontError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FontError -> FontError -> FontError
$cmin :: FontError -> FontError -> FontError
max :: FontError -> FontError -> FontError
$cmax :: FontError -> FontError -> FontError
>= :: FontError -> FontError -> Bool
$c>= :: FontError -> FontError -> Bool
> :: FontError -> FontError -> Bool
$c> :: FontError -> FontError -> Bool
<= :: FontError -> FontError -> Bool
$c<= :: FontError -> FontError -> Bool
< :: FontError -> FontError -> Bool
$c< :: FontError -> FontError -> Bool
compare :: FontError -> FontError -> Ordering
$ccompare :: FontError -> FontError -> Ordering
Ord, Int -> FontError -> ShowS
[FontError] -> ShowS
FontError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FontError] -> ShowS
$cshowList :: [FontError] -> ShowS
show :: FontError -> String
$cshow :: FontError -> String
showsPrec :: Int -> FontError -> ShowS
$cshowsPrec :: Int -> FontError -> ShowS
Show, forall x. Rep FontError x -> FontError
forall x. FontError -> Rep FontError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FontError x -> FontError
$cfrom :: forall x. FontError -> Rep FontError x
Generic)

instance Exception FontError

data Container = Container
  { Container -> Text
name       :: Text
  , Container -> Float
size       :: Float
  , Container -> Bool
bold       :: Bool
  , Container -> Bool
italic     :: Bool
  , Container -> Float
width      :: Float
  , Container -> Float
height     :: Float
  , Container -> HashMap Char Character
characters :: HashMap Char Character
  }
  deriving (Container -> Container -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Container -> Container -> Bool
$c/= :: Container -> Container -> Bool
== :: Container -> Container -> Bool
$c== :: Container -> Container -> Bool
Eq, Eq Container
Container -> Container -> Bool
Container -> Container -> Ordering
Container -> Container -> Container
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Container -> Container -> Container
$cmin :: Container -> Container -> Container
max :: Container -> Container -> Container
$cmax :: Container -> Container -> Container
>= :: Container -> Container -> Bool
$c>= :: Container -> Container -> Bool
> :: Container -> Container -> Bool
$c> :: Container -> Container -> Bool
<= :: Container -> Container -> Bool
$c<= :: Container -> Container -> Bool
< :: Container -> Container -> Bool
$c< :: Container -> Container -> Bool
compare :: Container -> Container -> Ordering
$ccompare :: Container -> Container -> Ordering
Ord, Int -> Container -> ShowS
[Container] -> ShowS
Container -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Container] -> ShowS
$cshowList :: [Container] -> ShowS
show :: Container -> String
$cshow :: Container -> String
showsPrec :: Int -> Container -> ShowS
$cshowsPrec :: Int -> Container -> ShowS
Show, forall x. Rep Container x -> Container
forall x. Container -> Rep Container x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Container x -> Container
$cfrom :: forall x. Container -> Rep Container x
Generic)

data Character = Character
  { Character -> Float
x       :: Float
  , Character -> Float
y       :: Float
  , Character -> Float
width   :: Float
  , Character -> Float
height  :: Float
  , Character -> Float
originX :: Float
  , Character -> Float
originY :: Float
  , Character -> Float
advance :: Float
  }
  deriving (Character -> Character -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Character -> Character -> Bool
$c/= :: Character -> Character -> Bool
== :: Character -> Character -> Bool
$c== :: Character -> Character -> Bool
Eq, Eq Character
Character -> Character -> Bool
Character -> Character -> Ordering
Character -> Character -> Character
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Character -> Character -> Character
$cmin :: Character -> Character -> Character
max :: Character -> Character -> Character
$cmax :: Character -> Character -> Character
>= :: Character -> Character -> Bool
$c>= :: Character -> Character -> Bool
> :: Character -> Character -> Bool
$c> :: Character -> Character -> Bool
<= :: Character -> Character -> Bool
$c<= :: Character -> Character -> Bool
< :: Character -> Character -> Bool
$c< :: Character -> Character -> Bool
compare :: Character -> Character -> Ordering
$ccompare :: Character -> Character -> Ordering
Ord, Int -> Character -> ShowS
[Character] -> ShowS
Character -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Character] -> ShowS
$cshowList :: [Character] -> ShowS
show :: Character -> String
$cshow :: Character -> String
showsPrec :: Int -> Character -> ShowS
$cshowsPrec :: Int -> Character -> ShowS
Show, forall x. Rep Character x -> Character
forall x. Character -> Rep Character x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Character x -> Character
$cfrom :: forall x. Character -> Rep Character x
Generic)

instance FromJSON Container
instance FromJSON Character

load
  :: ( MonadIO m
     , MonadReader env m
     , HasLogFunc env
     , HasCallStack
     )
  => Source -> m Container
load :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Source -> m Container
load =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$
    forall a (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, Typeable a,
 HasCallStack) =>
(ByteString -> m a) -> Source -> m a
Source.load \ByteString
bytes ->
      case forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict' ByteString
bytes of
        Left String
err ->
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FontError
FontError forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
err
        Right Container
res ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure Container
res

-- * Typesetting

data PutChar = PutChar
  { PutChar -> Vec2
pcPos    :: Vec2
  , PutChar -> Vec2
pcSize   :: Vec2
  , PutChar -> Vec2
pcOffset :: Vec2
  , PutChar -> Vec2
pcScale  :: Vec2
  } deriving (Int -> PutChar -> ShowS
[PutChar] -> ShowS
PutChar -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PutChar] -> ShowS
$cshowList :: [PutChar] -> ShowS
show :: PutChar -> String
$cshow :: PutChar -> String
showsPrec :: Int -> PutChar -> ShowS
$cshowsPrec :: Int -> PutChar -> ShowS
Show)

instance Foreign.Storable PutChar where
  alignment :: PutChar -> Int
alignment ~PutChar
_ = Int
16

  sizeOf :: PutChar -> Int
sizeOf ~PutChar
_ = Int
32 -- 4 of pairs of floats

  peek :: Ptr PutChar -> IO PutChar
peek Ptr PutChar
ptr = Vec2 -> Vec2 -> Vec2 -> Vec2 -> PutChar
PutChar
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> Int -> IO a
Foreign.peekElemOff (forall a b. Ptr a -> Ptr b
Foreign.castPtr Ptr PutChar
ptr) Int
0
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Storable a => Ptr a -> Int -> IO a
Foreign.peekElemOff (forall a b. Ptr a -> Ptr b
Foreign.castPtr Ptr PutChar
ptr) Int
1
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Storable a => Ptr a -> Int -> IO a
Foreign.peekElemOff (forall a b. Ptr a -> Ptr b
Foreign.castPtr Ptr PutChar
ptr) Int
2
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Storable a => Ptr a -> Int -> IO a
Foreign.peekElemOff (forall a b. Ptr a -> Ptr b
Foreign.castPtr Ptr PutChar
ptr) Int
3

  poke :: Ptr PutChar -> PutChar -> IO ()
poke Ptr PutChar
ptr PutChar{Vec2
pcScale :: Vec2
pcOffset :: Vec2
pcSize :: Vec2
pcPos :: Vec2
$sel:pcScale:PutChar :: PutChar -> Vec2
$sel:pcOffset:PutChar :: PutChar -> Vec2
$sel:pcSize:PutChar :: PutChar -> Vec2
$sel:pcPos:PutChar :: PutChar -> Vec2
..} = do
    forall a. Storable a => Ptr a -> Int -> a -> IO ()
Foreign.pokeElemOff (forall a b. Ptr a -> Ptr b
Foreign.castPtr Ptr PutChar
ptr) Int
0 Vec2
pcPos
    forall a. Storable a => Ptr a -> Int -> a -> IO ()
Foreign.pokeElemOff (forall a b. Ptr a -> Ptr b
Foreign.castPtr Ptr PutChar
ptr) Int
1 Vec2
pcSize
    forall a. Storable a => Ptr a -> Int -> a -> IO ()
Foreign.pokeElemOff (forall a b. Ptr a -> Ptr b
Foreign.castPtr Ptr PutChar
ptr) Int
2 Vec2
pcOffset
    forall a. Storable a => Ptr a -> Int -> a -> IO ()
Foreign.pokeElemOff (forall a b. Ptr a -> Ptr b
Foreign.castPtr Ptr PutChar
ptr) Int
3 Vec2
pcScale

putLine
  :: "WH"        ::: Vec2
  -> "XY"        ::: Vec2
  -> "Alignment" ::: Layout.Alignment
  -> "Size"      ::: Float
  -> "Font"      ::: Container
  -> "Line"      ::: [Char]
  -> ("scale" ::: Float, [PutChar])
putLine :: Vec2
-> Vec2
-> ("Alignment" ::: Alignment)
-> Float
-> Container
-> String
-> (Float, [PutChar])
putLine (WithVec2 Float
cw Float
ch) (WithVec2 Float
cx Float
cy) Layout.Alignment{Origin
$sel:alignY:Alignment :: ("Alignment" ::: Alignment) -> Origin
$sel:alignX:Alignment :: ("Alignment" ::: Alignment) -> Origin
alignY :: Origin
alignX :: Origin
..} Float
targetSize Container
font =
  (Float
sizeScale,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Float, Float, [(Vec2, Vec2, (Vec2, Vec2))]) -> [PutChar]
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Float, Float, [(Vec2, Vec2, (Vec2, Vec2))])
-> Char -> (Float, Float, [(Vec2, Vec2, (Vec2, Vec2))])
step (Float
0, Float
0, [])
  where
    Container
      { $sel:size:Container :: Container -> Float
size   = Float
fontSize
      , $sel:width:Container :: Container -> Float
width  = Float
atlasWidth
      , $sel:height:Container :: Container -> Float
height = Float
atlasHeight
      , HashMap Char Character
characters :: HashMap Char Character
$sel:characters:Container :: Container -> HashMap Char Character
characters
      } = Container
font

    sizeScale :: Float
sizeScale = Float
targetSize forall a. Fractional a => a -> a -> a
/ Float
fontSize

    extract :: (Float, Float, [(Vec2, Vec2, (Vec2, Vec2))]) -> [PutChar]
extract (Float
offX, Float
_offY, [(Vec2, Vec2, (Vec2, Vec2))]
bits) = do
      (WithVec2 Float
w Float
h, WithVec2 Float
x Float
y, (Vec2
offset, Vec2
scale)) <- [(Vec2, Vec2, (Vec2, Vec2))]
bits
      let
        ax :: Float
ax = case Origin
alignX of
          Origin
Layout.Begin  -> -Float
cw forall a. Fractional a => a -> a -> a
/ Float
2
          Origin
Layout.Middle -> -Float
offX forall a. Num a => a -> a -> a
* Float
sizeScale forall a. Fractional a => a -> a -> a
/ Float
2
          Origin
Layout.End    -> Float
cw forall a. Fractional a => a -> a -> a
/ Float
2 forall a. Num a => a -> a -> a
- Float
offX forall a. Num a => a -> a -> a
* Float
sizeScale

        ay :: Float
ay = case Origin
alignY of
          Origin
Layout.Begin  -> -Float
ch forall a. Fractional a => a -> a -> a
/ Float
2 forall a. Num a => a -> a -> a
+ Float
targetSize forall a. Num a => a -> a -> a
* Float
1.3
          Origin
Layout.Middle -> Float
targetSize forall a. Num a => a -> a -> a
* Float
0.5
          Origin
Layout.End    -> Float
ch forall a. Fractional a => a -> a -> a
/ Float
2 forall a. Num a => a -> a -> a
- Float
targetSize forall a. Num a => a -> a -> a
* Float
0.5

      forall (f :: * -> *) a. Applicative f => a -> f a
pure PutChar
        { $sel:pcPos:PutChar :: Vec2
pcPos    = Float -> Float -> Vec2
vec2 (Float
cx forall a. Num a => a -> a -> a
+ Float
ax forall a. Num a => a -> a -> a
+ Float
x forall a. Num a => a -> a -> a
* Float
sizeScale) (Float
cy forall a. Num a => a -> a -> a
+ Float
ay forall a. Num a => a -> a -> a
+ Float
y forall a. Num a => a -> a -> a
* Float
sizeScale)
        , $sel:pcSize:PutChar :: Vec2
pcSize   = Float -> Float -> Vec2
vec2 (Float
w forall a. Num a => a -> a -> a
* Float
sizeScale) (Float
h forall a. Num a => a -> a -> a
* Float
sizeScale)
        , $sel:pcOffset:PutChar :: Vec2
pcOffset = Vec2
offset
        , $sel:pcScale:PutChar :: Vec2
pcScale  = Vec2
scale
        }

    step :: (Float, Float, [(Vec2, Vec2, (Vec2, Vec2))])
-> Char -> (Float, Float, [(Vec2, Vec2, (Vec2, Vec2))])
step (Float
offX, Float
offY, [(Vec2, Vec2, (Vec2, Vec2))]
acc) Char
' ' =
      ( Float
offX forall a. Num a => a -> a -> a
+ Float
fontSize forall a. Fractional a => a -> a -> a
/ Float
2
      , Float
offY
      , [(Vec2, Vec2, (Vec2, Vec2))]
acc
      )

    step (Float
offX, Float
offY, [(Vec2, Vec2, (Vec2, Vec2))]
acc) Char
char =
      case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Char
char HashMap Char Character
characters forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Char
'?' HashMap Char Character
characters of
        Maybe Character
Nothing ->
          (Float
offX, Float
offY, [(Vec2, Vec2, (Vec2, Vec2))]
acc)
        Just Character{Float
advance :: Float
originY :: Float
originX :: Float
height :: Float
width :: Float
y :: Float
x :: Float
$sel:advance:Character :: Character -> Float
$sel:originY:Character :: Character -> Float
$sel:originX:Character :: Character -> Float
$sel:height:Character :: Character -> Float
$sel:width:Character :: Character -> Float
$sel:y:Character :: Character -> Float
$sel:x:Character :: Character -> Float
..} ->
          ( Float
offX forall a. Num a => a -> a -> a
+ Float
advance
          , Float
offY
          , ( Float -> Float -> Vec2
vec2 Float
width (-Float
height)
            , Float -> Float -> Vec2
vec2 Float
ox Float
oy
            , (Vec2
uvOffset, Vec2
uvScale)
            ) forall a. a -> [a] -> [a]
: [(Vec2, Vec2, (Vec2, Vec2))]
acc
          )
          where
            ox :: Float
ox = Float
offX forall a. Num a => a -> a -> a
+ Float
width forall a. Fractional a => a -> a -> a
/ Float
2 forall a. Num a => a -> a -> a
- Float
originX
            oy :: Float
oy = Float
offY forall a. Num a => a -> a -> a
+ Float
height forall a. Fractional a => a -> a -> a
/ Float
2 forall a. Num a => a -> a -> a
- Float
originY

            uvOffset :: Vec2
uvOffset = Float -> Float -> Vec2
vec2 (Float
x forall a. Fractional a => a -> a -> a
/ Float
atlasWidth) (Float
y forall a. Fractional a => a -> a -> a
/ Float
atlasHeight)
            uvScale :: Vec2
uvScale  = Float -> Float -> Vec2
vec2 (Float
width forall a. Fractional a => a -> a -> a
/ Float
atlasWidth) (Float
height forall a. Fractional a => a -> a -> a
/ Float
atlasHeight)