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 (h1) 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 (w1) 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
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
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
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
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
pixelAt :: Pixmap -> Int -> Int -> Pixel
pixelAt =
pixelFun
type Color = (Int, Int, Int)
data Picture =
Circle Bool
| Square Bool
| Line
| Colored Color Picture
| Translate (Double, Double) Picture
| Rotate Double Picture
| 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 ->
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 ->
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 ->
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 ->
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