-- © 2001 Peter Thiemann
module WASH.CGI.PPM where

import Char

data Pixmap =
     Pixmap	{ width :: Int
     		, height :: Int
		, maximumColorValue :: Int
		, pixelFun :: Int -> Int -> Pixel
		}

type Pixel = (Int, Int, Int)

instance Show Pixmap where
  show pm = if maximumColorValue pm > 255
  	    then showPixmap pm "P3" showAsciiPixel
	    else showPixmap pm "P6" showBinaryPixel
	    
showPixmap pm code showPixel =
  let w = width pm
      h = height pm
  in
  code ++
  '\n' : (show w) ++
  '\n' : (show h) ++
  '\n' : (show $ maximumColorValue pm) ++
  '\n' : [ ch | y <- [1..h], x <- [1..w], ch <- showPixel (pixelAt pm x y)]

showAsciiPixel (r, g, b) =
  show r ++ ' ' : show g ++ ' ' : show b ++ "\n"

showBinaryPixel (r, g, b) =
  [chr r, chr g, chr b]

instance Read Pixmap where
  readsPrec i = readsPixmap

readsPixmap ('P':'3':rest) = readsPixmap1 readsAsciiPixel (dropWhile isSpace rest)
readsPixmap ('P':'6':rest) = readsPixmap1 readsBinaryPixel (dropWhile isSpace rest)
readsPixmap str = []

readsPixmap1 readsPixel str = 
  do (w, rest1) <- reads str
     (h, rest2) <- reads (dropWhile isSpace rest1)
     (m, rest3) <- reads (dropWhile isSpace rest2)
     (pixs, rest4) <- readsPixels w h readsPixel (dropWhile isSpace rest3)
     return (Pixmap { width = w, 
                      height = h, 
		      maximumColorValue = m, 
		      pixelFun = \x y -> (pixs !! y) !! x }
     	    ,dropWhile isSpace rest4)

readsPixels w h readsPixel str =
  if h > 0 
  then do (sl1, rest1) <- readsScanline w readsPixel str
	  (sls, rest2) <- readsPixels w (h-1) readsPixel rest1
	  return (sl1 : sls, rest2)
  else return ([], str)

readsScanline w readsPixel str =
  if w > 0 
  then do (pix1, rest1) <- readsPixel str
	  (pixs, rest2) <- readsScanline (w-1) readsPixel rest1
	  return (pix1 : pixs, rest2)
  else return ([], str)

readsAsciiPixel str =
  do (r, rest1) <- reads (dropWhile isSpace str)
     (g, rest2) <- reads (dropWhile isSpace rest1)
     (b, rest3) <- reads (dropWhile isSpace rest2)
     return ((r,g,b), rest3)

readsBinaryPixel (cr:cg:cb:rest) =
  return ((ord cr, ord cg, ord cb), rest)
readsBinaryPixel _ =
  []
  
  


-- ======================================================================

create :: Int -> Int -> Int -> Pixel -> Pixmap
create w h m p = 
  Pixmap w h m (const (const p))

oval :: Pixmap -> (Int, Int) -> (Int, Int) -> Pixel -> Bool -> Pixmap
line :: Pixmap -> (Int, Int) -> (Int, Int) -> Pixel -> Pixmap
rectangle :: Pixmap -> (Int, Int) -> (Int, Int) -> Pixel -> Bool -> Pixmap
-- arc
-- poly
-- text
-- bitmap
-- image 

oval pm (xul,yul) (xlr,ylr) p fill =
  pm { pixelFun = fun }
  where w2 = (xlr - xul) `div` 2
	h2 = (ylr - yul) `div` 2
	xm = xul + w2
	ym = yul + h2
	lastfun = pixelFun pm
	fun x y | y < yul || y > ylr || x < xul || x > xlr = lastfun x y
	        | d <= 1.0 && (fill || d >= 0.9) = p
	        | otherwise = lastfun x y
	  where d = fromIntegral ((x - xm) ^ 2) / fromIntegral (w2 ^ 2) +
		    fromIntegral ((y - ym) ^ 2) / fromIntegral (h2 ^ 2)

rectangle pm (xul,yul) (xlr,ylr) p fill =
  pm { pixelFun = fun }
  where lastfun = pixelFun pm
	fun x y | y < yul || y > ylr || x < xul || x > xlr = lastfun x y
	        | x == xul || x == xlr || y == yul || y == ylr || fill = p
		| otherwise = lastfun x y
-- 
line = line2

line1 pm (xul,yul) (xlr,ylr) p =
  pm { pixelFun = fun }
  where lastfun = pixelFun pm
	fun x y | x < xul && x < xlr || x > xul && x > xlr || y < yul && y < ylr || y > yul && y > ylr = lastfun x y
	        | (x,y) `elem` points = p
	        | otherwise = lastfun x y
	-- suppose abs dx >= abs dy
	dx = xlr - xul
	dy = ylr - yul
	adx = abs dx
	ady = abs dy
	sdx = signum dx
	sdy = signum dy
	points | adx >= ady = k adx ady sdx sdy xlr ylr (adx `div` 2) (xul,yul)
	       | otherwise  = 
       		 [(x,y) | (y,x) <- k ady adx sdy sdx ylr xlr (ady `div` 2) (yul,xul)]
	k adx ady sdx sdy xlr ylr = m
	  where m v (x, y) | x == xlr && y == ylr = [(x,y)]
		           | otherwise = (x, y) : m nv' (nx, ny)
		  where
			nv = v - ady
			nv' | nv > 0 = nv
			    | otherwise = nv + adx
			nx  = x + sdx
			ny  | nv > 0 = y
			    | otherwise = y + sdy

