|
Packit |
c600df |
{-# LANGUAGE TupleSections #-}
|
|
Packit |
c600df |
{-# LANGUAGE FlexibleContexts #-}
|
|
Packit |
c600df |
-- | Module used by the jpeg decoder internally, shouldn't be used
|
|
Packit |
c600df |
-- in user code.
|
|
Packit |
c600df |
module Codec.Picture.Jpg.DefaultTable( DctComponent( .. )
|
|
Packit |
c600df |
, HuffmanTree( .. )
|
|
Packit |
c600df |
, HuffmanTable
|
|
Packit |
c600df |
, HuffmanPackedTree
|
|
Packit |
c600df |
, MacroBlock
|
|
Packit |
c600df |
, QuantificationTable
|
|
Packit |
c600df |
, HuffmanWriterCode
|
|
Packit |
c600df |
, scaleQuantisationMatrix
|
|
Packit |
c600df |
, makeMacroBlock
|
|
Packit |
c600df |
, makeInverseTable
|
|
Packit |
c600df |
, buildHuffmanTree
|
|
Packit |
c600df |
, packHuffmanTree
|
|
Packit |
c600df |
, huffmanPackedDecode
|
|
Packit |
c600df |
|
|
Packit |
c600df |
, defaultChromaQuantizationTable
|
|
Packit |
c600df |
|
|
Packit |
c600df |
, defaultLumaQuantizationTable
|
|
Packit |
c600df |
|
|
Packit |
c600df |
, defaultAcChromaHuffmanTree
|
|
Packit |
c600df |
, defaultAcChromaHuffmanTable
|
|
Packit |
c600df |
|
|
Packit |
c600df |
, defaultAcLumaHuffmanTree
|
|
Packit |
c600df |
, defaultAcLumaHuffmanTable
|
|
Packit |
c600df |
|
|
Packit |
c600df |
, defaultDcChromaHuffmanTree
|
|
Packit |
c600df |
, defaultDcChromaHuffmanTable
|
|
Packit |
c600df |
|
|
Packit |
c600df |
, defaultDcLumaHuffmanTree
|
|
Packit |
c600df |
, defaultDcLumaHuffmanTable
|
|
Packit |
c600df |
) where
|
|
Packit |
c600df |
|
|
Packit |
c600df |
import Data.Int( Int16 )
|
|
Packit |
c600df |
import Foreign.Storable ( Storable )
|
|
Packit |
c600df |
import Control.Monad.ST( runST )
|
|
Packit |
c600df |
import qualified Data.Vector.Storable as SV
|
|
Packit |
c600df |
import qualified Data.Vector as V
|
|
Packit |
c600df |
import Data.Bits( unsafeShiftL, (.|.), (.&.) )
|
|
Packit |
c600df |
import Data.Word( Word8, Word16 )
|
|
Packit |
c600df |
import Data.List( foldl' )
|
|
Packit |
c600df |
import qualified Data.Vector.Storable.Mutable as M
|
|
Packit |
c600df |
|
|
Packit |
c600df |
import Codec.Picture.BitWriter
|
|
Packit |
c600df |
|
|
Packit |
c600df |
-- | Tree storing the code used for huffman encoding.
|
|
Packit |
c600df |
data HuffmanTree = Branch HuffmanTree HuffmanTree -- ^ If bit is 0 take the first subtree, if 1, the right.
|
|
Packit |
c600df |
| Leaf Word8 -- ^ We should output the value
|
|
Packit |
c600df |
| Empty -- ^ no value present
|
|
Packit |
c600df |
deriving (Eq, Show)
|
|
Packit |
c600df |
|
|
Packit |
c600df |
type HuffmanPackedTree = SV.Vector Word16
|
|
Packit |
c600df |
|
|
Packit |
c600df |
type HuffmanWriterCode = V.Vector (Word8, Word16)
|
|
Packit |
c600df |
|
|
Packit |
c600df |
packHuffmanTree :: HuffmanTree -> HuffmanPackedTree
|
|
Packit |
c600df |
packHuffmanTree tree = runST $ do
|
|
Packit |
c600df |
table <- M.replicate 512 0x8000
|
|
Packit |
c600df |
let aux (Empty) idx = return $ idx + 1
|
|
Packit |
c600df |
aux (Leaf v) idx = do
|
|
Packit |
c600df |
(table `M.unsafeWrite` idx) $ fromIntegral v .|. 0x4000
|
|
Packit |
c600df |
return $ idx + 1
|
|
Packit |
c600df |
|
|
Packit |
c600df |
aux (Branch i1@(Leaf _) i2@(Leaf _)) idx =
|
|
Packit |
c600df |
aux i1 idx >>= aux i2
|
|
Packit |
c600df |
|
|
Packit |
c600df |
aux (Branch i1@(Leaf _) i2) idx = do
|
|
Packit |
c600df |
_ <- aux i1 idx
|
|
Packit |
c600df |
ix2 <- aux i2 $ idx + 2
|
|
Packit |
c600df |
(table `M.unsafeWrite` (idx + 1)) $ fromIntegral $ idx + 2
|
|
Packit |
c600df |
return ix2
|
|
Packit |
c600df |
|
|
Packit |
c600df |
aux (Branch i1 i2@(Leaf _)) idx = do
|
|
Packit |
c600df |
ix1 <- aux i1 (idx + 2)
|
|
Packit |
c600df |
_ <- aux i2 (idx + 1)
|
|
Packit |
c600df |
(table `M.unsafeWrite` idx) . fromIntegral $ idx + 2
|
|
Packit |
c600df |
return ix1
|
|
Packit |
c600df |
|
|
Packit |
c600df |
aux (Branch i1 i2) idx = do
|
|
Packit |
c600df |
ix1 <- aux i1 (idx + 2)
|
|
Packit |
c600df |
ix2 <- aux i2 ix1
|
|
Packit |
c600df |
(table `M.unsafeWrite` idx) (fromIntegral $ idx + 2)
|
|
Packit |
c600df |
(table `M.unsafeWrite` (idx + 1)) (fromIntegral ix1)
|
|
Packit |
c600df |
return ix2
|
|
Packit |
c600df |
_ <- aux tree 0
|
|
Packit |
c600df |
SV.unsafeFreeze table
|
|
Packit |
c600df |
|
|
Packit |
c600df |
makeInverseTable :: HuffmanTree -> HuffmanWriterCode
|
|
Packit |
c600df |
makeInverseTable t = V.replicate 255 (0,0) V.// inner 0 0 t
|
|
Packit |
c600df |
where inner _ _ Empty = []
|
|
Packit |
c600df |
inner depth code (Leaf v) = [(fromIntegral v, (depth, code))]
|
|
Packit |
c600df |
inner depth code (Branch l r) =
|
|
Packit |
c600df |
inner (depth + 1) shifted l ++ inner (depth + 1) (shifted .|. 1) r
|
|
Packit |
c600df |
where shifted = code `unsafeShiftL` 1
|
|
Packit |
c600df |
|
|
Packit |
c600df |
-- | Represent a compact array of 8 * 8 values. The size
|
|
Packit |
c600df |
-- is not guarenteed by type system, but if makeMacroBlock is
|
|
Packit |
c600df |
-- used, everything should be fine size-wise
|
|
Packit |
c600df |
type MacroBlock a = SV.Vector a
|
|
Packit |
c600df |
|
|
Packit |
c600df |
type QuantificationTable = MacroBlock Int16
|
|
Packit |
c600df |
|
|
Packit |
c600df |
-- | Helper function to create pure macro block of the good size.
|
|
Packit |
c600df |
makeMacroBlock :: (Storable a) => [a] -> MacroBlock a
|
|
Packit |
c600df |
makeMacroBlock = SV.fromListN 64
|
|
Packit |
c600df |
|
|
Packit |
c600df |
-- | Enumeration used to search in the tables for different components.
|
|
Packit |
c600df |
data DctComponent = DcComponent | AcComponent
|
|
Packit |
c600df |
deriving (Eq, Show)
|
|
Packit |
c600df |
|
|
Packit |
c600df |
-- | Transform parsed coefficients from the jpeg header to a
|
|
Packit |
c600df |
-- tree which can be used to decode data.
|
|
Packit |
c600df |
buildHuffmanTree :: [[Word8]] -> HuffmanTree
|
|
Packit |
c600df |
buildHuffmanTree table = foldl' insertHuffmanVal Empty
|
|
Packit |
c600df |
. concatMap (\(i, t) -> map (i + 1,) t)
|
|
Packit |
c600df |
$ zip ([0..] :: [Int]) table
|
|
Packit |
c600df |
where isTreeFullyDefined Empty = False
|
|
Packit |
c600df |
isTreeFullyDefined (Leaf _) = True
|
|
Packit |
c600df |
isTreeFullyDefined (Branch l r) = isTreeFullyDefined l && isTreeFullyDefined r
|
|
Packit |
c600df |
|
|
Packit |
c600df |
insertHuffmanVal Empty (0, val) = Leaf val
|
|
Packit |
c600df |
insertHuffmanVal Empty (d, val) = Branch (insertHuffmanVal Empty (d - 1, val)) Empty
|
|
Packit |
c600df |
insertHuffmanVal (Branch l r) (d, val)
|
|
Packit |
c600df |
| isTreeFullyDefined l = Branch l (insertHuffmanVal r (d - 1, val))
|
|
Packit |
c600df |
| otherwise = Branch (insertHuffmanVal l (d - 1, val)) r
|
|
Packit |
c600df |
insertHuffmanVal (Leaf _) _ = error "Inserting in value, shouldn't happen"
|
|
Packit |
c600df |
|
|
Packit |
c600df |
scaleQuantisationMatrix :: Int -> QuantificationTable -> QuantificationTable
|
|
Packit |
c600df |
scaleQuantisationMatrix quality
|
|
Packit |
c600df |
| quality < 0 = scaleQuantisationMatrix 0
|
|
Packit |
c600df |
-- shouldn't show much difference than with 1,
|
|
Packit |
c600df |
-- but hey, at least we're complete
|
|
Packit |
c600df |
| quality == 0 = SV.map (scale (10000 :: Int))
|
|
Packit |
c600df |
| quality < 50 = let qq = 5000 `div` quality
|
|
Packit |
c600df |
in SV.map (scale qq)
|
|
Packit |
c600df |
| otherwise = SV.map (scale q)
|
|
Packit |
c600df |
where q = 200 - quality * 2
|
|
Packit |
c600df |
scale coeff i = fromIntegral . min 255
|
|
Packit |
c600df |
. max 1
|
|
Packit |
c600df |
$ fromIntegral i * coeff `div` 100
|
|
Packit |
c600df |
|
|
Packit |
c600df |
huffmanPackedDecode :: HuffmanPackedTree -> BoolReader s Word8
|
|
Packit |
c600df |
huffmanPackedDecode table = getNextBitJpg >>= aux 0
|
|
Packit |
c600df |
where aux idx b
|
|
Packit |
c600df |
| (v .&. 0x8000) /= 0 = return 0
|
|
Packit |
c600df |
| (v .&. 0x4000) /= 0 = return . fromIntegral $ v .&. 0xFF
|
|
Packit |
c600df |
| otherwise = getNextBitJpg >>= aux v
|
|
Packit |
c600df |
where tableIndex | b = idx + 1
|
|
Packit |
c600df |
| otherwise = idx
|
|
Packit |
c600df |
v = table `SV.unsafeIndex` fromIntegral tableIndex
|
|
Packit |
c600df |
|
|
Packit |
c600df |
defaultLumaQuantizationTable :: QuantificationTable
|
|
Packit |
c600df |
defaultLumaQuantizationTable = makeMacroBlock
|
|
Packit |
c600df |
[16, 11, 10, 16, 24, 40, 51, 61
|
|
Packit |
c600df |
,12, 12, 14, 19, 26, 58, 60, 55
|
|
Packit |
c600df |
,14, 13, 16, 24, 40, 57, 69, 56
|
|
Packit |
c600df |
,14, 17, 22, 29, 51, 87, 80, 62
|
|
Packit |
c600df |
,18, 22, 37, 56, 68, 109, 103, 77
|
|
Packit |
c600df |
,24, 35, 55, 64, 81, 104, 113, 92
|
|
Packit |
c600df |
,49, 64, 78, 87, 103, 121, 120, 101
|
|
Packit |
c600df |
,72, 92, 95, 98, 112, 100, 103, 99
|
|
Packit |
c600df |
]
|
|
Packit |
c600df |
|
|
Packit |
c600df |
defaultChromaQuantizationTable :: QuantificationTable
|
|
Packit |
c600df |
defaultChromaQuantizationTable = makeMacroBlock
|
|
Packit |
c600df |
[17, 18, 24, 47, 99, 99, 99, 99
|
|
Packit |
c600df |
,18, 21, 26, 66, 99, 99, 99, 99
|
|
Packit |
c600df |
,24, 26, 56, 99, 99, 99, 99, 99
|
|
Packit |
c600df |
,47, 66, 99, 99, 99, 99, 99, 99
|
|
Packit |
c600df |
,99, 99, 99, 99, 99, 99, 99, 99
|
|
Packit |
c600df |
,99, 99, 99, 99, 99, 99, 99, 99
|
|
Packit |
c600df |
,99, 99, 99, 99, 99, 99, 99, 99
|
|
Packit |
c600df |
,99, 99, 99, 99, 99, 99, 99, 99
|
|
Packit |
c600df |
]
|
|
Packit |
c600df |
|
|
Packit |
c600df |
defaultDcLumaHuffmanTree :: HuffmanTree
|
|
Packit |
c600df |
defaultDcLumaHuffmanTree = buildHuffmanTree defaultDcLumaHuffmanTable
|
|
Packit |
c600df |
|
|
Packit |
c600df |
-- | From the Table K.3 of ITU-81 (p153)
|
|
Packit |
c600df |
defaultDcLumaHuffmanTable :: HuffmanTable
|
|
Packit |
c600df |
defaultDcLumaHuffmanTable =
|
|
Packit |
c600df |
[ []
|
|
Packit |
c600df |
, [0]
|
|
Packit |
c600df |
, [1, 2, 3, 4, 5]
|
|
Packit |
c600df |
, [6]
|
|
Packit |
c600df |
, [7]
|
|
Packit |
c600df |
, [8]
|
|
Packit |
c600df |
, [9]
|
|
Packit |
c600df |
, [10]
|
|
Packit |
c600df |
, [11]
|
|
Packit |
c600df |
, []
|
|
Packit |
c600df |
, []
|
|
Packit |
c600df |
, []
|
|
Packit |
c600df |
, []
|
|
Packit |
c600df |
, []
|
|
Packit |
c600df |
, []
|
|
Packit |
c600df |
, []
|
|
Packit |
c600df |
]
|
|
Packit |
c600df |
|
|
Packit |
c600df |
defaultDcChromaHuffmanTree :: HuffmanTree
|
|
Packit |
c600df |
defaultDcChromaHuffmanTree = buildHuffmanTree defaultDcChromaHuffmanTable
|
|
Packit |
c600df |
|
|
Packit |
c600df |
-- | From the Table K.4 of ITU-81 (p153)
|
|
Packit |
c600df |
defaultDcChromaHuffmanTable :: HuffmanTable
|
|
Packit |
c600df |
defaultDcChromaHuffmanTable =
|
|
Packit |
c600df |
[ []
|
|
Packit |
c600df |
, [0, 1, 2]
|
|
Packit |
c600df |
, [3]
|
|
Packit |
c600df |
, [4]
|
|
Packit |
c600df |
, [5]
|
|
Packit |
c600df |
, [6]
|
|
Packit |
c600df |
, [7]
|
|
Packit |
c600df |
, [8]
|
|
Packit |
c600df |
, [9]
|
|
Packit |
c600df |
, [10]
|
|
Packit |
c600df |
, [11]
|
|
Packit |
c600df |
, []
|
|
Packit |
c600df |
, []
|
|
Packit |
c600df |
, []
|
|
Packit |
c600df |
, []
|
|
Packit |
c600df |
, []
|
|
Packit |
c600df |
]
|
|
Packit |
c600df |
|
|
Packit |
c600df |
defaultAcLumaHuffmanTree :: HuffmanTree
|
|
Packit |
c600df |
defaultAcLumaHuffmanTree = buildHuffmanTree defaultAcLumaHuffmanTable
|
|
Packit |
c600df |
|
|
Packit |
c600df |
-- | From the Table K.5 of ITU-81 (p154)
|
|
Packit |
c600df |
defaultAcLumaHuffmanTable :: HuffmanTable
|
|
Packit |
c600df |
defaultAcLumaHuffmanTable =
|
|
Packit |
c600df |
[ []
|
|
Packit |
c600df |
, [0x01, 0x02]
|
|
Packit |
c600df |
, [0x03]
|
|
Packit |
c600df |
, [0x00, 0x04, 0x11]
|
|
Packit |
c600df |
, [0x05, 0x12, 0x21]
|
|
Packit |
c600df |
, [0x31, 0x41]
|
|
Packit |
c600df |
, [0x06, 0x13, 0x51, 0x61]
|
|
Packit |
c600df |
, [0x07, 0x22, 0x71]
|
|
Packit |
c600df |
, [0x14, 0x32, 0x81, 0x91, 0xA1]
|
|
Packit |
c600df |
, [0x08, 0x23, 0x42, 0xB1, 0xC1]
|
|
Packit |
c600df |
, [0x15, 0x52, 0xD1, 0xF0]
|
|
Packit |
c600df |
, [0x24, 0x33, 0x62, 0x72]
|
|
Packit |
c600df |
, []
|
|
Packit |
c600df |
, []
|
|
Packit |
c600df |
, [0x82]
|
|
Packit |
c600df |
, [0x09, 0x0A, 0x16, 0x17, 0x18, 0x19, 0x1A, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x34, 0x35
|
|
Packit |
c600df |
,0x36, 0x37, 0x38, 0x39, 0x3A, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4A, 0x53, 0x54
|
|
Packit |
c600df |
,0x55, 0x56, 0x57, 0x58, 0x59, 0x5A, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x73
|
|
Packit |
c600df |
,0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x8A
|
|
Packit |
c600df |
,0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99, 0x9A, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7
|
|
Packit |
c600df |
,0xA8, 0xA9, 0xAA, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7, 0xB8, 0xB9, 0xBA, 0xC2, 0xC3, 0xC4
|
|
Packit |
c600df |
,0xC5, 0xC6, 0xC7, 0xC8, 0xC9, 0xCA, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7, 0xD8, 0xD9, 0xDA
|
|
Packit |
c600df |
,0xE1, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xEA, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5
|
|
Packit |
c600df |
,0xF6, 0xF7, 0xF8, 0xF9, 0xFA]
|
|
Packit |
c600df |
]
|
|
Packit |
c600df |
|
|
Packit |
c600df |
type HuffmanTable = [[Word8]]
|
|
Packit |
c600df |
|
|
Packit |
c600df |
defaultAcChromaHuffmanTree :: HuffmanTree
|
|
Packit |
c600df |
defaultAcChromaHuffmanTree = buildHuffmanTree defaultAcChromaHuffmanTable
|
|
Packit |
c600df |
|
|
Packit |
c600df |
defaultAcChromaHuffmanTable :: HuffmanTable
|
|
Packit |
c600df |
defaultAcChromaHuffmanTable =
|
|
Packit |
c600df |
[ []
|
|
Packit |
c600df |
, [0x00, 0x01]
|
|
Packit |
c600df |
, [0x02]
|
|
Packit |
c600df |
, [0x03, 0x11]
|
|
Packit |
c600df |
, [0x04, 0x05, 0x21, 0x31]
|
|
Packit |
c600df |
, [0x06, 0x12, 0x41, 0x51]
|
|
Packit |
c600df |
, [0x07, 0x61, 0x71]
|
|
Packit |
c600df |
, [0x13, 0x22, 0x32, 0x81]
|
|
Packit |
c600df |
, [0x08, 0x14, 0x42, 0x91, 0xA1, 0xB1, 0xC1]
|
|
Packit |
c600df |
, [0x09, 0x23, 0x33, 0x52, 0xF0]
|
|
Packit |
c600df |
, [0x15, 0x62, 0x72, 0xD1]
|
|
Packit |
c600df |
, [0x0A, 0x16, 0x24, 0x34]
|
|
Packit |
c600df |
, []
|
|
Packit |
c600df |
, [0xE1]
|
|
Packit |
c600df |
, [0x25, 0xF1]
|
|
Packit |
c600df |
, [ 0x17, 0x18, 0x19, 0x1A, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x35
|
|
Packit |
c600df |
, 0x36, 0x37, 0x38, 0x39, 0x3A, 0x43, 0x44, 0x45, 0x46, 0x47
|
|
Packit |
c600df |
, 0x48, 0x49, 0x4A, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59
|
|
Packit |
c600df |
, 0x5A, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x73
|
|
Packit |
c600df |
, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x82, 0x83, 0x84
|
|
Packit |
c600df |
, 0x85, 0x86, 0x87, 0x88, 0x89, 0x8A, 0x92, 0x93, 0x94, 0x95
|
|
Packit |
c600df |
, 0x96, 0x97, 0x98, 0x99, 0x9A, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6
|
|
Packit |
c600df |
, 0xA7, 0xA8, 0xA9, 0xAA, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7
|
|
Packit |
c600df |
, 0xB8, 0xB9, 0xBA, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7, 0xC8
|
|
Packit |
c600df |
, 0xC9, 0xCA, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7, 0xD8, 0xD9
|
|
Packit |
c600df |
, 0xDA, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xEA
|
|
Packit |
c600df |
, 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7, 0xF8, 0xF9, 0xFA
|
|
Packit |
c600df |
]
|
|
Packit |
c600df |
]
|
|
Packit |
c600df |
|