{-
    Copyright (C) 2004 Remi Turk <rturk@science.uva.nl>
-}
module PPM (
    Color,
    Image,
    readPPM,
    showPPM,
    withColor,
    fromColor,
    toColor
) where

import Char
import Text.ParserCombinators.Parsec
import Data.Bits

import Matrix

--type Color      = (Int, Int, Int)
type Color      = Int
type Image      = Matrix Color

withColor       :: ((Int, Int, Int) -> (Int, Int, Int)) -> Color -> Color
withColor f     = toColor . f . fromColor

toColor         :: (Int, Int, Int) -> Color
fromColor       :: Color -> (Int, Int, Int)
{-
toColor         = id
fromColor       = id
-}
toColor (r,g,b) = (r `shiftL` 16) .|. (g `shiftL` 8) .|. b
fromColor col   = (col `shiftR` 16, (col `shiftR` 8) .&. 0xFF, col .&. 0xFF)

skip parser = parser >> return ()

magicNo     = string "P6" >> return () <?> "magicNo"
comment     = char '#' >> skipMany (noneOf "\n") >> skip newline <?> "comment"
whitespace  = skipMany1 (satisfy isSpace) <?> "whitespace"
number      = many1 (satisfy isDigit) <?> "number"

separator   = many1 (whitespace <|> comment)

readPPM             :: String -> (Int, Image)
readPPM s           = case parse parser "readImage" s of
                        Left err    -> error (show err)
                        Right image -> image
    where
        parser      :: GenParser Char st (Int, Image)
        parser      = do
                        magicNo;
                        separator
                        width <- read `fmap` number;    separator
                        height <- read `fmap` number;   separator
                        maxColor <- read `fmap` number; newline
                        pixels <- many pixel
                        let
                            bounds = ((1, 1), (width, height))
                            locs  = [(x,y) | y <- [1..height], x <- [1..width]]
                        return (maxColor, array bounds (zip locs pixels))
        pixel       = do
                        r <- anyChar
                        g <- anyChar
                        b <- anyChar
                        return $ toColor (ord r, ord g, ord b)

showPPM             :: Int -> Image -> String
showPPM maxColor image
                    = showString
                        (unlines ["P6", show w, show h, show maxColor])
                        $ map chr $ concatMap (f . fromColor)
                        $ map (image!) locs
    where
        f (r,g,b)   = [r,g,b]
        (_,(w,h))   = bounds image
        locs        = [(x,y) | y <- [1..h], x <- [1..w]]