line2 pm (xul,yul) (xlr,ylr) p =
  pm { pixelFun = fun }
  where lastfun = pixelFun pm
	dx = fromIntegral (xlr - xul)
	dy = fromIntegral (ylr - yul)
	xul' = fromIntegral xul
	yul' = fromIntegral yul
-- solve: dx1 * dx + dy1 * dy = 0
	dx1 = - dy
	dy1 = dx
	divisor = dy1 * dx - dy
		
	fun x y | x < xul && x < xlr ||
	          x > xul && x > xlr || 
		  y < yul && y < ylr ||
		  y > yul && y > ylr = lastfun x y
		| dx == 0 && x == xul ||
		  dy == 0 && y == yul = p
		| d <= lineWidth = p
		| otherwise = lastfun x y
	  where x' = fromIntegral x
		y' = fromIntegral y
-- solve: x0 = x + t * dx1 
--     && y0 = y + t * dy1
--     && x0 = xul + s * dx 
--     && y0 = yul + s * dy
-- for x0, y0, s, t
		s = ((x' - xul') * dy1 + yul' - y') / divisor
		x0 = xul' + s * dx
		y0 = yul' + s * dy
		d = (x0 - x')^2 + (y0 - y')^2
		lineWidth = 1.0

point pm (x0,y0) p =
  pm { pixelFun = fun }
  where lastfun = pixelFun pm
	fun x y | x == x0 && y == y0 = p
	        | otherwise = lastfun x y

comp pm1 pm2 (xul,yul) p =
  pm1 { pixelFun = fun }
  where 
    w2 = width pm2
    h2 = height pm2
    lastfun = pixelFun pm1
    fun x y | x2 >= 0 && y2 >= 0 && x2 < w2 && y2 < h2 && p2 /= p = p2
            | otherwise = lastfun x y
      where x2 = x - xul
	    y2 = y - yul
	    p2 = pixelFun pm2 x2 y2

-- for efficiency and versatility rely on external programs:

-- ppmmake : create a canvas
-- pbmtext : create a text image (pbmtopgm; pgmtoppm)
-- pnmcomp : compose two images
-- giftopnm : image to portable anymap

-- missing: ppmline ppmoval

pixelAt :: Pixmap -> Int -> Int -> Pixel
pixelAt =
  pixelFun

-- ======================================================================
-- a picture data type
-- ======================================================================
type Color = (Int, Int, Int)
data Picture = 
    Circle Bool		-- radius 1 around origin (filled?)
  | Square Bool		-- unit square, origin= lower left (filled?)
  | Line	-- from origin to (1,0)
  | Colored Color Picture
  | Translate (Double, Double) Picture
  | Rotate Double Picture	-- around origin
  | Scale (Double, Double) Picture
  | Invert Picture
  | And [Picture]
  | Or [Picture]

maxcv (Circle _) = 0
maxcv (Square _) = 0
maxcv (Line) = 0
maxcv (Colored (r,g,b) pic) = maximum [r,g,b,maxcv pic]
maxcv (Translate _ pic) = maxcv pic
maxcv (Rotate _ pic) = maxcv pic
maxcv (Scale _ pic) = maxcv pic
maxcv (Invert pic) = maxcv pic
maxcv (And pics) = maximum (0 : map maxcv pics)
maxcv (Or pics) = maximum (0 : map maxcv pics)

render :: Picture -> Int -> Int -> Color -> Pixmap
render pic w h bg =
  Pixmap { width = w, height = h, maximumColorValue = maxcv pic, pixelFun = pixelAt }
  where pixelAt x y =
	  case renderPix pic bg (fromIntegral x) (fromIntegral y) (sqrt 2) of
	    Nothing -> (0,0,0)
	    Just cl -> cl

renderPix pic bg fx fy fr =
  case pic of
    Circle filled ->		-- radius 1 around origin (filled?)
      let ra = fx * fx + fy * fy in
      if filled then
        if ra <= 1 + fr then Just bg else Nothing
      else
        if abs (ra - 1) <= fr then Just bg else Nothing
    Square filled ->		-- unit square, origin= lower left (filled?)
      if filled then
        if fx + fr >= 0 && fx - fr <= 1 && fy + fr >= 0 && fy - fr <= 1 
	then Just bg else Nothing
      else
        if abs fx <= fr && fy + fr >= 0 && fy - fr <= 1 
	|| abs fy <= fr && fx + fr >= 0 && fx - fr <= 1 
        || abs (fx - 1) <= fr && fy + fr >= 0 && fy - fr <= 1 
	|| abs (fy - 1) <= fr && fx + fr >= 0 && fx - fr <= 1 
	then Just bg else Nothing
    Line ->	-- from origin
      if abs fx <= fr && fy + fr >= 0 && fy - fr <= 1 
      then Just bg else Nothing      
    Colored clr pic ->
      renderPix pic bg fx fy fr >> Just clr
    Translate (dx, dy) pic ->
      renderPix pic bg (fx - dx) (fy - dy) fr
    Rotate phi pic ->	-- around origin
      renderPix pic bg (fx * cos (- phi) - fy * sin (- phi)) 
                       (fx * sin (- phi) + fy * cos (- phi)) fr
    Scale (sx, sy) pic ->
      renderPix pic bg (fx / sx) (fy / sy) (max (abs (fr / sx)) (abs (fr / sy)))
    Invert pic ->
      case renderPix pic bg fx fy fr of
        Just _ -> Nothing
	Nothing -> Just bg
    And pics ->
      foldl (\ j pic -> j >> renderPix pic bg fx fy fr) (Just bg) pics
    Or pics ->
      foldl (\ j pic -> case j of 
			  Nothing -> renderPix pic bg fx fy fr
			  Just clr -> Just clr
	    ) Nothing pics