diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2011, Yoshikuni Jujo +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + * Neither the name of the Yoshikuni Jujo nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVEN SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/png-file.cabal b/png-file.cabal new file mode 100644 --- /dev/null +++ b/png-file.cabal @@ -0,0 +1,41 @@ +build-type: Simple +cabal-version: >= 1.8 + +name: png-file +version: 0.0.1.0 +stability: Experimental +author: Yoshikuni Jujo +maintainer: Yoshikuni Jujo +homepage: https://skami.iocikun.jp/haskell/packages/png-file + +license: BSD3 +license-file: LICENSE + +category: File +synopsis: read/write png file +description: + + It's just alpha version now. + +source-repository head + type: git + location: git://github.com/YoshikuniJujo/png-file.git + +source-repository this + type: git + location: git://github.com/YoshikuniJujo/png-file.git + tag: 0.0.1.0 + +library + hs-source-dirs: src + exposed-modules: File.Binary.PNG + other-modules: + File.Binary.PNG.Data, + File.Binary.PNG.Chunks, + File.Binary.PNG.Chunks.CRC, + File.Binary.PNG.Chunks.Each, + Language.Haskell.TH.Tools + build-depends: + base > 3 && < 5, binary-file, bytestring, zlib, array, + template-haskell, monads-tf + ghc-options: -Wall diff --git a/src/File/Binary/PNG.hs b/src/File/Binary/PNG.hs new file mode 100644 --- /dev/null +++ b/src/File/Binary/PNG.hs @@ -0,0 +1,63 @@ +module File.Binary.PNG ( + getChunks, + putChunks, + + mkChunks, + ihdr, IHDR(..), + plte, + body, + others, + ICCP(..), + + TypeChunk(..), + typeChunk, + Chunk(..), + makePNGHeader, + bsToPNGImage, + pngImageToBS, + PNGImageL(..), + PNGImageLColor(..), + + readIccp +) where + +import Prelude hiding (concat) +import Data.List (find) +import Data.Maybe (fromJust) +import Data.ByteString.Lazy (ByteString, toChunks, fromChunks, concat) +import Codec.Compression.Zlib ( + decompress, compressWith, defaultCompressParams, CompressParams(..), + bestCompression, WindowBits(..)) +import File.Binary.PNG.DataChunks ( + Chunk(..), TypeChunk(..), typeChunk, IHDR(..), PLTE, IDAT(..), + ICCP(..), + getChunks, putChunks, makePNGHeader, bsToPNGImage, PNGImageL(..), + PNGImageLColor(..), pngImageToBS, readIccp) + +-------------------------------------------------------------------------------- + +body :: [Chunk] -> ByteString +body = decompress . concat . map (idat_body . (\(ChunkIDAT i) -> i)) . + filter ((== T_IDAT) . typeChunk) + +mkBody :: ByteString -> [Chunk] +mkBody = map (ChunkIDAT . IDAT . fromChunks . (: [])) . toChunks . + compressWith defaultCompressParams { + compressLevel = bestCompression, + compressWindowBits = WindowBits 10 + } + +ihdr :: [Chunk] -> IHDR +ihdr = (\(ChunkIHDR i) -> i) . fromJust . find ((== T_IHDR) . typeChunk) + +plte :: [Chunk] -> Maybe PLTE +plte c = do + ChunkPLTE pl <- find ((== T_PLTE) . typeChunk) c + return pl + +others :: [Chunk] -> [Chunk] +others = filter $ (`notElem` [T_IHDR, T_PLTE, T_IDAT, T_IEND]) . typeChunk + +mkChunks :: IHDR -> Maybe PLTE -> [Chunk] -> ByteString -> [Chunk] +mkChunks i (Just p) cs b = ChunkIHDR i : ChunkPLTE p : mkBody b ++ cs +mkChunks i Nothing cs b = ChunkIHDR i : mkBody b ++ cs diff --git a/src/File/Binary/PNG/Chunks.hs b/src/File/Binary/PNG/Chunks.hs new file mode 100644 --- /dev/null +++ b/src/File/Binary/PNG/Chunks.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies, OverloadedStrings #-} + +module File.Binary.PNG.Chunks ( + Chunk(..), + TypeChunk(..), + typeChunk, + + getChunks, + putChunks, + + IHDR(..), PLTE(..), RGB8(..), IDAT(..), IEND(..), + TRNS, + CHRM(..), GAMA(..), ICCP(..), SBIT, SRGB(..), + ITXT, TEXT(..), ZTXT, + BKGD(..), HIST, PHYS, SPLT, + TIME, + DATA(..) +) where + +import Control.Applicative ((<$>)) +import Control.Arrow (first) +import Control.Monad (unless) +import Data.Monoid (mempty) +import Data.List (isPrefixOf) +import Data.ByteString.Lazy (ByteString, append) +import qualified Data.ByteString.Lazy as BSL (length) +import Language.Haskell.TH ( + newName, nameBase, litP, stringL, + cxt, instanceD, tySynInstD, clause, normalB, + conT, appT, conP, varP, wildP, tupP, conE, varE, appE, appsE, infixApp) +import Language.Haskell.TH.Tools (wrapTypes, makeTypes, nameTypes, mapTypesFun) +import File.Binary (binary, Field(..), Binary(..)) +import File.Binary.Instances () +import File.Binary.Instances.BigEndian () +import File.Binary.PNG.Chunks.CRC (crc, checkCRC) +import File.Binary.PNG.Chunks.Each ( + IHDR(..), PLTE(..), RGB8(..), IDAT(..), IEND(..), + TRNS, CHRM(..), GAMA(..), ICCP(..), SBIT, SRGB(..), ITXT, TEXT(..), ZTXT, + BKGD(..), HIST, PHYS, SPLT, TIME, DATA(..), + chunkNames, beforePLTE, beforeIDAT, anyPlace) + + +-------------------------------------------------------------------------------- + +wrapTypes "Chunk" chunkNames ("ChunkOthers", [''ByteString, ''ByteString]) [''Show] +makeTypes "TypeChunk" ''Chunk "Chunk" "T_" +nameTypes ''TypeChunk "T_" 'T_Others ''ByteString + +(:[]) <$> do + let removePrefix prefix str + | prefix `isPrefixOf` str = drop (length prefix) str + | otherwise = str + instanceD (cxt []) (conT ''Field `appT` conT ''Chunk) [ + tySynInstD ''FieldArgument [conT ''Chunk] [t| (Int, ByteString) |], + mapTypesFun 'fromBinary ''Chunk $ \con _ -> do + [n, typ] <- mapM newName ["n", "typ"] + let (t, c) = if con /= 'ChunkOthers + then (litP $ stringL $ removePrefix "Chunk" $ + nameBase con, conE con) + else (varP typ, conE con `appE` varE typ) + flip (clause [tupP [varP n, t]]) [] $ normalB $ infixApp + (varE 'fmap `appE` (varE 'first `appE` c)) + (varE '(.)) + (varE 'fromBinary `appE` varE n), + mapTypesFun 'toBinary ''Chunk $ \con _ -> do + [n, dt] <- mapM newName ["n", "dt"] + let d = conP con $ if con /= 'ChunkOthers + then [varP dt] else [wildP, varP dt] + flip (clause [tupP [varP n, wildP], d]) [] $ normalB $ + appsE [varE 'toBinary, varE n, varE dt]] + +bplte, bidat, aplace :: [TypeChunk] +[bplte, bidat, aplace] = + map (map nameToTypeChunk) [beforePLTE, beforeIDAT, anyPlace] + +getChunks :: Binary b => b -> Either String [Chunk] +getChunks b = do + (p, rest) <- fromBinary () b + unless (rest == mempty) $ fail "couldn't read whole binary" + return $ map chunkData $ chunks p + +putChunks :: Binary b => [Chunk] -> Either String b +putChunks cs = do + ret <- mapM createChunk $ sortChunks cs + toBinary () $ PNGFile $ ret + +createChunk :: Chunk -> Either String ChunkStructure +createChunk cd = do + let name = typeChunkToName $ typeChunk cd + ret <- toBinary (undefined, name) cd + return $ ChunkStructure { + chunkSize = fromIntegral $ BSL.length ret, + chunkName = name, + chunkData = cd, + chunkCRC = CRC } + +sortChunks :: [Chunk] -> [Chunk] +sortChunks cs = concatMap (($ cs) . filterChunks) + [[T_IHDR], bplte, [T_PLTE], bidat, [T_IDAT], aplace, [T_IEND]] + where + filterChunks ts = filter $ (`elem` ts) . typeChunk + +[binary| + +PNGFile deriving Show + +1: 0x89 +3: "PNG" +2: "\r\n" +1: "\SUB" +1: "\n" +repeat (){[ChunkStructure]}: chunks + +|] + +[binary| + +ChunkStructure deriving Show + +4: chunkSize +4{ByteString}: chunkName +(chunkSize, chunkName){Chunk}: chunkData +(chunkName, chunkData, (chunkSize, chunkName)){CRC}: chunkCRC + +|] + +data CRC = CRC deriving Show + +instance Field CRC where + type FieldArgument CRC = (ByteString, Chunk, (Int, ByteString)) + fromBinary (name, body, arg) b = do + let (bs, rest) = getBytes 4 b + ret <- toBinary arg body + if checkCRC (name `append` ret) bs + then return (CRC, rest) + else fail "bad crc" + toBinary (name, body, arg) _ = do + ret <- toBinary arg body + return $ makeBinary $ crc $ name `append` ret diff --git a/src/File/Binary/PNG/Chunks/CRC.hs b/src/File/Binary/PNG/Chunks/CRC.hs new file mode 100644 --- /dev/null +++ b/src/File/Binary/PNG/Chunks/CRC.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} + +module File.Binary.PNG.Chunks.CRC (checkCRC, crc) where + +import Prelude hiding (reverse) +import Data.Array (Array, listArray, (!)) +import Data.Word (Word32) +import Data.Bits ((.&.), xor, shiftR) +import Data.ByteString.Lazy (ByteString, cons', append, reverse) +import qualified Data.ByteString.Lazy as BSL (foldl) +import Data.ByteString.Lazy.Char8 () + +-------------------------------------------------------------------------------- + +checkCRC :: ByteString -> ByteString -> Bool +checkCRC str c = crc (str `append` reverse c) == "\x21\x44\xdf\x1c" + +crc :: ByteString -> ByteString +crc = reverse . word32ToBS . xor 0xffffffff . BSL.foldl crc' 0xffffffff + where + crc' c x = table ! (c .&. 0xff `xor` fromIntegral x) `xor` shiftR c 8 + +table :: Array Word32 Word32 +table = listArray (0, 255) $ map (\n -> iterate crc8bit n !! 8) [0 .. 255] + +crc8bit :: Word32 -> Word32 +crc8bit c + | c .&. 1 == 0 = shiftR c 1 + | otherwise = 0xedb88320 `xor` shiftR c 1 + +word32ToBS :: Word32 -> ByteString +word32ToBS 0 = "" +word32ToBS w = fromIntegral (w .&. 0xff) `cons'` word32ToBS (w `shiftR` 8) diff --git a/src/File/Binary/PNG/Chunks/Each.hs b/src/File/Binary/PNG/Chunks/Each.hs new file mode 100644 --- /dev/null +++ b/src/File/Binary/PNG/Chunks/Each.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, OverloadedStrings #-} + +module File.Binary.PNG.Chunks.Each ( + IHDR(..), PLTE(..), RGB8(..), IDAT(..), IEND(..), + TRNS, + CHRM(..), GAMA(..), ICCP(..), SBIT, SRGB(..), + ITXT, TEXT(..), ZTXT, + BKGD(..), HIST, PHYS, SPLT, TIME, + DATA(..), + + chunkNames, critical, beforePLTE, beforeIDAT, anyPlace +) where + +import Data.Monoid (mconcat) +import Data.ByteString.Lazy (ByteString, append) +import File.Binary (binary, Field(..), Binary(..)) +import File.Binary.Instances () +import File.Binary.Instances.BigEndian () +import File.Binary.Instances.MSB0 () +import qualified Data.ByteString.Lazy.Char8 as BSLC + +-------------------------------------------------------------------------------- + +chunkNames, critical, beforePLTE, beforeIDAT, anyPlace :: [String] +chunkNames = critical ++ beforePLTE ++ beforeIDAT ++ anyPlace +critical = ["IHDR", "PLTE", "IDAT", "IEND"] +beforePLTE = ["cHRM", "gAMA", "iCCP", "sBIT", "sRGB", "bKGD", "hIST", "tRNS"] +beforeIDAT = ["pHYs", "sPLT"] +anyPlace = ["tIME", "iTXt", "tEXt", "zTXt"] + +type TRNS = DATA +-- type ICCP = DATA +type SBIT = DATA +type ITXT = DATA +type ZTXT = DATA +type HIST = DATA +type PHYS = DATA +type SPLT = DATA +type TIME = DATA + +[binary| + +IHDR deriving Show + +arg :: Int + +4: width +4: height +1: depth +: False +: False +: False +: False +: False +{Bool}: alpha +{Bool}: color +{Bool}: palet +1: compressionType +1: filterType +1: interlaceType + +|] + +[binary| + +PLTE deriving Show + +arg :: Int + +replicate (arg `div` 3) (){[RGB8]}: colors + +|] + +data RGB8 = RGB8 { red :: Int, green :: Int, blue :: Int } deriving Show + +instance Field RGB8 where + type FieldArgument RGB8 = () + toBinary () RGB8{ red = r, green = g, blue = b } = do + r' <- toBinary 1 r + g' <- toBinary 1 g + b' <- toBinary 1 b + return $ mconcat [r', g', b'] + fromBinary () bin = do + (r, bin') <- fromBinary 1 bin + (g, bin'') <- fromBinary 1 bin' + (b, bin''') <- fromBinary 1 bin'' + return (RGB8{ red = r, green = g, blue = b } , bin''') + +[binary| + +IDAT deriving Show + +arg :: Int + +arg{ByteString}: idat_body + +|] + +[binary|IEND deriving Show arg :: Int|] + +[binary| + +CHRM deriving Show + +arg :: Int + +replicate (arg `div` 4) 4{[Int]}: chrms + +|] + +[binary| + +GAMA deriving Show + +arg :: Int + +4: gamma + +|] + +[binary| + +ICCP deriving Show + +arg :: Int + +{NullString}: iccp_name +1: iccp_con +(arg - length (nullString iccp_name) - 2){ByteString}: iccp_body + +|] + +data NullString = NullString { nullString :: String } deriving Show + +instance Field NullString where + type FieldArgument NullString = () + toBinary () (NullString str) = + return $ makeBinary $ (`append` "\NUL") $ BSLC.pack str + fromBinary () bin = do + let (ret, rest) = spanBytes (/= 0) bin + return (NullString $ BSLC.unpack ret, snd $ unconsByte rest) + +[binary| + +SRGB deriving Show + +arg :: Int + +1: srgb + +|] + +[binary| + +TEXT deriving Show + +arg :: Int + +replicate arg (){String}: text + +|] + +[binary| + +BKGD deriving Show + +arg :: Int + +arg{ByteString}: bkgd + +|] + +[binary| + +DATA deriving Show + +arg :: Int + +arg{ByteString}: dat + +|] diff --git a/src/File/Binary/PNG/Data.hs b/src/File/Binary/PNG/Data.hs new file mode 100644 --- /dev/null +++ b/src/File/Binary/PNG/Data.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE + TypeFamilies, + FlexibleContexts, + ScopedTypeVariables, + TupleSections, + OverloadedStrings, + PackageImports #-} + +module File.Binary.PNG.Data ( + PNG(..), PNGImage(..), PNGColorType(..), PNGHeader(..), + PNGImageL(..), PNGImageLColor(..), readIccp, +) where + +import qualified Data.ByteString.Lazy as BSL +import Data.Word +import Data.Int +import Data.Maybe +import Data.Bits +import Codec.Compression.Zlib +import "monads-tf" Control.Monad.Error + +data PNG pi = PNG PNGValues [(String, BSL.ByteString)] pi + +data PNGValues = PNGValues { + pngChrm :: PNGChrm, + pngGama :: Int, + pngIccp :: (String, BSL.ByteString) + } + +readIccp :: BSL.ByteString -> BSL.ByteString +readIccp = decompress + +data PNGChrm = PNGChrm { + pngChrmWhite :: (Int, Int), + pngChrmRed :: (Int, Int), + pngChrmGreen :: (Int, Int), + pngChrmBlue :: (Int, Int) + } + +data PNGHeader = PNGHeader { + pngWidth :: Int, + pngHeight :: Int, + pngDepth :: Int, + pngColorType :: PNGColorType, + pngCompType :: Int, + pngFilterType :: Int, + pngInterlaceType :: Int, + pngPalette :: [(Int, Int, Int)] + } deriving Show + +data PNGColorType + = PNGTypeIndex { piTrans :: [Int] } + | PNGTypeGrey { pgTrans :: Maybe Int } | PNGTypeGreyAlpha + | PNGTypeColor { pcTrans :: Maybe (Int, Int, Int) } | PNGTypeColorAlpha + deriving Show + +class PNGColor (PNGImageColor pi) => PNGImage pi where + type PNGImageColor pi + type PNGImageError pi + + makePNGImage :: PNGHeader -> BSL.ByteString -> pi + fromPNGImage :: pi -> (PNGHeader, BSL.ByteString) + + goNext :: pi -> Either (PNGImageError pi) pi + getXY :: pi -> (Int, Int) + + goUp :: pi -> Either (PNGImageError pi) pi + goDown :: pi -> Either (PNGImageError pi) pi + goLeft :: pi -> Either (PNGImageError pi) pi + goRight :: pi -> Either (PNGImageError pi) pi + + getPixel :: pi -> PNGImageColor pi + setPixel :: pi -> PNGImageColor pi -> pi + +-- toPalet :: pi -> Either (PNGImageError pi) pi +-- toGrey :: pi -> Either (PNGImageError pi) pi +-- fromAlpha :: pi -> Either (PNGImageError pi) pi + toInterlace :: pi -> pi + fromInterlace :: pi -> pi + +class PNGColor pc where + +data PNGImageL = PNGImageL { + pilInterlace :: Bool, + pilBits :: Int, + pilBackLines :: [([PNGImageLColor], [PNGImageLColor])], + pilForwardLines :: [([PNGImageLColor], [PNGImageLColor])]} + deriving Show + +data PNGImageLColor = PNGImageLColor Int Int Int Int deriving Show + +instance PNGImage PNGImageL where + type PNGImageColor PNGImageL = PNGImageLColor + type PNGImageError PNGImageL = String + makePNGImage = makePNGImageL + fromPNGImage = fromPNGImageL + + goUp = pngImageLUp + goDown = pngImageLDown + goLeft = pngImageLLeft + goRight = pngImageLRight + +instance PNGColor PNGImageLColor where + +pngImageLUp, pngImageLDown, pngImageLLeft, pngImageLRight :: + PNGImageL -> Either String PNGImageL +pngImageLUp (PNGImageL _ _ [] _) = fail "can't go up" +pngImageLUp (PNGImageL False bits (u : us) ds) = + return $ PNGImageL False bits us (u : ds) +pngImageLDown (PNGImageL _ _ _ []) = fail "can't go down" +pngImageLDown (PNGImageL False bits us (d : ds)) = + return $ PNGImageL False bits (d : us) ds +pngImageLLeft (PNGImageL False bits us ds) = do + us' <- mapM gl us + ds' <- mapM gl ds + return $ PNGImageL False bits us' ds' + where + gl ([], _) = fail "can't go left" + gl (l : ls, rs) = return (ls, l : rs) +pngImageLRight (PNGImageL False bits us ds) = do + us' <- mapM gr us + ds' <- mapM gr ds + return $ PNGImageL False bits us' ds' + where + gr (_, []) = fail "can't go right" + gl (ls, r : rs) = return (r : ls, rs) + +fromPNGImageL :: PNGImageL -> (PNGHeader, BSL.ByteString) +fromPNGImageL pil@(PNGImageL False 8 us ds) = ( + PNGHeader { + pngWidth = pilWidth pil, + pngHeight = pilHeight pil, + pngDepth = 8, + pngColorType = PNGTypeColor Nothing, + pngCompType = 0, + pngFilterType = 0, + pngInterlaceType = 0, + pngPalette = [] + }, + BSL.pack $ + filterPNGImageL (replicate (w + 1) $ PNGImageLColor 0 0 0 65535) + $ map (\(ls, rs) -> ls ++ rs) $ us ++ ds +-- concatMap (\(ls, rs) -> +-- 0 : concatMap pilColorToWord8 (ls ++ rs)) $ us ++ ds + ) + where + w = case (us, ds) of + ((rs, ls) : _, _) -> length rs + length ls + (_, (rs, ls) : _) -> length rs + length ls + +pilWidth, pilHeight :: PNGImageL -> Int +pilWidth (PNGImageL False _ ((ls, rs) : _) _) = length ls + length rs +pilWidth (PNGImageL False _ _ ((ls, rs) : _)) = length ls + length rs +pilHeight (PNGImageL False _ us ds) = length us + length ds + +filterPNGImageL :: [PNGImageLColor] -> [[PNGImageLColor]] -> [Word8] +filterPNGImageL _ [] = [] +filterPNGImageL pre (l : ls) = 4 : + filterLinePNGImageL pre (PNGImageLColor 0 0 0 65535) l ++ + filterPNGImageL (PNGImageLColor 0 0 0 65535 : l) ls + +filterLinePNGImageL :: [PNGImageLColor] -> PNGImageLColor -> [PNGImageLColor] -> [Word8] +filterLinePNGImageL _ _ [] = [] +filterLinePNGImageL pre left (px : pxs) = + pilColorToWord8f 4 pre left px ++ + filterLinePNGImageL (tail pre) px pxs + +pilColorToWord8f :: + Int -> [PNGImageLColor] -> PNGImageLColor -> PNGImageLColor -> [Word8] +pilColorToWord8f 4 pre left px = let + PNGImageLColor rlu glu blu 65535 : PNGImageLColor ru gu bu 65535 : _ = pre + PNGImageLColor rl gl bl 65535 = left + PNGImageLColor rpx gpx bpx 65535 = px in [ +{- + fi rpx - ((fi ru + fi rl) `div` 2), + fi gpx - ((fi gu + fi gl) `div` 2), + fi bpx - ((fi bu + fi bl) `div` 2) +-} + fi rpx - paeth' (fi rl) (fi ru) (fi rlu), + fi gpx - paeth' (fi gl) (fi gu) (fi glu), + fi bpx - paeth' (fi bl) (fi bu) (fi blu) + ] + where + fi = fromIntegral . (`shiftR` 8) + +pilColorToWord8 :: PNGImageLColor -> [Word8] +pilColorToWord8 (PNGImageLColor r g b 65535) = [fi r, fi g, fi b] + where + fi = fromIntegral . (`shiftR` 8) + +makePNGImageL :: PNGHeader -> BSL.ByteString -> PNGImageL +makePNGImageL PNGHeader { + pngWidth = w, + pngHeight = h, + pngDepth = 8, + pngColorType = PNGTypeColor Nothing, + pngCompType = 0, + pngFilterType = 0, + pngInterlaceType = 0 + } bs = PNGImageL False 8 [] $ map ([] ,) $ bsToImageA w bs + +makePNGImageL PNGHeader { + pngWidth = w, + pngHeight = h, + pngDepth = 2, + pngColorType = PNGTypeIndex [], + pngCompType = 0, + pngFilterType = 0, + pngInterlaceType = 0, + pngPalette = p + } bs = PNGImageL False 8 [] $ map ([] ,) $ + groupN w $ map (intsToPNGImageLColor . (p !!)) $ concatMap toIndexes2 $ + map BSL.tail $ groupNBS (w `div` 4 + 1) bs + +groupN :: Int -> [a] -> [[a]] +groupN _ [] = [] +groupN n xs = take n xs : groupN n (drop n xs) + +groupNBS :: Int -> BSL.ByteString -> [BSL.ByteString] +groupNBS n_ bs + | BSL.null bs = [] + | otherwise = BSL.take n bs : groupNBS n_ (BSL.drop n bs) + where + n = fromIntegral n_ + +intsToPNGImageLColor :: (Int, Int, Int) -> PNGImageLColor +intsToPNGImageLColor = convert + +toIndexes2 :: BSL.ByteString -> [Int] +toIndexes2 bs = concatMap word2Int2 $ BSL.unpack bs + +word2Int2 :: Word8 -> [Int] +word2Int2 w = map fromIntegral [ + w `shiftR` 6, (w .&. 0x30) `shiftR` 4, + (w .&. 0x0c) `shiftR` 2, w .&. 0x03] + +bsToImageA :: Int -> BSL.ByteString -> [[PNGImageLColor]] +bsToImageA w = map (map convert) . bsToImage w + +convert (r, g, b) = PNGImageLColor + (toRGB16 r) (toRGB16 g) (toRGB16 b) (255 `shiftL` 8 .|. 255) + +-- toRGB16 :: Word8 -> Int +toRGB16 w = fromIntegral w `shiftL` 8 .|. fromIntegral w + +setpre :: Int -> BSL.ByteString -> BSL.ByteString -> BSL.ByteString +setpre w pre rgb + | fromIntegral (BSL.length pre) == w * 3 + 3 = BSL.drop 3 pre `BSL.append` rgb + | otherwise = error "bad pre" -- pre `append` rgb + +bsToImage w bs = reverse $ map reverse $ + bsToImage' w (BSL.replicate (fromIntegral w * 3 + 3) 0) bs [] + +bsToImage' :: Int -> BSL.ByteString -> BSL.ByteString -> [[(Word8, Word8, Word8)]] -> + [[(Word8, Word8, Word8)]] +bsToImage' w pre bs rets + | BSL.null bs = rets + | otherwise = let + Just (filter, dat') = BSL.uncons bs + (pre', ret, dat'') = bsToLine filter w 0 pre Nothing [] dat' in + bsToImage' w pre' dat'' (ret : rets) + +bsToLine :: Word8 -> Int -> Int -> BSL.ByteString -> + Maybe (Word8, Word8, Word8) -> + [(Word8, Word8, Word8)] -> BSL.ByteString -> + (BSL.ByteString, [(Word8, Word8, Word8)], BSL.ByteString) +bsToLine filter w x pre left ret dat + | x < w = let + tToL (r, g, b) = [r, g, b] + lToT [r, g, b] = (r, g, b) + l = fromMaybe (0, 0, 0) left + lu = (\[r, g, b] -> (r, g, b)) $ + maybe [0, 0, 0] (const $ take' 3 pre) left + color'@[r, g, b] = getColor filter + (tToL l) (take' 3 $ BSL.drop 3 pre) (tToL lu) (take' 3 dat) + color = (r, g, b) in + bsToLine filter w (x + 1) (setpre w pre $ BSL.pack color') + (Just color) (color : ret) $ BSL.drop 3 dat + | otherwise = (pre, ret, dat) + +zipWith4 :: (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e] +zipWith4 _ [] [] [] [] = [] +zipWith4 f (x : xs) (y : ys) (z : zs) (w : ws) = f x y z w : zipWith4 f xs ys zs ws + +getColor 0 left up leftup rgb = rgb +getColor 1 left up leftup rgb = zipWith (+) left rgb +getColor 2 left up leftup rgb = zipWith (+) up rgb +getColor 3 left up leftup rgb = zipWith3 (\l u p -> p + (l + u) `div` 2) left up rgb +getColor 4 left up leftup rgb = zipWith4 getByte4'' left up leftup rgb + +getByte4'' :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 +getByte4'' left up leftup rgb = paeth' left up leftup + rgb + +paeth' :: Word8 -> Word8 -> Word8 -> Word8 +paeth' a b c = let + [a', b', c'] = map fromIntegral [a, b, c] + p :: Int = a' + b' - c' + pa = abs $ p - a' + pb = abs $ p - b' + pc = abs $ p - c' in + if pa <= pb && pa <= pc then a else + if pb <= pc then b else c + +take' :: Int64 -> BSL.ByteString -> [Word8] +take' n = BSL.unpack . BSL.take n diff --git a/src/Language/Haskell/TH/Tools.hs b/src/Language/Haskell/TH/Tools.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/Tools.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Language.Haskell.TH.Tools ( + mapTypesFun, + wrapTypes, + makeTypes, + nameTypes +) where + +import Language.Haskell.TH ( + Info(TyConI), reify, Name, mkName, newName, nameBase, stringL, + DecsQ, DecQ, Dec(FunD, DataD), cxt, sigD, dataD, funD, + Con(NormalC), normalC, ClauseQ, clause, normalB, + TypeQ, Type, conT, appT, arrowT, conP, varP, wildP, litP, + conE, varE, appE, litE, strictType, notStrict) +import Control.Applicative ((<$>), (<*>)) +import Control.Arrow (first, (&&&)) +import Control.Monad (replicateM) +import Data.List (isPrefixOf) +import Data.String (fromString) +import Data.Char (toLower, toUpper) + +-------------------------------------------------------------------------------- + +mapTypesFun :: Name -> Name -> (Name -> [Type] -> ClauseQ) -> DecQ +mapTypesFun fname typ f = do + TyConI (DataD _ _ _ cons _) <- reify typ + clauses <- (`mapM` cons) $ \(NormalC n a) -> f n $ map snd a + return $ FunD fname clauses + +wrapTypes :: String -> [String] -> (String, [Name]) -> [Name] -> DecsQ +wrapTypes name types other deriv = let upper = map toUpper in fmap (: []) $ + flip (dataD (cxt []) (mkName name) []) deriv $ map + (normalC <$> fst <*> map (strictType notStrict . conT) . snd) $ + (++ [first mkName other]) $ flip map types $ + mkName . (name ++) &&& (: []) . mkName . upper + +makeTypes :: String -> Name -> String -> String -> DecsQ +makeTypes name dat preold prenew = do + TyConI (DataD _ _ _ cs _) <- reify dat + let (datN, funN) = mkName &&& mkName . headToLower $ name + ((ns, tns), as) = first (id &&& map chpre) $ unzip $ + map (\(NormalC n a) -> (n, map return $ init a)) cs + mkClause n a tn = do + t <- replicateM (length a) (newName "typ") + flip (clause [conP n (map varP t ++ [wildP])]) [] $ + normalB $ foldl (\c -> appE c . varE) (conE tn) t + dd <- dataD (cxt []) datN [] (zipWith normalC tns as) [''Eq, ''Show] + sd <- sigD funN $ conT dat --> conT datN + fd <- funD funN $ zipWith3 mkClause ns as tns + return [dd, sd, fd] + where chpre = mkName . (prenew ++) . removePrefix preold . nameBase + +removePrefix :: String -> String -> String +removePrefix pre str + | pre `isPrefixOf` str = drop (length pre) str + | otherwise = str + +nameTypes :: Name -> String -> Name -> Name -> DecsQ +nameTypes typ pre o st = do + TyConI (DataD _ _ _ cons _) <- reify typ + let types = filter (/= o) $ map (\(NormalC n _) -> n) cons + cs = map (removePrefix pre . nameBase) types + (++) <$> nameToType typ cs types o <*> typeToName typ types cs o st + +nameToType :: Name -> [String] -> [Name] -> Name -> DecsQ +nameToType typ strs types o = do + str <- newName "str" + let pats = map ((: []) . litP . stringL) strs ++ [[varP str]] + bodys = map normalB $ map conE types ++ + [conE o `appE` (varE 'fromString `appE` varE str)] + (\sd fd -> [sd, fd]) + <$> sigD fname (conT ''String --> conT typ) + <*> funD fname (zipWith3 clause pats bodys $ repeat []) + where fname = mkName $ ("nameTo" ++) $ nameBase typ + +typeToName :: Name -> [Name] -> [String] -> Name -> Name -> DecsQ +typeToName typ ts ss o st = do + str <- newName "str" + let pats = map ((: []) . ($ []) . conP) ts ++ [[conP o [varP str]]] + bodys = map normalB $ map (litE . stringL) ss ++ [varE str] + (\sd fd -> [sd, fd]) + <$> sigD fname (conT typ --> conT st) + <*> funD fname (zipWith3 clause pats bodys $ repeat []) + where fname = mkName $ (++ "ToName") $ headToLower $ nameBase typ + +(-->) :: TypeQ -> TypeQ -> TypeQ +t1 --> t2 = arrowT `appT` t1 `appT` t2 + +headToLower :: String -> String +headToLower "" = "" +headToLower (c : cs) = toLower c : cs