Data commit

Task/Bitmap/Haskell/bitmap-1.hs

@@ -0,0 +1,77 @@
+module Bitmap(module Bitmap) where
+
+import Control.Monad
+import Control.Monad.ST
+import Data.Array.ST
+
+newtype Pixel = Pixel (Int, Int) deriving Eq
+
+instance Ord Pixel where
+    compare (Pixel (x1, y1)) (Pixel (x2, y2)) =
+        case compare y1 y2 of
+            EQ -> compare x1 x2
+            v  -> v
+
+instance Ix Pixel where
+{- This instance differs from the one for (Int, Int) in that
+the ordering of indices is
+  (0,0), (1,0), (2,0), (0,1), (1,1), (2,1)
+instead of
+  (0,0), (0,1), (1,0), (1,1), (2,0), (2,1). -}
+    range (Pixel (xa, ya), Pixel (xz, yz)) =
+        [Pixel (x, y) | y <- [ya .. yz], x <- [xa .. xz]]
+    index (Pixel (xa, ya), Pixel (xz, _)) (Pixel (xi, yi)) =
+        (yi - ya)*(xz - xa + 1) + (xi - xa)
+    inRange (Pixel (xa, ya), Pixel (xz, yz)) (Pixel (xi, yi)) =
+        not $ xi < xa || xi > xz || yi < ya || yi > yz
+    rangeSize (Pixel (xa, ya), Pixel (xz, yz)) =
+        (xz - xa + 1) * (yz - ya + 1)
+
+instance Show Pixel where
+    show (Pixel p) = show p
+
+class Ord c => Color c where
+    luminance :: c -> Int
+     -- The Int should be in the range [0 .. 255].
+    black, white :: c
+    toNetpbm :: [c] -> String
+    fromNetpbm :: [Int] -> [c]
+    netpbmMagicNumber, netpbmMaxval :: c -> String
+      {- The argument to these two functions is ignored; the
+      parameter is only for typechecking. -}
+
+newtype Color c => Image s c = Image (STArray s Pixel c)
+
+image :: Color c => Int -> Int -> c -> ST s (Image s c)
+{- Creates a new image with the given width and height, filled
+with the given color. -}
+image w h = liftM Image .
+    newArray (Pixel (0, 0), Pixel (w - 1, h - 1))
+
+listImage :: Color c => Int -> Int -> [c] -> ST s (Image s c)
+{- Creates a new image with the given width and height, with
+each pixel set to the corresponding element of the given list. -}
+listImage w h = liftM Image .
+    newListArray (Pixel (0, 0), Pixel (w - 1, h - 1))
+
+dimensions :: Color c => Image s c -> ST s (Int, Int)
+dimensions (Image i) = do
+    (_, Pixel (x, y)) <- getBounds i
+    return (x + 1, y + 1)
+
+getPix :: Color c => Image s c -> Pixel -> ST s c
+getPix (Image i) = readArray i
+
+getPixels :: Color c => Image s c -> ST s [c]
+getPixels (Image i) = getElems i
+
+setPix :: Color c => Image s c -> Pixel -> c -> ST s ()
+setPix (Image i) = writeArray i
+
+fill :: Color c => Image s c -> c -> ST s ()
+fill (Image i) c = getBounds i >>= mapM_ f . range
+  where f p = writeArray i p c
+
+mapImage :: (Color c, Color c') =>
+    (c -> c') -> Image s c -> ST s (Image s c')
+mapImage f (Image i) = liftM Image $ mapArray f i

Task/Bitmap/Haskell/bitmap-2.hs

@@ -0,0 +1,23 @@
+module Bitmap.RGB(module Bitmap.RGB) where
+
+import Bitmap
+import Control.Monad.ST
+
+newtype RGB = RGB (Int, Int, Int) deriving (Eq, Ord)
+
+instance Color RGB where
+    luminance (RGB (r, g, b)) = round x
+      where x = 0.2126*r' + 0.7152*g' + 0.0722*b'
+            (r', g', b') = (toEnum r, toEnum g, toEnum b)
+    black = RGB (0,   0,   0)
+    white = RGB (255, 255, 255)
+    toNetpbm = concatMap f
+      where f (RGB (r, g, b)) = [toEnum r, toEnum g, toEnum b]
+    fromNetpbm [] = []
+    fromNetpbm (r : g : b : rest) = RGB (r, g, b) : fromNetpbm rest
+    netpbmMagicNumber _ = "P6"
+    netpbmMaxval _ = "255"
+
+toRGBImage :: Color c => Image s c -> ST s (Image s RGB)
+toRGBImage = mapImage $ f . luminance
+  where f x = RGB (x, x, x)