BasicV2.hs

module Codec.Ktx2.DFD.Khronos.BasicV2 where

import Data.Binary (Binary(..))
import Data.Binary.Get (Get, getWord8, getWord16le, getWord32le, runGetOrFail)
import Data.Binary.Put (PutM, putWord8, putWord16le, putWord32le, runPut)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BSL
import Data.ByteString.Lazy qualified as LBS
import Data.Vector (Vector)
import Data.Vector qualified as Vector
import Data.Word (Word8, Word16, Word32)
import GHC.Generics (Generic)

import Codec.Ktx2.DFD qualified as DFD

-- | Khronos
pattern VENDOR_ID :: (Eq a, Num a) => a
pattern VENDOR_ID = 0

-- | Basic DFD Block
pattern DESCRIPTOR_TYPE :: (Eq a, Num a) => a
pattern DESCRIPTOR_TYPE = 0

-- | KDF v1.3
pattern VERSION :: (Eq a, Num a) => a
pattern VERSION = 2

{- |
  A basic descriptor block is designed to encode common metadata associated with bulk data — especially image or texture data.

  While this descriptor holds more information about the data interpretation than is needed by many applications,
  a comprehensive encoding reduces the risk of metadata needed by different APIs being lost in translation.

  The format is described in terms of a repeating axis-aligned texel block composed of samples.
  Each sample contains a single channel of information with a single spatial offset within the texel block,
  and consists of an amount of contiguous data. This descriptor block consists of information about the interpretation
  of the texel block as a whole, supplemented by a description of a number of samples taken from one or more planes of contiguous memory.

  <https://registry.khronos.org/DataFormat/specs/1.3/dataformat.1.3.html>
-}
data BasicV2 = BasicV2
  { colorModel :: Word8
  , colorPrimaries :: Word8
  , transferFunction :: Word8
  , flags :: Word8

  , texelBlockDimension0 :: Word8
    {- ^
      The value held in each of these fields is one fewer than the size of the block in that dimension — 
      that is, a value of 0 represents a size of 1, a value of 1 represents a size of 2, etc.

      A texel block which covers fewer than four dimensions should have a size of 1 in each dimension
      that it lacks, and therefore the corresponding fields in the representation should be 0.
    -}
  , texelBlockDimension1 :: Word8
  , texelBlockDimension2 :: Word8
  , texelBlockDimension3 :: Word8

  , bytesPlane0 :: Word8
  , bytesPlane1 :: Word8
  , bytesPlane2 :: Word8
  , bytesPlane3 :: Word8
  , bytesPlane4 :: Word8
  , bytesPlane5 :: Word8
  , bytesPlane6 :: Word8
  , bytesPlane7 :: Word8

  , samples :: Vector Sample
  }
  deriving (Eq, Show, Generic)

getter :: Int -> Get BasicV2
getter numSamples = do
  colorModel <- getWord8
  colorPrimaries <- getWord8
  transferFunction <- getWord8
  flags <- getWord8

  texelBlockDimension0 <- fmap (+ 1) getWord8
  texelBlockDimension1 <- fmap (+ 1) getWord8
  texelBlockDimension2 <- fmap (+ 1) getWord8
  texelBlockDimension3 <- fmap (+ 1) getWord8

  bytesPlane0 <- getWord8
  bytesPlane1 <- getWord8
  bytesPlane2 <- getWord8
  bytesPlane3 <- getWord8
  bytesPlane4 <- getWord8
  bytesPlane5 <- getWord8
  bytesPlane6 <- getWord8
  bytesPlane7 <- getWord8

  samples <- Vector.replicateM numSamples get

  pure BasicV2{..}

putter :: BasicV2 -> PutM ()
putter BasicV2{..} = do
  putWord8 colorModel
  putWord8 colorPrimaries
  putWord8 transferFunction
  putWord8 flags

  putWord8 $ texelBlockDimension0 - 1
  putWord8 $ texelBlockDimension1 - 1
  putWord8 $ texelBlockDimension2 - 1
  putWord8 $ texelBlockDimension3 - 1

  putWord8 bytesPlane0
  putWord8 bytesPlane1
  putWord8 bytesPlane2
  putWord8 bytesPlane3
  putWord8 bytesPlane4
  putWord8 bytesPlane5
  putWord8 bytesPlane6
  putWord8 bytesPlane7

  Vector.mapM_ put samples

