module Codec.Picture.STBIR
(
resize
, Options(..)
, defaultOptions
, Flag
, flag_ALPHA_PREMULTIPLIED
, flag_ALPHA_USES_COLORSPACE
, Edge(..)
, Filter(..)
, Colorspace(..)
, Scale(..)
, Region(..)
, STBIRPixel(..)
, STBIRComponent(..)
, Datatype(..)
) where
import qualified Foreign.C.Types as C2HSImp
import qualified Foreign.Ptr as C2HSImp
import Foreign
import Foreign.C
import Codec.Picture
import Codec.Picture.Types
import qualified Data.Vector.Storable as V
import System.IO.Unsafe (unsafePerformIO)
import Data.Default.Class (Default(..))
newtype Flag = Flag { fromFlag :: CInt }
deriving (Eq, Ord, Show, Read)
flag_ALPHA_PREMULTIPLIED :: Flag
flag_ALPHA_PREMULTIPLIED = Flag 1
flag_ALPHA_USES_COLORSPACE :: Flag
flag_ALPHA_USES_COLORSPACE = Flag 2
data Edge = EDGE_CLAMP
| EDGE_REFLECT
| EDGE_WRAP
| EDGE_ZERO
deriving (Eq,Ord,Show,Read,Bounded)
instance Enum Edge where
succ EDGE_CLAMP = EDGE_REFLECT
succ EDGE_REFLECT = EDGE_WRAP
succ EDGE_WRAP = EDGE_ZERO
succ EDGE_ZERO = error "Edge.succ: EDGE_ZERO has no successor"
pred EDGE_REFLECT = EDGE_CLAMP
pred EDGE_WRAP = EDGE_REFLECT
pred EDGE_ZERO = EDGE_WRAP
pred EDGE_CLAMP = error "Edge.pred: EDGE_CLAMP has no predecessor"
enumFromTo from to = go from
where
end = fromEnum to
go v = case compare (fromEnum v) end of
LT -> v : go (succ v)
EQ -> [v]
GT -> []
enumFrom from = enumFromTo from EDGE_ZERO
fromEnum EDGE_CLAMP = 1
fromEnum EDGE_REFLECT = 2
fromEnum EDGE_WRAP = 3
fromEnum EDGE_ZERO = 4
toEnum 1 = EDGE_CLAMP
toEnum 2 = EDGE_REFLECT
toEnum 3 = EDGE_WRAP
toEnum 4 = EDGE_ZERO
toEnum unmatched = error ("Edge.toEnum: Cannot match " ++ show unmatched)
data Filter
= FILTER_DEFAULT
| FILTER_BOX
| FILTER_TRIANGLE
| FILTER_CUBICBSPLINE
| FILTER_CATMULLROM
| FILTER_MITCHELL
deriving (Eq, Ord, Show, Read, Enum, Bounded)
data C_Filter = STBIR_FILTER_DEFAULT
| STBIR_FILTER_BOX
| STBIR_FILTER_TRIANGLE
| STBIR_FILTER_CUBICBSPLINE
| STBIR_FILTER_CATMULLROM
| STBIR_FILTER_MITCHELL
deriving (Eq,Ord,Show,Read,Bounded)
instance Enum C_Filter where
succ STBIR_FILTER_DEFAULT = STBIR_FILTER_BOX
succ STBIR_FILTER_BOX = STBIR_FILTER_TRIANGLE
succ STBIR_FILTER_TRIANGLE = STBIR_FILTER_CUBICBSPLINE
succ STBIR_FILTER_CUBICBSPLINE = STBIR_FILTER_CATMULLROM
succ STBIR_FILTER_CATMULLROM = STBIR_FILTER_MITCHELL
succ STBIR_FILTER_MITCHELL = error "C_Filter.succ: STBIR_FILTER_MITCHELL has no successor"
pred STBIR_FILTER_BOX = STBIR_FILTER_DEFAULT
pred STBIR_FILTER_TRIANGLE = STBIR_FILTER_BOX
pred STBIR_FILTER_CUBICBSPLINE = STBIR_FILTER_TRIANGLE
pred STBIR_FILTER_CATMULLROM = STBIR_FILTER_CUBICBSPLINE
pred STBIR_FILTER_MITCHELL = STBIR_FILTER_CATMULLROM
pred STBIR_FILTER_DEFAULT = error "C_Filter.pred: STBIR_FILTER_DEFAULT has no predecessor"
enumFromTo from to = go from
where
end = fromEnum to
go v = case compare (fromEnum v) end of
LT -> v : go (succ v)
EQ -> [v]
GT -> []
enumFrom from = enumFromTo from STBIR_FILTER_MITCHELL
fromEnum STBIR_FILTER_DEFAULT = 0
fromEnum STBIR_FILTER_BOX = 1
fromEnum STBIR_FILTER_TRIANGLE = 2
fromEnum STBIR_FILTER_CUBICBSPLINE = 3
fromEnum STBIR_FILTER_CATMULLROM = 4
fromEnum STBIR_FILTER_MITCHELL = 5
toEnum 0 = STBIR_FILTER_DEFAULT
toEnum 1 = STBIR_FILTER_BOX
toEnum 2 = STBIR_FILTER_TRIANGLE
toEnum 3 = STBIR_FILTER_CUBICBSPLINE
toEnum 4 = STBIR_FILTER_CATMULLROM
toEnum 5 = STBIR_FILTER_MITCHELL
toEnum unmatched = error ("C_Filter.toEnum: Cannot match " ++ show unmatched)
cFilter :: Filter -> CInt
cFilter FILTER_DEFAULT = fromIntegral $ fromEnum STBIR_FILTER_DEFAULT
cFilter FILTER_BOX = fromIntegral $ fromEnum STBIR_FILTER_BOX
cFilter FILTER_TRIANGLE = fromIntegral $ fromEnum STBIR_FILTER_TRIANGLE
cFilter FILTER_CUBICBSPLINE = fromIntegral $ fromEnum STBIR_FILTER_CUBICBSPLINE
cFilter FILTER_CATMULLROM = fromIntegral $ fromEnum STBIR_FILTER_CATMULLROM
cFilter FILTER_MITCHELL = fromIntegral $ fromEnum STBIR_FILTER_MITCHELL
data Colorspace = COLORSPACE_LINEAR
| COLORSPACE_SRGB
deriving (Enum,Eq,Ord,Show,Read,Bounded)
data Datatype = TYPE_UINT8
| TYPE_UINT16
| TYPE_UINT32
| TYPE_FLOAT
deriving (Enum)
data Scale = Scale
{ x_scale :: Float
, y_scale :: Float
, x_offset :: Float
, y_offset :: Float
} deriving (Eq, Ord, Show, Read)
data Region = Region
{ region_s0 :: Float
, region_t0 :: Float
, region_s1 :: Float
, region_t1 :: Float
} deriving (Eq, Ord, Show, Read)
data Options = Options
{ flags :: [Flag]
, edgeModeHorizontal :: Edge
, edgeModeVertical :: Edge
, filterHorizontal :: Filter
, filterVertical :: Filter
, colorspace :: Colorspace
, transform :: Either Scale Region
} deriving (Eq, Ord, Show, Read)
defaultOptions :: Options
defaultOptions = Options
{ flags = []
, edgeModeHorizontal = EDGE_CLAMP
, edgeModeVertical = EDGE_CLAMP
, filterHorizontal = FILTER_DEFAULT
, filterVertical = FILTER_DEFAULT
, colorspace = COLORSPACE_LINEAR
, transform = Right $ Region 0 0 1 1
}
instance Default Options where
def = defaultOptions
class STBIRComponent a where
stbirType :: a -> Datatype
instance STBIRComponent Word8 where stbirType _ = TYPE_UINT8
instance STBIRComponent Word16 where stbirType _ = TYPE_UINT16
instance STBIRComponent Word32 where stbirType _ = TYPE_UINT32
instance STBIRComponent Float where stbirType _ = TYPE_FLOAT
noAlpha :: CInt
noAlpha = 1
class (Pixel a, STBIRComponent (PixelBaseComponent a)) => STBIRPixel a where
alphaIndex :: a -> Maybe Int
instance STBIRPixel PixelRGBA16 where alphaIndex _ = Just 3
instance STBIRPixel PixelRGBA8 where alphaIndex _ = Just 3
instance STBIRPixel PixelCMYK16 where alphaIndex _ = Nothing
instance STBIRPixel PixelCMYK8 where alphaIndex _ = Nothing
instance STBIRPixel PixelYCbCr8 where alphaIndex _ = Nothing
instance STBIRPixel PixelRGBF where alphaIndex _ = Nothing
instance STBIRPixel PixelRGB16 where alphaIndex _ = Nothing
instance STBIRPixel PixelYCbCrK8 where alphaIndex _ = Nothing
instance STBIRPixel PixelRGB8 where alphaIndex _ = Nothing
instance STBIRPixel PixelYA16 where alphaIndex _ = Just 1
instance STBIRPixel PixelYA8 where alphaIndex _ = Just 1
instance STBIRPixel PixelF where alphaIndex _ = Nothing
instance STBIRPixel Pixel32 where alphaIndex _ = Nothing
instance STBIRPixel Pixel16 where alphaIndex _ = Nothing
instance STBIRPixel Pixel8 where alphaIndex _ = Nothing
stbir_resize_subpixel :: (Ptr ())
-> (CInt)
-> (CInt)
-> (CInt)
-> (Ptr ())
-> (CInt)
-> (CInt)
-> (CInt)
-> (Datatype)
-> (CInt)
-> (CInt)
-> (CInt)
-> (Edge)
-> (Edge)
-> (Filter)
-> (Filter)
-> (Colorspace)
-> (Ptr ())
-> (CFloat)
-> (CFloat)
-> (CFloat)
-> (CFloat)
-> IO ((CInt))
stbir_resize_subpixel a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 =
let {a1' = id a1} in
let {a2' = fromIntegral a2} in
let {a3' = fromIntegral a3} in
let {a4' = fromIntegral a4} in
let {a5' = id a5} in
let {a6' = fromIntegral a6} in
let {a7' = fromIntegral a7} in
let {a8' = fromIntegral a8} in
let {a9' = (fromIntegral . fromEnum) a9} in
let {a10' = fromIntegral a10} in
let {a11' = fromIntegral a11} in
let {a12' = fromIntegral a12} in
let {a13' = (fromIntegral . fromEnum) a13} in
let {a14' = (fromIntegral . fromEnum) a14} in
let {a15' = cFilter a15} in
let {a16' = cFilter a16} in
let {a17' = (fromIntegral . fromEnum) a17} in
let {a18' = id a18} in
let {a19' = realToFrac a19} in
let {a20' = realToFrac a20} in
let {a21' = realToFrac a21} in
let {a22' = realToFrac a22} in
stbir_resize_subpixel'_ a1' a2' a3' a4' a5' a6' a7' a8' a9' a10' a11' a12' a13' a14' a15' a16' a17' a18' a19' a20' a21' a22' >>= \res ->
let {res' = fromIntegral res} in
return (res')
stbir_resize_region :: (Ptr ())
-> (CInt)
-> (CInt)
-> (CInt)
-> (Ptr ())
-> (CInt)
-> (CInt)
-> (CInt)
-> (Datatype)
-> (CInt)
-> (CInt)
-> (CInt)
-> (Edge)
-> (Edge)
-> (Filter)
-> (Filter)
-> (Colorspace)
-> (Ptr ())
-> (CFloat)
-> (CFloat)
-> (CFloat)
-> (CFloat)
-> IO ((CInt))
stbir_resize_region a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 =
let {a1' = id a1} in
let {a2' = fromIntegral a2} in
let {a3' = fromIntegral a3} in
let {a4' = fromIntegral a4} in
let {a5' = id a5} in
let {a6' = fromIntegral a6} in
let {a7' = fromIntegral a7} in
let {a8' = fromIntegral a8} in
let {a9' = (fromIntegral . fromEnum) a9} in
let {a10' = fromIntegral a10} in
let {a11' = fromIntegral a11} in
let {a12' = fromIntegral a12} in
let {a13' = (fromIntegral . fromEnum) a13} in
let {a14' = (fromIntegral . fromEnum) a14} in
let {a15' = cFilter a15} in
let {a16' = cFilter a16} in
let {a17' = (fromIntegral . fromEnum) a17} in
let {a18' = id a18} in
let {a19' = realToFrac a19} in
let {a20' = realToFrac a20} in
let {a21' = realToFrac a21} in
let {a22' = realToFrac a22} in
stbir_resize_region'_ a1' a2' a3' a4' a5' a6' a7' a8' a9' a10' a11' a12' a13' a14' a15' a16' a17' a18' a19' a20' a21' a22' >>= \res ->
let {res' = fromIntegral res} in
return (res')
pixelProperty :: (a -> b) -> Image a -> b
pixelProperty f img = let
getFakePixel :: Image a -> a
getFakePixel = undefined
in f $ getFakePixel img
resize
:: (STBIRPixel a)
=> Options
-> Int
-> Int
-> Image a
-> Image a
resize opts w' h' img@(Image w h v) = unsafePerformIO $ do
V.unsafeWith v $ \p -> do
let comps = pixelProperty componentCount img
fp <- mallocForeignPtrArray $ w' * h' * comps
let (cfun, f0, f1, f2, f3) = case transform opts of
Left (Scale a b c d) -> (stbir_resize_subpixel, a, b, c, d)
Right (Region a b c d) -> (stbir_resize_region , a, b, c, d)
res <- withForeignPtr fp $ \p' -> cfun
(castPtr p)
(fromIntegral w)
(fromIntegral h)
0
(castPtr p')
(fromIntegral w')
(fromIntegral h')
0
(pixelProperty (stbirType . pixelOpacity) img)
(fromIntegral comps)
(maybe noAlpha fromIntegral $ pixelProperty alphaIndex img)
(fromIntegral $ foldr (.|.) 0 $ map fromFlag $ flags opts)
(edgeModeHorizontal opts)
(edgeModeVertical opts)
(filterHorizontal opts)
(filterVertical opts)
(colorspace opts)
nullPtr
(realToFrac f0)
(realToFrac f1)
(realToFrac f2)
(realToFrac f3)
if res == 0
then error "Codec.Picture.STBIR.resize returned an error"
else return $ Image w' h' $ V.unsafeFromForeignPtr0 fp $ w' * h' * comps
foreign import ccall safe "Codec/Picture/STBIR.chs.h stbir_resize_subpixel"
stbir_resize_subpixel'_ :: ((C2HSImp.Ptr ()) -> (C2HSImp.CInt -> (C2HSImp.CInt -> (C2HSImp.CInt -> ((C2HSImp.Ptr ()) -> (C2HSImp.CInt -> (C2HSImp.CInt -> (C2HSImp.CInt -> (C2HSImp.CInt -> (C2HSImp.CInt -> (C2HSImp.CInt -> (C2HSImp.CInt -> (C2HSImp.CInt -> (C2HSImp.CInt -> (C2HSImp.CInt -> (C2HSImp.CInt -> (C2HSImp.CInt -> ((C2HSImp.Ptr ()) -> (C2HSImp.CFloat -> (C2HSImp.CFloat -> (C2HSImp.CFloat -> (C2HSImp.CFloat -> (IO C2HSImp.CInt)))))))))))))))))))))))
foreign import ccall safe "Codec/Picture/STBIR.chs.h stbir_resize_region"
stbir_resize_region'_ :: ((C2HSImp.Ptr ()) -> (C2HSImp.CInt -> (C2HSImp.CInt -> (C2HSImp.CInt -> ((C2HSImp.Ptr ()) -> (C2HSImp.CInt -> (C2HSImp.CInt -> (C2HSImp.CInt -> (C2HSImp.CInt -> (C2HSImp.CInt -> (C2HSImp.CInt -> (C2HSImp.CInt -> (C2HSImp.CInt -> (C2HSImp.CInt -> (C2HSImp.CInt -> (C2HSImp.CInt -> (C2HSImp.CInt -> ((C2HSImp.Ptr ()) -> (C2HSImp.CFloat -> (C2HSImp.CFloat -> (C2HSImp.CFloat -> (C2HSImp.CFloat -> (IO C2HSImp.CInt)))))))))))))))))))))))