packages feed

binary-file 0.15.24 → 0.15.25

raw patch · 6 files changed

+342/−65 lines, 6 files

Files

binary-file.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		binary-file-version:	0.15.24+version:	0.15.25 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>
examples/readBitmap.hs view
@@ -1,72 +1,347 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, FlexibleInstances, ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--import File.Binary (binary, Field(..), Binary(..), readBinaryFile, writeBinaryFile)-import File.Binary.Instances.LittleEndian ()-import File.Binary.Instances ()-import Data.ByteString.Lazy (singleton)-import Data.Monoid (mconcat)-import Control.Applicative ((<$>))-import System.Environment (getArgs)+{-# LANGUAGE ScopedTypeVariables #-} ---------------------------------------------------------------------------------+import System.Environment+import Control.Applicative+import BitmapCore+import Data.List+import Data.Maybe  main :: IO () main = do 	[inf, outf] <- getArgs-	bmp <- readBitmap inf-	putStrLn $ take 1000 (show bmp) ++ "..."-	writeBitmap outf bmp+	Right (bmp :: Bitmap, "") <- fromBinary () <$> readBinaryFile inf+	putStrLn $ take 5000 (show bmp) ++ "..."+	let	img = bmpToImage bmp+		bmp' = imageToBMP img+		Right bin = toBinary () bmp'+	writeBinaryFile outf bin -readBitmap :: FilePath -> IO Bitmap-readBitmap fp = do-	Right (bmp, "") <- fromBinary () <$> readBinaryFile fp-	return bmp+type Image = [[RGB8]]+data RGB8 = RGB8 Int Int Int deriving (Show, Eq, Ord) -writeBitmap :: FilePath -> Bitmap -> IO ()-writeBitmap fp bmp = do-	let Right bin = toBinary () bmp-	writeBinaryFile fp bin+border, border2 :: Image+border = take 100 $ cycle+	[replicate 100 $ RGB8 0 0 0, replicate 100 $ RGB8 255 255 255] -instance Field (Int, Int, Int) where-	type FieldArgument (Int, Int, Int) = ()-	fromBinary _ s = do-		(b, rest) <- fromBinary 1 s-		(g, rest') <- fromBinary 1 rest-		(r, rest'') <- fromBinary 1 rest'-		return ((b, g, r), snd $ getBytes 1 rest'')-	toBinary _ (b, g, r) = do-		b' <- toBinary 1 b-		g' <- toBinary 1 g-		r' <- toBinary 1 r-		return $ mconcat [b', g', r', makeBinary $ singleton 0]+border2 = take 100 $ cycle [+	replicate 100 $ RGB8 0 0 0, replicate 100 $ RGB8 255 255 255,+	replicate 100 $ RGB8 255 0 0, replicate 100 $ RGB8 0 0 255+ ] -[binary|+rgb24ToRGB8 :: RGB24 -> RGB8+rgb24ToRGB8 (RGB24 r g b) = RGB8 r g b -Bitmap+rgb32ToRGB8 :: RGB32 -> RGB8+rgb32ToRGB8 (RGB32 r g b) = RGB8 r g b -deriving Show+rgb8ToRGB32 :: RGB8 -> RGB32+rgb8ToRGB32 (RGB8 r g b) = RGB32 r g b -2: "BM"-4: fileSize-2: 0-2: 0-4: offset+rgb8ToRGB24 :: RGB8 -> RGB24+rgb8ToRGB24 (RGB8 r g b) = RGB24 r g b -4: 40-4: width-4: height-2: 1-2: bits_per_pixel-4: compression-4: image_size-4: resolutionH-4: resolutionV-4: color_num-4: important_colors_num--- ((), Just color_num){[(Int, Int, Int)]}: colors--- ((), Just image_size){String}: image-replicate color_num (){[(Int, Int, Int)]}: colors-replicate image_size (){String}: image+linesToImage :: [RGB32] -> [Line] -> Image+linesToImage plt = reverse . map (pixelsToImage plt . line) -|]+pixelsToImage :: [RGB32] -> Pixels -> [RGB8]+pixelsToImage _ (Colors24 cs) = map rgb24ToRGB8 cs+pixelsToImage _ (Colors32 cs) = map rgb32ToRGB8 cs+pixelsToImage plt (Indices is) = map rgb32ToRGB8 $ map (plt !!) is++bmpToImage :: Bitmap -> Image+bmpToImage = linesToImage <$> colors <*> image++getImage :: [RGB32] -> Image -> [Line]+getImage plt = map (Line . imageToPixels plt)++imageToPixels :: [RGB32] -> [RGB8] -> Pixels+imageToPixels plt ln+	| notBigger 256 plt =+		Indices $ map (fromJust . flip findIndex plt . (==) . rgb8ToRGB32) ln+	| otherwise = Colors24 $ map rgb8ToRGB24 ln++getMandrill :: IO Image+getMandrill = do+	Right (bmp, "") <- fromBinary () <$> readBinaryFile "tmp/Mandrill.bmp"+	return $ bmpToImage bmp++getLady :: IO Image+getLady = do+	Right (bmp, "") <- fromBinary () <$> readBinaryFile "tmp/test.bmp"+	return $ bmpToImage bmp++imageToBMP :: Image -> Bitmap+imageToBMP img_ = Bitmap {+		fileSize = ofst + isize,+		offset = ofst,+		width = length $ head img,+		height = length img,+		bits_per_pixel = getbpp plt,+		compression = 0,+		image_size = getISize plt img,+		resolutionH = 0,+		resolutionV = 0,+		color_num = cnum,+		important_colors_num = 0,+		colors = if notBigger 256 plt then plt else [],+		image = getImage plt img+	 }+	where+	plt = getColors img+	cnum = if notBigger 256 plt then length plt else 0+	ofst = getOffset plt+	isize = getISize plt img+	img = reverse img_++getColors :: Image -> [RGB32]+getColors = map (rgb8ToRGB32 . head) . group . sort . concat++notBigger :: Int -> [a] -> Bool+notBigger _ [] = True+notBigger 0 _ = False+notBigger n (x : xs) = notBigger (n - 1) xs++getbpp :: [RGB32] -> Int+getbpp cs+	| notBigger 2 cs = 1+	| notBigger 16 cs = 4+	| notBigger 256 cs = 8+	| otherwise = 24++getISize :: [RGB32] -> Image -> Int+getISize plt img = addPadd (bpp * w) `div` 8 * h+	where+	bpp = getbpp plt+	w = length $ head img+	h = length img+	addPadd x = x + paddBits x++getOffset :: [RGB32] -> Int+getOffset plt+	| notBigger 256 plt = length plt * 4 + 54+	| otherwise = 54++strsToImage :: [String] -> Image+strsToImage = map strToRGBs++strToRGBs :: String -> [RGB8]+strToRGBs = map $ fromJust . flip lookup [+	('*', RGB8 255 0 0),+	('#', RGB8 0 0 0),+	('.', RGB8 255 255 255)+ ]++strsToBin :: (Monad m, Applicative m) => [String] -> m String+strsToBin = toBinary () . imageToBMP . strsToImage++writeStrPic :: FilePath -> [String] -> IO ()+writeStrPic fp strs = writeBinaryFile fp =<< strsToBin strs++flipH = reverse+flipV = map reverse+scale img n = concatMap (replicate n . concatMap (replicate n)) img+above = (++)+beside = zipWith (++)++rotate = flipH . flipV++nega = map $ map $ \p -> case p of { '#' -> '.'; '*' -> '.'; '.' -> '*' }++superimpose = zipWith (zipWith combine)++combine topCh botCh+	| topCh == '#' = '#'+	| topCh == '*' = '*'+	| botCh == '#' = '#'+	| botCh == '*' = '*'+	| otherwise = '.'++sampleImg :: [String]+sampleImg = [+	"******************************************************",+	"*....................................................*",+	"*....................................................*",+	"*....................................................*",+	"*....................................................*",+	"*....................................................*",+	"*........*******************.........................*",+	"*.........*****************..........................*",+	"*..........***************...........................*",+	"*...........*************............................*",+	"*............***********.............................*",+	"*.............*********..............................*",+	"*..............*******...............................*",+	"*...............*****................................*",+	"*................***.................................*",+	"*.................*..................................*",+	"*....................................................*",+	"*....................................................*",+	"*....................................................*",+	"*....................................................*",+	"*....................................................*",+	"*............**......................................*",+	"*............**......................................*",+	"*............**......................................*",+	"*............**......................................*",+	"*............**......................................*",+	"*............**......................................*",+	"*............**......................................*",+	"*............**......................................*",+	"*............**......................................*",+	"*............**......................................*",+	"*............**......................................*",+	"*............**....................***...............*",+	"*............**...................*****..............*",+	"*............**...................*****..............*",+	"*.................................*****..............*",+	"*..................................***...............*",+	"*....................................................*",+	"*....................................................*",+	"*....................................................*",+	"*....................................................*",+	"*....................................................*",+	"*....................................................*",+	"*....................................................*",+	"******************************************************"+ ]++horse :: [String]+horse = [+	".......##...",+	".....##..#..",+	"...##.....#.",+	"..#.......#.",+	"..#...#...#.",+	"..#...###.#.",+	".#....#..##.",+	"..#...#..##.",+	"...#...#....",+	"....#...#...",+	".....#..#...",+	"......#.#...",+	".......##..."+ ]++yo :: [String]+yo = [+	"................",+	"................",+	".......##.......",+	".......##.......",+	".......##.......",+	".......#####....",+	".......#####....",+	".......##.......",+	".......##.......",+	".......##.......",+	".....#######....",+	"....#########...",+	"...##..##..##...",+	"...######.......",+	"....####........",+	"................"+ ]++shi :: [String]+shi = [+	".............",+	".............",+	"...##........",+	"...##........",+	"...##........",+	"...##........",+	"...##........",+	"...##........",+	"...##........",+	"...##........",+	"...##....##..",+	"...##....##..",+	"....#######..",+	".....####....",+	".............",+	"............."+ ]++ku :: [String]+ku = [+	"...............",+	"...............",+	".......###.....",+	"......###......",+	".....###.......",+	"....###........",+	"...###.........",+	"..###..........",+	"..###..........",+	"...###.........",+	"....###........",+	".....###.......",+	"......###......",+	".......###.....",+	"...............",+	"..............."+ ]++ni :: [String]+ni = [+	"................",+	"................",+	"..##............",+	"..##...#####....",+	"..##..#######...",+	"..##............",+	"..##............",+	"..##............",+	"..##............",+	"..##............",+	"..##..#######...",+	"..##...#####....",+	"...##...........",+	"...##...........",+	"................",+	"................"+ ]++margeH :: [RGB8] -> [RGB8]+margeH [] = []+margeH [rgb] = [rgb]+margeH (RGB8 r1 g1 b1 : RGB8 r2 g2 b2 : rest) =+	RGB8 (average r1 r2) (average g1 g2) (average b1 b2) : margeH rest++average x y = (x + y) `div` 2+averageRGB8 (RGB8 r1 g1 b1) (RGB8 r2 g2 b2) =+	RGB8 (average r1 r2) (average g1 g2) (average b1 b2)++scaleDownH :: Image -> Image+scaleDownH = map margeH++scaleDownV :: Image -> Image+scaleDownV [] = []+scaleDownV [l] = [l]+scaleDownV (l1 : l2 : rest) = zipWith averageRGB8 l1 l2 : scaleDownV rest++scaleDown :: Image -> Image+scaleDown = scaleDownV . scaleDownH++getLena64 = scaleDown <$> scaleDown <$> scaleDown <$> getLady+getMandrill64 = scaleDown <$> scaleDown <$> scaleDown <$> getMandrill++writeImage :: FilePath -> Image -> IO ()+writeImage fp img = writeBinaryFile fp =<< toBinary () (imageToBMP img)++mirrorV img = img `beside` flipV img+mirrorH img = img `above` flipH img+mirror = mirrorV . mirrorH++scalePattern :: Image -> Image+scalePattern img =+	img' `beside` img' `above` img `beside` (img' `above` img' `above` img')+	where+	img' = scaleDown img++gradation :: Image+gradation =+	replicate 5 (map (\x -> RGB8 x x x) $ [0, 2 .. 255]) +++	replicate 5 (map (\x -> RGB8 x 0 0) $ [0, 2 .. 255]) +++	replicate 5 (map (\x -> RGB8 0 x 0) $ [0, 2 .. 255]) +++	replicate 5 (map (\x -> RGB8 0 0 x) $ [0, 2 .. 255])
src/File/Binary/Classes.hs view
@@ -27,7 +27,8 @@ 	consToBits a f ([], b) = do 		ret <- (`mappend` b) <$> toBinary a f 		return ([], ret)-	consToBits _ _ _ = fail "consToBits: not bytes (1 byte = 8 bits)"+	consToBits _ _ (bits, _) =+		fail $ "consToBits: not bytes (1 byte = 8 bits) " ++ show bits  	fromBinary a b = do 		ret <- fromBits a ([], b)@@ -38,7 +39,8 @@ 		ret <- consToBits a f ([], mempty) 		case ret of 			([], bin) -> return bin-			_ -> fail "toBinary: not bytes (1 byte = 8 bits)"+			(bits, _) -> fail $+				"toBinary: not bytes (1 byte = 8 bits) " ++ show bits  pop :: Binary b => b -> AddBits b pop = first (wtbs (8 :: Int) . head . unpack) . getBytes 1
src/File/Binary/Instances/LSB0.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE TypeFamilies #-} {-# OPtIONS_GHC -fno-warn-orphans #-} -module File.Binary.Instances.LSB0 (BitsInt, bitsInt) where+module File.Binary.Instances.LSB0 (BitsInt(..)) where  import File.Binary.Classes import Data.Bits
src/File/Binary/Instances/MSB0.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module File.Binary.Instances.MSB0 (BitsInt) where+module File.Binary.Instances.MSB0 (BitsInt(..)) where  import File.Binary.Classes import Data.Bits (Bits, shiftL, shiftR, (.|.), (.&.))
src/File/Binary/Quote.hs view
@@ -12,7 +12,7 @@ 	instanceD, funD, clause, normalB, valD, tySynInstD, cxt, 	conT, appT, sigE, varP, tupP, condE, recConE, tupE, listE, 	appE, appsE, infixApp, varE, conE, litE, newName, integerL, stringL,-	doE, bindS, noBindS, letS, tildeP)+	doE, bindS, noBindS, letS, tildeP, tySynEqn) import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Data.ByteString.Lazy.Char8 (pack) import Control.Monad (zipWithM, foldM)@@ -35,7 +35,7 @@ 		map (varStrictType <$> fst <*> strictType notStrict . snd) $ 			rights' $ map valueOf $ sItems bs] (sDerive bs) 	    <*> instanceD (cxt []) (appT (conT ''Field) (conT c)) [-		tySynInstD ''FieldArgument [conT c] $ sArgType bs,+		tySynInstD ''FieldArgument . tySynEqn [conT c] $ sArgType bs, 		funD 'fromBits $ (: []) $ return r, 		funD 'consToBits $ (: []) $ writing fe (sArgName bs) (sItems bs)]