data Sample = Sample
  { bitOffset :: Word16
  , bitLength :: Word8
  , channelType :: Word8

  , samplePosition0 :: Word8
  , samplePosition1 :: Word8
  , samplePosition2 :: Word8
  , samplePosition3 :: Word8

  , sampleLower :: Word32
  , sampleUpper :: Word32
  }
  deriving (Eq, Show, Generic)

instance Binary Sample where
  get = do
    bitOffset <- getWord16le
    bitLength <- fmap (+1) getWord8
    channelType <- getWord8

    samplePosition0 <- getWord8
    samplePosition1 <- getWord8
    samplePosition2 <- getWord8
    samplePosition3 <- getWord8

    sampleLower <- getWord32le
    sampleUpper <- getWord32le

    pure Sample{..}

  put Sample{..} = do
    putWord16le bitOffset
    putWord8 $ bitLength - 1
    putWord8 channelType

    putWord8 samplePosition0
    putWord8 samplePosition1
    putWord8 samplePosition2
    putWord8 samplePosition3

    putWord32le sampleLower
    putWord32le sampleUpper

fromBlock :: DFD.Block -> Maybe BasicV2
fromBlock DFD.Block{descriptorBlockSize, body} =
  case runGetOrFail (getter numSamples) (LBS.fromChunks [body]) of
    Left _err ->
      Nothing
    Right (_bytes, _offset, ok) ->
      Just ok
  where
    numSamples =
      div (fromIntegral descriptorBlockSize - 24) 16

toBlock :: BasicV2 -> DFD.Block
toBlock v2 =
  DFD.Block
    { descriptorType =
        DESCRIPTOR_TYPE
    , vendorId =
        VENDOR_ID
    , versionNumber =
        VERSION
    , descriptorBlockSize =
        fromIntegral $ BS.length body + 8
    , body =
        body
    }
  where
    body = BSL.toStrict . runPut $ putter v2

-- * Constructors

unspecified :: BasicV2
unspecified = BasicV2
  { colorModel = KHR_DF_MODEL_UNSPECIFIED
  , colorPrimaries = KHR_DF_PRIMARIES_UNSPECIFIED
  , transferFunction = KHR_DF_TRANSFER_LINEAR
  , flags = KHR_DF_FLAG_ALPHA_STRAIGHT
  , texelBlockDimension0 = 1
  , texelBlockDimension1 = 1
  , texelBlockDimension2 = 1
  , texelBlockDimension3 = 1
  , bytesPlane0 = 0
  , bytesPlane1 = 0
  , bytesPlane2 = 0
  , bytesPlane3 = 0
  , bytesPlane4 = 0
  , bytesPlane5 = 0
  , bytesPlane6 = 0
  , bytesPlane7 = 0
  , samples = mempty
  }

-- * Patterns

pattern KHR_DF_MODEL_UNSPECIFIED :: Word8
pattern KHR_DF_MODEL_UNSPECIFIED = 0

pattern KHR_DF_MODEL_RGBSDA :: Word8
pattern KHR_DF_MODEL_RGBSDA = 1

pattern KHR_DF_MODEL_YUVSDA :: Word8
pattern KHR_DF_MODEL_YUVSDA = 2

pattern KHR_DF_MODEL_YIQSDA :: Word8
pattern KHR_DF_MODEL_YIQSDA = 3

pattern KHR_DF_MODEL_LABSDA :: Word8
pattern KHR_DF_MODEL_LABSDA = 4

pattern KHR_DF_MODEL_CMYKA :: Word8
pattern KHR_DF_MODEL_CMYKA = 5

pattern KHR_DF_MODEL_XYZW :: Word8
pattern KHR_DF_MODEL_XYZW = 6

pattern KHR_DF_MODEL_HSVA_ANG :: Word8
pattern KHR_DF_MODEL_HSVA_ANG = 7

pattern KHR_DF_MODEL_HSLA_ANG :: Word8
pattern KHR_DF_MODEL_HSLA_ANG = 8

pattern KHR_DF_MODEL_HSVA_HEX :: Word8
pattern KHR_DF_MODEL_HSVA_HEX = 9

pattern KHR_DF_MODEL_HSLA_HEX :: Word8
pattern KHR_DF_MODEL_HSLA_HEX = 10

pattern KHR_DF_MODEL_YCGCOA :: Word8
pattern KHR_DF_MODEL_YCGCOA = 11

