module WASH.CGI.CGIGraphics
(activeImage
,newImage
,drawOval, fillOval
,drawRectangle, fillRectangle
,drawLine, drawPoint
,makeText
,gifImage, xwdImage, xpmImage, bmpImage
,activateImage, activateXY, activateColor
,overlay
,storeDirectory
,Pixel, CGIImage, ActionFun)
where
import Maybe
import Monad
import System
import WASH.Utility.Hex
import qualified WASH.CGI.RawCGIInternal as RawCGI
import WASH.CGI.CGITypes as CGITypes
import WASH.CGI.BaseCombinators (unsafe_io)
import WASH.CGI.CGIMonad hiding (lift)
import WASH.CGI.PPM
import WASH.HTML.HTMLMonad hiding (head, div, span, map)
import WASH.Utility.Unique
import WASH.CGI.CGIConfig
storeDirectory = imageDir
ppmtogif = pbmPath ++ "ppmtogif "
pbmtext = pbmPath ++ "pbmtext "
pnmcrop = pbmPath ++ "pnmcrop "
pbmtopgm = pbmPath ++ "pbmtopgm 1 1 "
pgmtoppm = pbmPath ++ "pgmtoppm "
type CGIImage = IO CGIImage'
type ActionFun = Int -> Int -> Maybe (CGI ())
data CGIImage' =
CGIImage'{ pixmap :: Pixmap
, actionFun :: ActionFun
}
activeImage :: CGIImage -> WithHTML x CGI ()
activeImage img =
do fieldName <- liftM show $ lift nextName
(url, actFun) <- lift (flushImage img)
input (attr "type" "image" ##
attr "name" fieldName ##
attr "src" (unURL url))
info <- lift getInfo
let maybeSetAction =
do bds <- bindings info
x <- RawCGI.assocParm (fieldName ++ ".x") bds
y <- RawCGI.assocParm (fieldName ++ ".y") bds
act <- actFun (read x) (read y)
return (lift $ setAction (const act))
fromMaybe (return ()) maybeSetAction
flushImage :: CGIImage -> CGI (CGITypes.URL, ActionFun)
flushImage img =
do cgi_image <- unsafe_io img
pageInfo <- getInfo
baseUrl <- getUrl
case bindings pageInfo of
Nothing ->
unsafe_io $ do
key <- inventStdKey
let path = storeDirectory ++ key
ppmPath = path ++ ".ppm"
gifPath = path ++ ".gif"
writeFile ppmPath (show $ pixmap cgi_image)
system (ppmtogif ++ ppmPath ++ " > " ++ gifPath)
return (URL (baseUrl ++ '?' : key ++ ".gif"), actionFun cgi_image)
Just _ ->
return (URL "", actionFun cgi_image)
newImage :: (Int, Int) -> Pixel -> CGIImage
newImage (w, h) bg =
return $ CGIImage'
{ pixmap = create w h 8 bg
, actionFun = const (const Nothing)
}
makeOval :: Bool -> CGIImage -> (Int, Int) -> (Int, Int) -> Pixel -> CGIImage
drawOval :: CGIImage -> (Int, Int) -> (Int, Int) -> Pixel -> CGIImage
fillOval :: CGIImage -> (Int, Int) -> (Int, Int) -> Pixel -> CGIImage
drawOval = makeOval False
fillOval = makeOval True
makeOval fill img ul lr p =
do cgi_image <- img
return $ cgi_image { pixmap = oval (pixmap cgi_image) ul lr p fill }
makeRectangle :: Bool -> CGIImage -> (Int, Int) -> (Int, Int) -> Pixel -> CGIImage
drawRectangle :: CGIImage -> (Int, Int) -> (Int, Int) -> Pixel -> CGIImage
fillRectangle :: CGIImage -> (Int, Int) -> (Int, Int) -> Pixel -> CGIImage
drawRectangle = makeRectangle False
fillRectangle = makeRectangle True
makeRectangle fill img ul lr p =
do cgi_image <- img
return $ cgi_image { pixmap = rectangle (pixmap cgi_image) ul lr p fill }
drawLine :: CGIImage -> (Int, Int) -> (Int, Int) -> Pixel -> CGIImage
drawLine img ul lr p =
do cgi_image <- img
return $ cgi_image { pixmap = line (pixmap cgi_image) ul lr p }
drawPoint :: CGIImage -> (Int, Int) -> Pixel -> CGIImage
drawPoint img xy p =
do cgi_image <- img
return $ cgi_image { pixmap = point (pixmap cgi_image) xy p }
makeText :: String -> Pixel -> CGIImage
makeText str fg =
do key <- inventStdKey
let path = storeDirectory ++ key
ppmPath = path ++ ".ppm"
gifPath = path ++ ".gif"
system (pbmtext ++ "'" ++ str ++ "' | "
++ pnmcrop ++ "| "
++ pbmtopgm ++ "| "
++ pgmtoppm ++ rgb fg ++ "-black > " ++ ppmPath)
pixmapStr <- readFile ppmPath
return $ CGIImage'
{ pixmap = read pixmapStr
, actionFun = const (const Nothing)
}
rgb (r, g, b) =
"rgb:" ++ showHex2 r ++ '/' : showHex2 g ++ '/' : showHex2 b
gifImage, xwdImage, xpmImage, bmpImage :: String -> CGIImage
gifImage gifPath =
anyImage "gif" gifPath
xwdImage xwdPath =
anyImage "xwd" xwdPath
xpmImage xpmPath =
anyImage "xpm" xpmPath
bmpImage bmpPath =
anyImage "bmp" bmpPath
anyImage :: String -> String -> CGIImage
anyImage format anyPath =
do key <- inventStdKey
let path = storeDirectory ++ key
ppmPath = path ++ ".ppm"
system (pbmPath ++ format ++ "toppm " ++ anyPath ++ " > " ++ ppmPath)
pixmapStr <- readFile ppmPath
return $ CGIImage'
{ pixmap = read pixmapStr
, actionFun = const (const Nothing)
}
activateImage :: CGIImage -> CGI () -> CGIImage
activateImage img act =
activateXY img (const (const (Just act)))
activateXY :: CGIImage -> ActionFun -> CGIImage
activateXY img actFun =
do cgi_image <- img
return $ cgi_image { actionFun = actFun }
activateColor :: CGIImage -> Pixel -> CGI () -> CGIImage
activateColor img p act =
do cgi_image <- img
let fun x y = if pixelAt (pixmap cgi_image) x y == p
then Just act
else actionFun cgi_image x y
return $ cgi_image { actionFun = fun }
overlay :: CGIImage -> CGIImage -> (Int, Int) -> Pixel -> CGIImage
overlay img1 img2 (xul, yul) p =
do cgi1 <- img1
cgi2 <- img2
return $
cgi1 { pixmap = comp (pixmap cgi1) (pixmap cgi2) (xul, yul) p
, actionFun = fun cgi1 cgi2
}
where fun cgi1 cgi2 x1 y1 =
let x2 = x1 xul
y2 = y1 yul
w2 = width $ pixmap cgi2
h2 = height $ pixmap cgi2
maybeAction2 = actionFun cgi2 x2 y2
maybeAction1 = actionFun cgi1 x1 y1
in if x2 >= 0 && y2 >= 0 && x2 < w2 && y2 < w2 && isJust maybeAction2
then maybeAction2
else maybeAction1