gdritter repos farbfeld / master
basic ff reading/writing Getty Ritter 2 years ago
3 changed file(s) with 103 addition(s) and 0 deletion(s). Collapse all Expand all
1 dist
2 dist-*
3 *~
4 cabal-dev
5 *.o
6 *.hi
7 *.chi
8 *.chs.h
9 *.dyn_o
10 *.dyn_hi
11 .hpc
12 .hsenv
13 .cabal-sandbox/
14 cabal.sandbox.config
15 *.prof
16 *.aux
17 *.hp
18 *.eventlog
19 cabal.project.local
20 .ghc.environment.*
1 name: farbfeld
2 version: 0.1.0.0
3 -- synopsis:
4 -- description:
5 license: BSD3
6 author: Getty Ritter <gettylefou@gmail.com>
7 maintainer: Getty Ritter <gettylefou@gmail.com>
8 copyright: @2018 Getty Ritter
9 -- category:
10 build-type: Simple
11 cabal-version: >=1.14
12
13 library
14 hs-source-dirs: src
15 ghc-options: -Wall
16 build-depends: base >=4.7 && <5
17 , bytestring
18 , cereal
19 , array
20 default-language: Haskell2010
21 default-extensions: ScopedTypeVariables
22 exposed-modules: Image.Farbfeld
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE RecordWildCards #-}
3
4 module Image.Farbfeld
5 ( Image(..)
6 , Pixel(..)
7 , parseImage
8 , emitImage
9 ) where
10
11 import Control.Monad (when, forM_)
12 import Data.Array (Array, array, bounds, (!))
13 import Data.ByteString.Lazy (ByteString)
14 import Data.Word (Word16, Word32)
15 import qualified Data.Serialize as S
16
17 newtype Image = Image
18 { imgPixels :: Array (Word32, Word32) Pixel
19 } deriving (Eq, Show)
20
21 data Pixel = Pixel
22 { pxRed :: !Word16
23 , pxGreen :: !Word16
24 , pxBlue :: !Word16
25 , pxAlpha :: !Word16
26 } deriving (Eq, Show)
27
28 parseImage :: ByteString -> Either String Image
29 parseImage = S.runGetLazy $ do
30 magic <- S.getByteString 8
31 when (magic /= "farbfeld") $
32 fail "Unable to find farbfeld magic number"
33 w <- S.getWord32be
34 h <- S.getWord32be
35 imgPixels <- array ((0, 0), (w-1, h-1)) <$> sequence
36 [ sequence ((x, y), getPixel)
37 | y <- [0..h-1]
38 , x <- [0..w-1]
39 ]
40 return Image { .. }
41
42 emitImage :: Image -> ByteString
43 emitImage (Image pixels) = S.runPutLazy $ do
44 S.putByteString "farbfeld"
45 let (w, h) = snd (bounds pixels)
46 S.putWord32be (w + 1)
47 S.putWord32be (h + 1)
48 forM_ [0..h] $ \y ->
49 forM_ [0..w] $ \x -> do
50 let Pixel { .. } = pixels ! (x, y)
51 S.putWord16be pxRed
52 S.putWord16be pxGreen
53 S.putWord16be pxBlue
54 S.putWord16be pxAlpha
55
56 getPixel :: S.Get Pixel
57 getPixel = Pixel
58 <$> S.getWord16be
59 <*> S.getWord16be
60 <*> S.getWord16be
61 <*> S.getWord16be