Unfinished HVIF types + decoder

.gitignore

@@ -0,0 +1,3 @@
+dist
+dist-newstyle
+*~

Graphics/HVIF.hs

@@ -0,0 +1,225 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Graphics.HVIF where
+
+import           Control.Monad (replicateM, when)
+import           Data.Bits ((.|.), clearBit, shift, testBit)
+import           Data.ByteString (ByteString)
+import           Data.Sequence (Seq)
+import qualified Data.Sequence as S
+import           Data.Serialize
+import           Data.Word
+
+data HVIFFile = HVIFFile
+  { hvifColors :: Seq Style
+  , hvifPaths  :: Seq Path
+  , hvifShapes :: Seq Shape
+  } deriving (Eq, Show)
+
+decodeFile :: ByteString -> Either String HVIFFile
+decodeFile = runGet pFile
+
+getSeveral :: Get a -> Get (Seq a)
+getSeveral getter = do
+  count <- getWord8
+  S.fromList `fmap` replicateM (fromIntegral count) getter
+
+pFile :: Get HVIFFile
+pFile = do
+  header <- getByteString 4
+  when (header /= "ncif") $
+    fail "Missing `ficn' header"
+  hvifColors <- getSeveral pStyle
+  hvifPaths  <- getSeveral pPath
+  hvifShapes <- getSeveral pShape
+  return HVIFFile { .. }
+
+-- Style Section
+
+data Style
+  = ColorSolid Word8 Word8 Word8 Word8
+  | ColorGradient Gradient
+  | ColorSolidNoAlpha Word8 Word8 Word8
+  | ColorSolidGray Word8 Word8
+  | ColorSolidGrayNoAlpha Word8
+    deriving (Eq, Show)
+
+pStyle :: Get Style
+pStyle = do
+  sType <- getWord8
+  case sType of
+    0x01 -> ColorSolid <$> get <*> get <*> get <*> get
+    0x02 -> ColorGradient <$> pGradient
+    0x03 -> ColorSolidNoAlpha <$> get <*> get <*> get
+    0x04 -> ColorSolidGray <$> get <*> get
+    0x05 -> ColorSolidGrayNoAlpha <$> get
+    _    -> fail "invalid"
+
+
+data Gradient = Gradient
+  { gType  :: GradientType
+  , gFlags :: GradientFlags
+  , gStops :: Seq GradientStop
+  } deriving (Eq, Show)
+
+pGradient :: Get Gradient
+pGradient = do
+  gType  <- pGradientType
+  gFlags <- pGradientFlags
+  gStops <- getSeveral (pGradientStop gFlags)
+  return Gradient { .. }
+
+data GradientType
+  = GTLinear
+  | GTCircular
+  | GTDiamond
+  | GTConic
+  | GTXY
+  | GTSqrtXY
+    deriving (Eq, Show)
+
+pGradientType :: Get GradientType
+pGradientType = do
+  gType <- getWord8
+  case gType of
+    00 -> return GTLinear
+    01 -> return GTCircular
+    02 -> return GTDiamond
+    03 -> return GTConic
+    04 -> return GTXY
+    05 -> return GTSqrtXY
+    _  -> fail ("Unknown gradient type: " ++ show gType)
+
+
+data GradientFlags = GradientFlags
+  { gfTransform :: Bool
+  , gfNoAlpha   :: Bool
+  , gf16Bit     :: Bool
+  , gfGrays     :: Bool
+  } deriving (Eq, Show)
+
+pGradientFlags :: Get GradientFlags
+pGradientFlags = do
+  gFlags <- getWord8
+  return $ GradientFlags
+    { gfTransform = testBit gFlags 1
+    , gfNoAlpha   = testBit gFlags 2
+    , gf16Bit     = testBit gFlags 3
+    , gfGrays     = testBit gFlags 4
+    }
+
+data GradientStop = GradientStop
+  { gsOffset :: Word8
+  , gsRed    :: Word8
+  , gsGreen  :: Word8
+  , gsBlue   :: Word8
+  , gsAlpha  :: Word8
+  } deriving (Eq, Show)
+
+pGradientStop :: GradientFlags -> Get GradientStop
+pGradientStop flags = do
+  offset <- get
+  (r, g, b) <-
+    if gfGrays flags
+      then do
+        val <- get
+        return (val, val, val)
+      else do
+        r <- get
+        g <- get
+        b <- get
+        return (r, g, b)
+  a <-
+    if gfNoAlpha flags
+      then return 0xff
+      else get
+  return $ GradientStop offset r g b a
+
+
+-- Path Section
+
+data Path = Path
+  { pathFlags  :: PathFlags
+  , pathPoints :: Seq Point
+  } deriving (Eq, Show)
+
+pPath :: Get Path
+pPath = do
+  pathFlags <- pPathFlags
+  pathPoints <- pPoints pathFlags
+  return Path { .. }
+
+data PathFlags = PathFlags
+  { pfClosed       :: Bool
+  , pfUsesCommands :: Bool
+  , pfNoCurves     :: Bool
+  } deriving (Eq, Show)
+
+pPathFlags :: Get PathFlags
+pPathFlags = do
+  pFlags <- getWord8
+  return $ PathFlags
+    { pfClosed       = testBit pFlags 1
+    , pfUsesCommands = testBit pFlags 2
+    , pfNoCurves     = testBit pFlags 3
+    }
+
+data Point = Point
+  { coordX :: Float
+  , coordY :: Float
+  } deriving (Eq, Show)
+
+pPoints :: PathFlags -> Get (Seq Point)
+pPoints PathFlags { pfUsesCommands = False } =
+  getSeveral (Point <$> pCoord <*> pCoord)
+pPoints PathFlags { pfUsesCommands = True } = do
+  c1 <- getWord8
+  c2 <- getWord8
+  return $ S.empty
+
+pCoord :: Get Float
+pCoord = do
+  b1 <- getWord8
+  if testBit b1 7 then do
+    b2 <- getWord8
+    let cVal :: Word16 = (clearBit 7 (fromIntegral b1) `shift` 8) .|. fromIntegral b2
+    return ((fromIntegral cVal / 102.0) - 128.0)
+  else
+    return (fromIntegral b1 - 32.0)
+
+-- Shape Section
+
+data Shape = Shape
+  { shapeStyle :: StyleRef
+  , shapePaths :: Seq PathRef
+  , shapeFlags :: ShapeFlags
+  } deriving (Eq, Show)
+
+pShape :: Get Shape
+pShape = do
+  shapeStyle <- StyleRef <$> get
+  shapePaths <- getSeveral (PathRef <$> get)
+  shapeFlags <- pShapeFlags
+  return Shape { .. }
+
+newtype PathRef = PathRef { prIdx :: Word8 } deriving (Eq, Show)
+newtype StyleRef = StyleRef { stIdx :: Word8 } deriving (Eq, Show)
+
+data ShapeFlags = ShapeFlags
+  { sfTransform       :: Bool
+  , sfHinting         :: Bool
+  , sfLodScale        :: Bool
+  , sfHasTransformers :: Bool
+  , sfTranslation     :: Bool
+  } deriving (Eq, Show)
+
+pShapeFlags :: Get ShapeFlags
+pShapeFlags = do
+  sFlags <- getWord8
+  return ShapeFlags
+    { sfTransform       = testBit sFlags 1
+    , sfHinting         = testBit sFlags 2
+    , sfLodScale        = testBit sFlags 3
+    , sfHasTransformers = testBit sFlags 4
+    , sfTranslation     = testBit sFlags 5
+    }

hvif.cabal

@@ -0,0 +1,23 @@
+name:             hvif
+version:          0.1.0.0
+-- synopsis:
+-- description:
+license:          BSD3
+license-file:     LICENSE
+author:           Getty Ritter <gettylefou@gmail.com>
+maintainer:       Getty Ritter <gettylefou@gmail.com>
+copyright:        ©2016 Getty Ritter
+-- category:
+build-type:       Simple
+cabal-version:    >= 1.12
+
+library
+  exposed-modules:     Graphics.HVIF
+  ghc-options:         -Wall
+  build-depends:       base >=4.7 && <4.9
+                     , bytestring
+                     , cereal
+                     , containers
+  default-language:    Haskell2010
+  default-extensions:  OverloadedStrings,
+                       ScopedTypeVariables