First pass at Pixels library

.gitignore

@@ -0,0 +1,4 @@
+*~
+dist
+dist-newstyle
+*.pbm

examples/Main.hs

@@ -0,0 +1,35 @@
+{-# LANGUAGE MultiWayIf #-}
+
+module Main where
+
+import Control.Monad (forM_)
+import Image.Pixels
+import qualified System.Random as R
+
+glyph :: FilePath -> IO ()
+glyph fp = do
+  rs <- fmap R.randoms R.newStdGen
+
+  let (w, h) = (3, 3)
+      (fw, fh) = (w * 2 - 1, h * 2 - 1)
+
+  let img = scaleUp 16 $ image black (fw + 2) (fh + 2) $ do
+        forM_ (zip [1..fw ] (cycle [True,False])) $ \ (x, xConn) ->
+          forM_ (zip [1..fh] (cycle [True,False])) $ \ (y, yConn) ->
+          let color = if | xConn && yConn ->
+                             white
+                         | xConn || yConn ->
+                             if rs !! fromIntegral (x + fw * y)
+                               then black
+                               else white
+                         | otherwise ->
+                             black
+          in draw color x y
+
+  savePBM fp img
+
+
+main :: IO ()
+main = do
+  forM_ [0..15] $ \ n -> do
+    glyph ("glyph" ++ show n ++ ".pbm")

pixels.cabal

@@ -0,0 +1,29 @@
+name:             pixels
+version:          0.1.0.0
+synopsis:         A simple library for working with image data on
+                  a pixel-by-pixel basis
+-- description:
+license:          BSD3
+license-file:     LICENSE
+author:           Getty Ritter <gettylefou@gmail.com>
+maintainer:       Getty Ritter <gettylefou@gmail.com>
+copyright:        ©2017 Getty Ritter
+-- category:
+build-type:       Simple
+cabal-version:    >= 1.12
+
+library
+  exposed-modules:     Image.Pixels
+  hs-source-dirs:      src
+  ghc-options:         -Wall
+  build-depends:       base >=4.7 && <5
+                     , array
+                     , bytestring
+                     , monadLib
+  default-language:    Haskell2010
+
+executable sample
+  hs-source-dirs: examples
+  main-is: Main.hs
+  build-depends: base, pixels, random
+  default-language: Haskell2010

src/Image/Pixels.hs

@@ -0,0 +1,179 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Image.Pixels where
+
+import           Data.Array (Array)
+import qualified Data.Array as Array
+import qualified Data.ByteString.Builder as BS
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.Ix as Ix
+import           Data.Monoid ((<>))
+import           Data.Word
+import           MonadLib
+
+data Index = Index {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 deriving (Eq, Ord, Show)
+
+instance Ix.Ix Index where
+  range (Index x1 y1, Index x2 y2) =
+    concat [ [ Index x y
+             | x <- [x1..x2] ]
+           | y <- [y1..y2] ]
+  index (Index x1 _, Index x2 _) (Index x y) =
+    let w = (x2 - x1) + 1
+    in fromIntegral (x + w * y)
+  inRange (Index x1 y1, Index x2 y2) (Index x y) =
+    Ix.inRange (x1, x2) x && Ix.inRange (y1, y2) y
+
+data RGB8 =
+  RGB8 {-# UNPACK #-} !Word8
+       {-# UNPACK #-} !Word8
+       {-# UNPACK #-} !Word8
+  deriving (Eq)
+
+data RGB16 =
+  RGB16 {-# UNPACK #-} !Word16
+        {-# UNPACK #-} !Word16
+        {-# UNPACK #-} !Word16
+  deriving (Eq)
+
+data RGBA8 =
+  RGBA8 {-# UNPACK #-} !Word8
+        {-# UNPACK #-} !Word8
+        {-# UNPACK #-} !Word8
+        {-# UNPACK #-} !Word8
+  deriving (Eq)
+
+data RGBA16 =
+  RGBA16 {-# UNPACK #-} !Word16
+         {-# UNPACK #-} !Word16
+         {-# UNPACK #-} !Word16
+         {-# UNPACK #-} !Word16
+  deriving (Eq)
+
+data Gray8 = Gray8 {-# UNPACK #-} !Word8 deriving (Eq)
+data Gray16 = Gray16 {-# UNPACK #-} !Word16 deriving (Eq)
+newtype BW = BW Bool deriving (Eq, Show)
+
+class BWPixel pixel where
+  black :: pixel
+  white :: pixel
+
+class GrayPixel pixel where
+  gray :: Double -> pixel
+
+class RGBPixel pixel where
+  red   :: Double -> pixel
+  green :: Double -> pixel
+  blue  :: Double -> pixel
+  rgb   :: Double -> pixel
+
+instance BWPixel BW where
+  black = BW False
+  white = BW True
+
+data Image pixel = Image
+  { imgWidth  :: Word32
+  , imgHeight :: Word32
+  , imgPixels :: Array Index pixel
+  } deriving Show
+
+instance Functor Image where
+  fmap f img = img { imgPixels = fmap f (imgPixels img) }
+
+image :: pixel -> Word32 -> Word32 -> PixelM pixel () -> Image pixel
+image def w h (PixelM mote) = snd (runId (runStateT img mote))
+  where
+    img = Image
+            { imgWidth  = w
+            , imgHeight = h
+            , imgPixels =
+              let range = (Index 0 0, Index (w - 1) (h - 1))
+              in Array.array range [ (ix, def)
+                                   | ix <- Ix.range range
+                                   ]
+            }
+
+squareImg :: pixel -> Word32 -> PixelM pixel () -> Image pixel
+squareImg def s mote = image def s s mote
+
+getWidth :: PixelM pixel Word32
+getWidth = PixelM (fmap imgWidth get)
+
+getHeight :: PixelM pixel Word32
+getHeight = PixelM (fmap imgHeight get)
+
+horizontal :: PixelM pixel () -> PixelM pixel ()
+horizontal (PixelM mote) = PixelM $ do
+  w <- fmap imgWidth get
+  let flipHoriz = sets_ $ \i ->
+        i { imgPixels =
+               imgPixels i Array.//
+               [ (ix, imgPixels i Array.! Index ((w - 1) - x) y)
+               | ix@(Index x y) <- Ix.range (Array.bounds (imgPixels i))
+               ]
+          }
+  mote
+  flipHoriz
+  mote
+  flipHoriz
+
+vertical :: PixelM pixel () -> PixelM pixel ()
+vertical (PixelM mote) = PixelM $ do
+  h <- fmap imgHeight get
+  let flipVert = sets_ $ \i ->
+        i { imgPixels =
+               imgPixels i Array.//
+               [ (ix, imgPixels i Array.! Index x ((h - 1) - y))
+               | ix@(Index x y) <- Ix.range (Array.bounds (imgPixels i))
+               ]
+          }
+  mote
+  flipVert
+  mote
+  flipVert
+
+newtype PixelM pixel a = PixelM { runPixelM :: StateT (Image pixel) Id a }
+  deriving (Functor, Applicative, Monad)
+
+inImage :: Word32 -> Word32 -> Image pixel -> Bool
+inImage x y Image { imgWidth = w, imgHeight = h } =
+  Ix.inRange (Index 0 0, Index w h) (Index x y)
+
+draw :: pixel -> Word32 -> Word32 -> PixelM pixel ()
+draw p x y = PixelM $ sets_ $ \ img ->
+  img { imgPixels = imgPixels img Array.// [ (Index x y, p) ] }
+
+scaleUp :: Word8 -> Image pixel -> Image pixel
+scaleUp n img =
+  let n' = fromIntegral n
+      range = ( Index 0 0
+              , Index (imgWidth img * n' - 1)
+                      (imgHeight img * n' - 1)
+              )
+  in Image
+       { imgWidth  = imgWidth img * n'
+       , imgHeight = imgHeight img * n'
+       , imgPixels = Array.array range
+                     [ (ix, imgPixels img Array.! Index (x `div` n') (y `div` n'))
+                     | ix@(Index x y) <- Ix.range range
+                     ]
+       }
+
+
+toPBM :: Image BW -> BS.ByteString
+toPBM img = BS.toLazyByteString pbmFile
+  where pbmFile = BS.string7 "P1\n" <>
+                  BS.word32Dec (imgWidth img) <>
+                  BS.char7 ' ' <>
+                  BS.word32Dec (imgHeight img) <>
+                  BS.char7 '\n' <>
+                  mconcat [ go (imgPixels img Array.! ix)
+                          | ix <- Ix.range (Array.bounds (imgPixels img))
+                          ]
+        go (BW True) = BS.char7 '0' <> BS.char7 ' '
+        go (BW False) = BS.char7 '1' <> BS.char7 ' '
+
+savePBM :: FilePath -> Image BW -> IO ()
+savePBM path img = BS.writeFile path (toPBM img)