78 lines
2.5 KiB
Haskell
78 lines
2.5 KiB
Haskell
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
|