pattern KHR_DF_MODEL_YCCBCCRC :: Word8
pattern KHR_DF_MODEL_YCCBCCRC = 12

pattern KHR_DF_MODEL_ICTCP :: Word8
pattern KHR_DF_MODEL_ICTCP = 13

pattern KHR_DF_MODEL_CIEXYZ :: Word8
pattern KHR_DF_MODEL_CIEXYZ = 14

pattern KHR_DF_MODEL_CIEXYY :: Word8
pattern KHR_DF_MODEL_CIEXYY = 15

-- *** Compressed formats

pattern KHR_DF_MODEL_DXT1A :: Word8
pattern KHR_DF_MODEL_DXT1A = 128

pattern KHR_DF_MODEL_BC1A :: Word8
pattern KHR_DF_MODEL_BC1A = KHR_DF_MODEL_DXT1A

pattern KHR_DF_MODEL_DXT2 :: Word8
pattern KHR_DF_MODEL_DXT2 = 129

pattern KHR_DF_MODEL_DXT3 :: Word8
pattern KHR_DF_MODEL_DXT3 = KHR_DF_MODEL_DXT2

pattern KHR_DF_MODEL_BC2 :: Word8
pattern KHR_DF_MODEL_BC2 = KHR_DF_MODEL_DXT2

pattern KHR_DF_MODEL_DXT4 :: Word8
pattern KHR_DF_MODEL_DXT4 = 130

pattern KHR_DF_MODEL_DXT5 :: Word8
pattern KHR_DF_MODEL_DXT5 = KHR_DF_MODEL_DXT4

pattern KHR_DF_MODEL_BC3 :: Word8
pattern KHR_DF_MODEL_BC3 = KHR_DF_MODEL_DXT4

pattern KHR_DF_MODEL_BC4 :: Word8
pattern KHR_DF_MODEL_BC4 = 131

pattern KHR_DF_MODEL_BC5 :: Word8
pattern KHR_DF_MODEL_BC5 = 132

pattern KHR_DF_MODEL_BC6H :: Word8
pattern KHR_DF_MODEL_BC6H = 133

pattern KHR_DF_MODEL_BC7 :: Word8
pattern KHR_DF_MODEL_BC7 = 134


pattern KHR_DF_MODEL_ETC1 :: Word8
pattern KHR_DF_MODEL_ETC1 = 160

pattern KHR_DF_MODEL_ETC2 :: Word8
pattern KHR_DF_MODEL_ETC2 = 161

pattern KHR_DF_MODEL_ASTC2 :: Word8
pattern KHR_DF_MODEL_ASTC2 = 162

pattern KHR_DF_MODEL_ETC1S :: Word8
pattern KHR_DF_MODEL_ETC1S = 163

pattern KHR_DF_MODEL_PVRTC :: Word8
pattern KHR_DF_MODEL_PVRTC = 164

pattern KHR_DF_MODEL_PVRTC2 :: Word8
pattern KHR_DF_MODEL_PVRTC2 = 165

-- ** Color primaries

pattern KHR_DF_PRIMARIES_UNSPECIFIED :: Word8
pattern KHR_DF_PRIMARIES_UNSPECIFIED = 0

pattern KHR_DF_PRIMARIES_BT709 :: Word8
pattern KHR_DF_PRIMARIES_BT709 = 1

pattern KHR_DF_PRIMARIES_SRGB :: Word8
pattern KHR_DF_PRIMARIES_SRGB = KHR_DF_PRIMARIES_BT709

pattern KHR_DF_PRIMARIES_BT601_EBU :: Word8
pattern KHR_DF_PRIMARIES_BT601_EBU = 2

pattern KHR_DF_PRIMARIES_BT601_SMPTE :: Word8
pattern KHR_DF_PRIMARIES_BT601_SMPTE = 3

pattern KHR_DF_PRIMARIES_BT2020 :: Word8
pattern KHR_DF_PRIMARIES_BT2020 = 4

pattern KHR_DF_PRIMARIES_CIEXYZ :: Word8
pattern KHR_DF_PRIMARIES_CIEXYZ = 5

pattern KHR_DF_PRIMARIES_ACES :: Word8
pattern KHR_DF_PRIMARIES_ACES = 6

pattern KHR_DF_PRIMARIES_ACESCC :: Word8
pattern KHR_DF_PRIMARIES_ACESCC = 7

pattern KHR_DF_PRIMARIES_NTSC1953 :: Word8
pattern KHR_DF_PRIMARIES_NTSC1953 = 8

