basic ff reading/writing
Getty Ritter
6 years ago
| 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
|