diff --git a/Gamgine.cabal b/Gamgine.cabal --- a/Gamgine.cabal +++ b/Gamgine.cabal @@ -1,5 +1,5 @@ name: Gamgine -version: 0.4.1 +version: 0.5 cabal-version: >=1.6 build-type: Simple license: BSD3 @@ -26,20 +26,20 @@ base >3 && <5, GLFW-b >=1.0 && <1.5, OpenGLRaw >=1.4.0.0 && <1.6, - mtl >=2.1.3.1 && <2.2, - time >=1.4.0.1 && <1.5, + mtl >=2.1.3.1 && <2.3, + time >=1.4.0.1 && <1.6, Vec >=1.0.1 && <1.1, utility-ht >=0.0.10 && <0.1, directory >=1.2.0.1 && <1.3, - StateVar >=1.0.0.0 && <1.1, + StateVar >=1.0.0.0 && <1.2, array >=0.4.0.1 && <0.6, bytestring >=0.10.0.2 && <0.11, unordered-containers >=0.2.4.0 && <0.3, data-lens >=2.10.4 && <2.11, pretty-show >=1.6.7 && <1.7, cpphs >=1.18.4 && <1.19, - filepath >=1.3.0.1 && <1.4, - parsec ==3.1.5, + filepath >=1.3.0.1 && <1.5, + parsec >=3.1.5 && <3.2, zlib >=0.5.4.1 && <0.6, ListZipper >=1.2.0.2 && <1.3, composition >=1.0.1.0 && <1.1 @@ -65,6 +65,7 @@ Gamgine.Engine Gamgine.Image.PNG.Internal.Filters Gamgine.Image.PNG.Internal.Parser + Gamgine.Image.PNG.Internal.LBS Gamgine.Image.PNG.Internal.CRC Gamgine.Image.PNG Gamgine.System diff --git a/Gamgine/Image/PNG.hs b/Gamgine/Image/PNG.hs --- a/Gamgine/Image/PNG.hs +++ b/Gamgine/Image/PNG.hs @@ -3,7 +3,7 @@ -- Module : Graphics.Formats.PNG -- Copyright : (c) Marko Lauronen 2008 -- License : BSD --- +-- -- Maintainer : marko.lauronen@pp1.inet.fi -- Stability : experimental -- Portability : non-portable (GHC only) @@ -37,8 +37,6 @@ import Data.Array.Storable import Data.Word import Data.List -import qualified Data.ByteString.Lazy as LB -import qualified Data.ByteString.Lazy.Char8 as C import Data.Int import Data.Char import System.IO @@ -48,6 +46,8 @@ import Gamgine.Image.PNG.Internal.Parser import Gamgine.Image.PNG.Internal.CRC import Gamgine.Image.PNG.Internal.Filters +import qualified Gamgine.Image.PNG.Internal.LBS as LBS +import Gamgine.Image.PNG.Internal.LBS (LBS) -- | Type for raw PNG chunks -- The parsing happens in two phases: first the file is read into @@ -56,7 +56,7 @@ -- with raw chunk data. data RawPNGChunk = RawPNGChunk { rawPngChunk_type :: !String, - rawPngChunk_data :: !LB.ByteString + rawPngChunk_data :: !LBS } deriving (Show) type Width = Word32 @@ -76,7 +76,7 @@ | PLTE { plte_entries :: !(Array Word8 Rgb) } | IDAT { - idat_data :: !LB.ByteString } + idat_data :: !LBS } | UnknownChunk RawPNGChunk -- chunk types not supported yet | IEND deriving (Show) @@ -102,8 +102,8 @@ -- | Raw chunk parsing -pngHeaderBytes :: LB.ByteString -pngHeaderBytes = LB.pack [137, 80, 78, 71, 13, 10, 26, 10] +pngHeaderBytes :: LBS +pngHeaderBytes = LBS.pack [137, 80, 78, 71, 13, 10, 26, 10] pngFile :: Parser [RawPNGChunk] pngFile = do @@ -119,9 +119,9 @@ len <- anyWord32 chunkType <- block 4 chunkData <- block (fromIntegral len) - let expectedCrc = crc (LB.concat [chunkType,chunkData]) + let expectedCrc = crc (LBS.concat [chunkType,chunkData]) word32 expectedCrc "valid crc" - return $ RawPNGChunk (C.unpack chunkType) chunkData + return $ RawPNGChunk (LBS.unpackToString chunkType) chunkData -- | Final chunk parsing @@ -142,12 +142,12 @@ --[(0,Ct0), (2,Ct2), (3,Ct3), (4,Ct4), (6,Ct6)] colorType <- allowedValues word8 [(2,Ct2), (6,Ct6)] "valid colorType: supported Ct2,Ct6" - compressionMethod <- allowedValues word8 [(0, Deflate)] + compressionMethod <- allowedValues word8 [(0, Deflate)] "valid compression method: supported Deflate" - filterMethod <- allowedValues word8 [(0, Adaptive)] + filterMethod <- allowedValues word8 [(0, Adaptive)] "valid filter method: supported Adaptive" - -- [(0, NoInterlace), (1, Adam7)] - interlaceMethod <- allowedValues word8 [(0, NoInterlace)] + -- [(0, NoInterlace), (1, Adam7)] + interlaceMethod <- allowedValues word8 [(0, NoInterlace)] "valid interlace method: supported NoInterlace" return $ IHDR { ihdr_width = width @@ -180,7 +180,7 @@ case mapM toPngChunk chunks >>= return . partition isIDAT of Right (_, []) -> return $ Left "File has no chunks!" Right (dataChunks, hdr:otherChunks) -> do - let dataDecompressed = decompress . LB.concat . map idat_data $ dataChunks + let dataDecompressed = decompress . LBS.unLSB . LBS.concat . map idat_data $ dataChunks bpp = bytesPerPixel (ihdr_colorType hdr) (ihdr_bitDepth hdr) w = fromIntegral (ihdr_width hdr) h = fromIntegral (ihdr_height hdr) diff --git a/Gamgine/Image/PNG/Internal/CRC.hs b/Gamgine/Image/PNG/Internal/CRC.hs --- a/Gamgine/Image/PNG/Internal/CRC.hs +++ b/Gamgine/Image/PNG/Internal/CRC.hs @@ -5,7 +5,8 @@ import Data.Word import Data.Array.Unboxed import Data.Bits -import qualified Data.ByteString.Lazy as LB +import qualified Gamgine.Image.PNG.Internal.LBS as LBS +import Gamgine.Image.PNG.Internal.LBS (LBS) crc_table :: UArray Word32 Word32 crc_table = listArray (0,255) . map iterate_c $ [0..] @@ -15,15 +16,15 @@ | c .&. 1 == 1 = 0xedb88320 `xor` (c `shiftR` 1) | otherwise = c `shiftR` 1 -update_crc :: Word32 -> LB.ByteString -> Word32 +update_crc :: Word32 -> LBS -> Word32 update_crc !c bs - | LB.null bs = c - | otherwise = let w = LB.head bs + | LBS.null bs = c + | otherwise = let w = LBS.head bs newcrc = (crc_table ! ((c `xor` fromIntegral w) .&. 0xff)) `xor` (c `shiftR` 8) in - update_crc newcrc (LB.tail bs) + update_crc newcrc (LBS.tail bs) -crc :: LB.ByteString -> Word32 +crc :: LBS -> Word32 crc = (`xor` 0xffffffff) . update_crc 0xffffffff --test = crc $ LB.replicate 10000000 128 diff --git a/Gamgine/Image/PNG/Internal/Filters.hs b/Gamgine/Image/PNG/Internal/Filters.hs --- a/Gamgine/Image/PNG/Internal/Filters.hs +++ b/Gamgine/Image/PNG/Internal/Filters.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, FlexibleContexts #-} module Gamgine.Image.PNG.Internal.Filters (defilter_scanlines_arr) where diff --git a/Gamgine/Image/PNG/Internal/LBS.hs b/Gamgine/Image/PNG/Internal/LBS.hs new file mode 100644 --- /dev/null +++ b/Gamgine/Image/PNG/Internal/LBS.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} + +module Gamgine.Image.PNG.Internal.LBS + ( LBS(..) + , unpack + , unpackToString + , splitAt + , readFile + , concat + , pack + , null + , head + , tail + ) where + +import Prelude hiding (splitAt, readFile, concat, null, head, tail) +import Text.Parsec.Prim (Stream(..)) +import Data.Word +import Data.Int (Int64) +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Lazy.Char8 as C +import Control.Applicative ((<$>)) + +newtype LBS = LBS { unLSB :: LB.ByteString } deriving (Show) + +instance (Monad m) => Stream LBS m Word8 where + uncons = return . uncons' + +uncons' :: LBS -> Maybe (Word8, LBS) +uncons' (LBS bs) = case LB.uncons bs of + Just (w, bs) -> Just (w, LBS bs) + Nothing -> Nothing + +unpack :: LBS -> [Word8] +unpack = LB.unpack . unLSB + +unpackToString :: LBS -> String +unpackToString = C.unpack . unLSB + +splitAt :: Int64 -> LBS -> (LBS, LBS) +splitAt idx (LBS bs) = + let (bs1, bs2) = LB.splitAt idx bs + in (LBS bs1, LBS bs2) + +readFile :: FilePath -> IO LBS +readFile fp = LBS <$> LB.readFile fp + +concat :: [LBS] -> LBS +concat = LBS . LB.concat . map unLSB + +pack :: [Word8] -> LBS +pack = LBS . LB.pack + +null :: LBS -> Bool +null = LB.null . unLSB + +head :: LBS -> Word8 +head = LB.head . unLSB + +tail :: LBS -> LBS +tail = LBS . LB.tail . unLSB diff --git a/Gamgine/Image/PNG/Internal/Parser.hs b/Gamgine/Image/PNG/Internal/Parser.hs --- a/Gamgine/Image/PNG/Internal/Parser.hs +++ b/Gamgine/Image/PNG/Internal/Parser.hs @@ -9,66 +9,63 @@ import Data.Bits import Numeric (showHex) +import qualified Gamgine.Image.PNG.Internal.LBS as LBS +import Gamgine.Image.PNG.Internal.LBS (LBS) import qualified Data.ByteString.Lazy as LB -instance (Monad m) => Stream LB.ByteString m Word8 where - uncons = return . LB.uncons - -type Parser = Parsec LB.ByteString () +type Parser = Parsec LBS () -word8 :: (Stream LB.ByteString m Word8) => Word8 -> ParsecT LB.ByteString u m Word8 +word8 :: (Stream LBS m Word8) => Word8 -> ParsecT LBS u m Word8 word8 = satisfy . (==) -word16 :: (Stream LB.ByteString m Word8) => Word16 -> ParsecT LB.ByteString u m Word16 +word16 :: (Stream LBS m Word8) => Word16 -> ParsecT LBS u m Word16 word16 w = (word8 hi >> word8 lo >> return w) "0x" ++ showHex w "" where hi = fromIntegral (w `shiftR` 8) lo = fromIntegral w -word32 :: (Stream LB.ByteString m Word8) => Word32 -> ParsecT LB.ByteString u m Word32 +word32 :: (Stream LBS m Word8) => Word32 -> ParsecT LBS u m Word32 word32 w = (word16 hi >> word16 lo >> return w) "0x" ++ showHex w "" where hi = fromIntegral (w `shiftR` 16) lo = fromIntegral w -satisfy :: (Stream LB.ByteString m Word8) => (Word8 -> Bool) -> ParsecT LB.ByteString u m Word8 +satisfy :: (Stream LBS m Word8) => (Word8 -> Bool) -> ParsecT LBS u m Word8 satisfy f = tokenPrim (\c -> "0x" ++ showHex c "") (\pos _ _ -> pos) (\c -> if f c then Just c else Nothing) -anyWord8 :: (Stream LB.ByteString m Word8) => ParsecT LB.ByteString u m Word8 +anyWord8 :: (Stream LBS m Word8) => ParsecT LBS u m Word8 anyWord8 = anyToken -anyWord16 :: (Stream LB.ByteString m Word8) => ParsecT LB.ByteString u m Word16 +anyWord16 :: (Stream LBS m Word8) => ParsecT LBS u m Word16 anyWord16 = do hi <- anyWord8 lo <- anyWord8 return $ (fromIntegral hi `shiftL` 8) .|. fromIntegral lo -anyWord32 :: (Stream LB.ByteString m Word8) => ParsecT LB.ByteString u m Word32 +anyWord32 :: (Stream LBS m Word8) => ParsecT LBS u m Word32 anyWord32 = do hi <- anyWord16 lo <- anyWord16 return $ (fromIntegral hi `shiftL` 16) .|. fromIntegral lo -string :: (Stream LB.ByteString m Word8) => LB.ByteString -> ParsecT LB.ByteString u m LB.ByteString -string s = mapM_ word8 (LB.unpack s) >> return s +string :: (Stream LBS m Word8) => LBS -> ParsecT LBS u m LBS +string s = mapM_ word8 (LBS.unpack s) >> return s -block :: (Stream LB.ByteString m Word8) => Int -> ParsecT LB.ByteString u m LB.ByteString +block :: (Stream LBS m Word8) => Int -> ParsecT LBS u m LBS block size = do -- count size anyWord8 >>= return . LB.pack i <- getInput - let (s,r) = LB.splitAt (fromIntegral size) i + let (s,r) = LBS.splitAt (fromIntegral size) i setInput r return s allowedValues :: (a -> Parser a) -> [(a,b)] -> Parser b -allowedValues fn = choice . map (\(val,res) -> fn val >> return res) +allowedValues fn = choice . map (\(val,res) -> fn val >> return res) parseFromFile :: Parser a -> FilePath -> IO (Either String a) parseFromFile p fname - = do input <- LB.readFile fname + = do input <- LBS.readFile fname return $ case runP p () fname input of Left err -> Left (show err) Right x -> Right x - - diff --git a/Gamgine/Math/Vect.hs b/Gamgine/Math/Vect.hs --- a/Gamgine/Math/Vect.hs +++ b/Gamgine/Math/Vect.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + module Gamgine.Math.Vect (module Data.Vec,Vect,Vect4,x,y,z,v3,v4,fromTuple,toTuple,fromVect4,len, inverseVec,clampVec,maxVec,minVec,index,absVec,nullVec,and,or,all,any) where