Layout.hs

module Graphics.MSDF.Atlas.Layout where

import Data.Aeson
import Data.Char (ord)
import Data.IntMap (IntMap)
import Data.IntMap qualified as IntMap
import Data.Vector (Vector)
import Data.Vector qualified as Vector
import GHC.Generics (Generic)

data Layout = Layout
  { atlas :: Atlas
  , metrics :: Metrics
  , glyphs :: Vector Glyph
  , kerning :: Vector Kerning
  }
  deriving (Eq, Ord, Show, Generic)

instance FromJSON Layout
instance ToJSON Layout

data Atlas = Atlas
  { aType :: AtlasType
  , distanceRange :: Maybe Float
  , distanceRangeMiddle :: Maybe Float
  , size :: Float -- ^ The `size` field represents the font size in pixels per em.
  , width :: Int -- ^ Atlas image width in pixels
  , height :: Int -- ^ Atlas image height in pixels
  , yOrigin :: YOrigin
  }
  deriving (Eq, Ord, Show, Generic)

instance FromJSON Atlas where
  parseJSON = withObject "Atlas" \o -> do
    aType <- o .: "type"
    distanceRange <- o .:? "distanceRange"
    distanceRangeMiddle <- o .:? "distanceRangeMiddle"
    size <- o .: "size"
    width <- o .: "width"
    height <- o .: "height"
    yOrigin <- o .: "yOrigin"
    pure Atlas{..}

instance ToJSON Atlas where
  toJSON Atlas{..} = object
    [ "type" .= aType
    , "distanceRange" .= distanceRange
    , "distanceRangeMiddle" .= distanceRangeMiddle
    , "size" .= size
    , "width" .= width
    , "height" .= height
    , "yOrigin" .= yOrigin
    ]

data AtlasType
  = Hardmask -- ^ non-anti-aliased binary image
  | Softmask -- ^ anti-aliased image
  | SDF -- ^ true signed distance field (SDF)
  | PSDF -- ^ signed perpendicular distance field (PSDF)
  | MSDF -- ^ multi-channel signed distance field (MSDF)
  | MTSDF -- ^ combination of MSDF and true SDF in the alpha channel
  deriving (Eq, Ord, Show, Enum, Bounded, Generic)

instance FromJSON AtlasType where
  parseJSON = withText "AtlasType" \case
    "hardmask" -> pure Hardmask
    "softmask" -> pure Softmask
    "sdf" -> pure SDF
    "psdf" -> pure PSDF
    "msdf" -> pure MSDF
    "mtsdf" -> pure MTSDF
    huh -> fail $ "Unexpected AtlasType: " <> show huh

instance ToJSON AtlasType where
  toJSON = \case
    Hardmask -> "hardmask"
    Softmask -> "softmask"
    SDF -> "sdf"
    PSDF -> "psdf"
    MSDF -> "msdf"
    MTSDF -> "mtsdf"

data YOrigin
  = Top
  | Bottom
  deriving (Eq, Ord, Show, Enum, Bounded, Generic)

instance FromJSON YOrigin where
  parseJSON = withText "yOrigin" \case
    "top" -> pure Top
    "bottom" -> pure Bottom
    huh -> fail $ "Unexpected yOrigin: " <> show huh

instance ToJSON YOrigin where
  toJSON = \case
    Top -> String "top"
    Bottom -> String "bottom"

    -- - If there are multiple input fonts (`-and` parameter), the remaining data are grouped into `variants`, each representing an input font.
    --

-- | Useful font metric values retrieved from the font. All values are in em's.
data Metrics = Metrics
  { emSize :: Float
  , lineHeight :: Float
  , ascender :: Float
  , descender :: Float
  , underlineY :: Float
  , underlineThickness :: Float
  }
  deriving (Eq, Ord, Show, Generic)

instance FromJSON Metrics
instance ToJSON Metrics

data Glyph = Glyph
  { index :: Maybe Int
  , unicode :: Maybe Int
  , advance :: Float
  , planeBounds :: Maybe Bounds
  , atlasBounds :: Maybe Bounds
  }
  deriving (Eq, Ord, Show, Generic)

instance FromJSON Glyph
instance ToJSON Glyph

newtype ByCodepoint = ByCodepoint (IntMap Glyph)
  deriving (Eq, Ord, Show, Generic)

instance FromJSON ByCodepoint
instance ToJSON ByCodepoint

byCodepoint :: Foldable t => t Glyph -> ByCodepoint
byCodepoint = ByCodepoint . foldr (\g@Glyph{unicode} rest -> maybe rest (\i -> IntMap.insert i g rest) unicode) mempty

lookupCodepoint :: Char -> ByCodepoint -> Maybe Glyph
lookupCodepoint c (ByCodepoint gs) = IntMap.lookup (ord c) gs

newtype ByIndex = ByIndex (Vector Glyph)
  deriving (Eq, Ord, Show, Generic)

lookupGlyph :: Int -> ByIndex -> Maybe Glyph
lookupGlyph ix (ByIndex gs) = Vector.indexM gs ix

byIndex :: Foldable t => t Glyph -> Either String ByIndex
byIndex = extract . foldr collect mempty
  where
    collect g@Glyph{index} next = maybe next (\i -> IntMap.insert i g next) index
    extract m =
      if IntMap.keys m == [0 .. IntMap.size m - 1] then
        Right . ByIndex $ Vector.fromList (IntMap.elems m)
      else
        Left "Glyph indices aren't contiguous"

data Bounds = Bounds
  { left, top, right, bottom :: Float
  }
  deriving (Eq, Ord, Show, Generic)

instance FromJSON Bounds
instance ToJSON Bounds

data Kerning = Kerning
  { advance :: Float
  , unicode1 :: Maybe Int
  , unicode2 :: Maybe Int
  , index1 :: Maybe Int
  , index2 :: Maybe Int
  }
  deriving (Eq, Ord, Show, Generic)

instance FromJSON Kerning
instance ToJSON Kerning

    -- - `glyphs` is an array of individual glyphs identified by Unicode character index (`unicode`) or glyph index (`index`), depending on whether character set or glyph set mode is used.
    --     - `advance` is the horizontal advance in em's.
    --     - `planeBounds` represents the glyph quad's bounds in em's relative to the baseline and horizontal cursor position.
    --     - `atlasBounds` represents the glyph's bounds in the atlas in pixels.
    -- - If available, `kerning` lists all kerning pairs and their advance adjustment (which needs to be added to the base advance of the first glyph in the pair).