-- -----------------------------------------------
--
-- portable bit/grey/pixel map parsing
-- and conversion to/from a Picture

module PPM(readPicture,
	   readPNM,
	   pictureToPGM,
	   pictureToPBM,
	   showPNM,
	   showPNMbin,
	   showPicture,
	   PNM,
	  ) where

import Char(ord,chr)
import Types

type Pixel	= (Int, Int, Int)

type PBM	= (Int, Int,      Matrix Int)
type PGM	= (Int, Int, Int, Matrix Int)
type PPM	= (Int, Int, Int, Matrix Pixel)

data PNM	= Pbm PBM
		| Pgm PGM
		| Ppm PPM

-- -----------------------------------------------
--

mapMatrix	:: (a -> b) -> (Matrix a -> Matrix b)
mapMatrix f	= map (map f)

readPicture :: String -> Picture
readPicture = readPNM . item

-- -----------------------------------------------
--

readPNM	:: (String, String) -> Picture

readPNM ("P1", str)
    = mapMatrix normalize pixels
      where
      (ns, rest)	= readRow 2 str
      [width, height]	= map read ns
      (pixels, _)	= readPixels width height rest
      normalize x	= 1.0 - (read x)::Float

readPNM ("P2", str)
    = mapMatrix normalize pixels
      where
      ([w, h, m], rest)	= readRow 3 str
      width		= (read w)::Int
      height		= (read h)::Int
      max		= (read m)::Float
      normalize x	= ((read x)::Float) / max
      (pixels, _)	= readPixels width height rest

readPNM ("P5", str)
    = mapMatrix normalize pixels
      where
      ([w, h, m], rest)	= readRow 3 str
      width		= (read w)::Int
      height		= (read h)::Int
      max		= (read m)::Float
      normalize x	= (((fromInteger
			     . toInteger
			     . ord) x)::Float) / max
      pixels		= readChars width height
			  (tail rest)

readPNM (_,_)
    = [[0.0]]

--

item	:: String -> (String, String)
item str
    = i1
      where
      i@(w,r) = head (lex str)
      i1 | head w == '#'
	     = item r1
	 | otherwise
	     = i
	 where
	 r1 = ( drop 1 . snd . break (== '\n') . drop 1) r

readFct	:: (String -> (a, String)) ->
	   Int ->
	   String -> ([a], String)

readFct f 0 str
    = ([],str)

readFct f n str
    = (i:r, str2)
      where
      (i, str1)	= f str
      (r, str2)	= readFct f (n-1) str1

readRow	 		= readFct item
readPixels width	= readFct (readRow width)

-- convert a binary pgm to a matrix

readChars :: Int -> Int -> String -> Matrix Char
readChars _ 0 _
    = []

readChars w h s
    = (take w s) : (readChars w (h-1) (drop w s))

-- -----------------------------------------------
--
-- Picture to portable grey map
-- and portable bitmap (ascii)
-- conversions

pictureToPGM	:: Picture -> PNM
pictureToPGM pic
    = Pgm (w, h,
	   255,
	   mapMatrix (\x -> round (x * 255.0)) pic
	  )
      where
      w = length (head pic)
      h = length pic

pictureToPBM	:: Picture -> PNM
pictureToPBM	= toPBM . pictureToPGM

-- -----------------------------------------------
--
-- portable ??? map conversion functions

-- convert to PGM format
-- 1. PGM: identity
-- 2. PBM to PGM
-- nothing else (not yet)

toPGM p@(Pgm _)
    = p

toPGM (Pbm (w, h, pxs))
    = Pgm (w, h, 1, mapMatrix (\x -> 1 - x) pxs)

-- -----------------------------------------------
--
-- convert to PBM format
-- 1. PBM: identity
-- 2. PGM to PBM
-- else first convert to PGM

toPBM p@(Pbm _)
    = p

toPBM (Pgm (w, h, max, pxs))
    = Pbm (w, h, mapMatrix mapTo01 pxs)
      where
      mapTo01 x
	  | x > max `div` 2	= 0
	  | otherwise		= 1

toPBM p
    = toPBM (toPGM p)

-- -----------------------------------------------

--
-- output functions for .pbm and .pgm

showPNM	:: PNM -> String

-- portable bit map format (ascii)

showPNM (Pbm (width, height, pixels))
    =
      "P1\n"
      ++ show width ++ " " ++ show height ++ "\n"
      ++ version
      ++ concatMap (concatMap ((++ "\n")
			       . show)) pixels

-- portable grey map format (ascii)

showPNM (Pgm (width, height, max, pixels))
    =
      "P2\n"
      ++ show width ++ " " ++ show height ++ "\n"
      ++ version
      ++ show max ++ "\n"
      ++ concatMap (concatMap ((++ "\n")
			       . show)) pixels

-- portable grey map format (binary)

showPNMbin (Pgm (width, height, max, pixels))
    =
      "P5\n"
      ++ show width ++ " "
      ++ show height ++ "\n"
      ++ version
      ++ show max ++ "\n"
      ++ concatMap (map chr) pixels

-- private "portable float map" (ascii) for debugging

showPicture	:: Picture -> String
showPicture p
    =
      "Pf\n"
      ++ show (length (head p))
      ++ " " ++ show (length p) ++ "\n"
      ++ version
      ++ "# internal floating point format\n"
      ++ concatMap (concatMap ((++ "\n") . show)) p

version	= "# Haskell PPM Tools\n"

-- -----------------------------------------------