pattern KHR_DF_PRIMARIES_PAL525 :: Word8
pattern KHR_DF_PRIMARIES_PAL525 = 9

pattern KHR_DF_PRIMARIES_DISPLAYP3 :: Word8
pattern KHR_DF_PRIMARIES_DISPLAYP3 = 10

pattern KHR_DF_PRIMARIES_ADOBERGB :: Word8
pattern KHR_DF_PRIMARIES_ADOBERGB = 11

-- ** Transfer functions

pattern KHR_DF_TRANSFER_UNSPECIFIED :: Word8
pattern KHR_DF_TRANSFER_UNSPECIFIED = 0

pattern KHR_DF_TRANSFER_LINEAR :: Word8
pattern KHR_DF_TRANSFER_LINEAR = 1

pattern KHR_DF_TRANSFER_SRGB :: Word8
pattern KHR_DF_TRANSFER_SRGB = 2

pattern KHR_DF_TRANSFER_ITU :: Word8
pattern KHR_DF_TRANSFER_ITU = 3

pattern KHR_DF_TRANSFER_NTSC :: Word8
pattern KHR_DF_TRANSFER_NTSC = 4

pattern KHR_DF_TRANSFER_SLOG :: Word8
pattern KHR_DF_TRANSFER_SLOG = 5

pattern KHR_DF_TRANSFER_SLOG2 :: Word8
pattern KHR_DF_TRANSFER_SLOG2 = 6

pattern KHR_DF_TRANSFER_BT1886 :: Word8
pattern KHR_DF_TRANSFER_BT1886 = 7

pattern KHR_DF_TRANSFER_HLG_OETF :: Word8
pattern KHR_DF_TRANSFER_HLG_OETF = 8

pattern KHR_DF_TRANSFER_HLG_EOTF :: Word8
pattern KHR_DF_TRANSFER_HLG_EOTF = 9

pattern KHR_DF_TRANSFER_PQ_EOTF :: Word8
pattern KHR_DF_TRANSFER_PQ_EOTF = 10

pattern KHR_DF_TRANSFER_PQ_OETF :: Word8
pattern KHR_DF_TRANSFER_PQ_OETF = 11

pattern KHR_DF_TRANSFER_DCIP3 :: Word8
pattern KHR_DF_TRANSFER_DCIP3 = 12

pattern KHR_DF_TRANSFER_PAL_OETF :: Word8
pattern KHR_DF_TRANSFER_PAL_OETF = 13

pattern KHR_DF_TRANSFER_PAL625_EOTF :: Word8
pattern KHR_DF_TRANSFER_PAL625_EOTF = 14

pattern KHR_DF_TRANSFER_ST240 :: Word8
pattern KHR_DF_TRANSFER_ST240 = 15

pattern KHR_DF_TRANSFER_ACESCC :: Word8
pattern KHR_DF_TRANSFER_ACESCC = 16

pattern KHR_DF_TRANSFER_ACESCCT :: Word8
pattern KHR_DF_TRANSFER_ACESCCT = 17

pattern KHR_DF_TRANSFER_ADOBERGB :: Word8
pattern KHR_DF_TRANSFER_ADOBERGB = 18

-- ** Flags

pattern KHR_DF_FLAG_ALPHA_STRAIGHT :: Word8
pattern KHR_DF_FLAG_ALPHA_STRAIGHT = 0

pattern KHR_DF_FLAG_ALPHA_PREMULTIPLIED :: Word8
pattern KHR_DF_FLAG_ALPHA_PREMULTIPLIED = 1

-- ** Samples

pattern KHR_DF_SAMPLE_DATATYPE_FLOAT :: (Eq a, Num a) => a
pattern KHR_DF_SAMPLE_DATATYPE_FLOAT = 0x80

pattern KHR_DF_SAMPLE_DATATYPE_SIGNED :: (Eq a, Num a) => a
pattern KHR_DF_SAMPLE_DATATYPE_SIGNED = 0x40

pattern KHR_DF_SAMPLE_DATATYPE_EXPONENT :: (Eq a, Num a) => a
pattern KHR_DF_SAMPLE_DATATYPE_EXPONENT = 0x20

pattern KHR_DF_SAMPLE_DATATYPE_LINEAR :: (Eq a, Num a) => a
pattern KHR_DF_SAMPLE_DATATYPE_LINEAR = 0x10