HRay-1.1: HRayGUI.lhs
HRay visual main program, built with Gtk2Hs
intended for usage with the other modules in the HRay package
author: Kenneth Hoste, 2004-2005
part of a masters thesis at the University of Ghent, Belgium
==========================================================================
> import Graphics.UI.Gtk hiding (Graphics.UI.Gtk.Gdk.Enums.Solid,Graphics.UI.Gtk.General.Structs.Color)
> import Data.IORef (newIORef,readIORef,writeIORef)
> import Data.Array (Array, (!), listArray)
> import Maybe (isNothing)
> import PixBufExtras (pixbufSetPixelsRGB8)
> import HRayEngine (Scene(Scene))
> import HRayOutput (getRenderTime, getImage)
> import HRayParser (RenderDescr(RenderDescr), readDescr)
> import Directory (doesFileExist)
> import System.CPUTime (getCPUTime)
--------------------
| Reading a scene |
--------------------
> loadThisScene :: String -> IO (Maybe RenderDescr)
> loadThisScene file = do
> exists <- doesFileExist file
> case exists of
> True -> do
> fileContent <- readFile file
> return (Just (readDescr fileContent))
> False -> return Nothing
-------------------------
| Handling click events |
------------------------
loading a scene
> loadScene :: String -> Label -> Label -> Label -> IO (Maybe RenderDescr)
> loadScene "" messLabel descrLabel renderTimeLabel = do
> labelSetText messLabel "\nNo scene loaded.\n"
> labelSetText descrLabel "\nScene description:\n\n Resolution: <none>\n Objects: <none>\n Lights: <none>\n"
> labelSetText renderTimeLabel "\nRender time:\n\n <none>\n"
> return Nothing
> loadScene file messLabel descrLabel renderTimeLabel = do
> renderDescr <- loadThisScene file
> labelSetText renderTimeLabel "\nRender time:\n\n <none>\n"
> case renderDescr of
> Nothing -> do
> labelSetText messLabel "\nNo such file.\n"
> labelSetText descrLabel "\nScene description:\n\n Resolution: <none>\n Objects: <none>\n Lights: <none>\n"
> (Just (RenderDescr (rx,ry) depth (Scene _ _ objects lights)) ) -> do
> labelSetText messLabel "\nScene loaded.\n"
> labelSetText descrLabel ("\nScene description:\n\n Resolution: "++(show rx)++"x"++
> (show ry)++"\n # Objects: "++(show (length objects))++"\n # Lights: "++
> (show (length lights))++"\n")
> return renderDescr
setting up a pixbuf with a Color array
> pixbufSetPixelsRGB8FromArray :: Int -> Pixbuf -> Array Int (Int,Int,Int) -> IO()
> pixbufSetPixelsRGB8FromArray w pixbuf arr =
> pixbufSetPixelsRGB8 pixbuf (\x y -> (\ (r,g,b) -> (fromIntegral r, fromIntegral g, fromIntegral b)) $ arr!(y*w+x) )
rendering a scene
> renderScene :: (Maybe RenderDescr) -> Label -> IO Pixbuf
> renderScene (Just (RenderDescr res@(rx,ry) depth scene)) descrLabel = do
> let colorList = map (\ (r,g,b) -> (round (r*255),round (g*255),round (b*255))) $ getImage depth res scene
> colorArray = listArray (0,rx*ry-1) colorList
> pixBuf <- pixbufNew ColorspaceRgb False 8 rx ry
> pixbufSetPixelsRGB8FromArray rx pixBuf colorArray
> return pixBuf
---------------------------
| Handling closure events |
---------------------------
returning 'False' results in destroys the window
(and throws a destroy-event)
> deleteEvent :: Event -> IO Bool
> deleteEvent _ = do return False
what should happen when the window is being closed
> destroyEvent :: IO()
> destroyEvent = do mainQuit
--------------------
| : : : MAIN : : : |
--------------------
> main :: IO()
> main = do
initializing GUI
> initGUI
setting up new window
> window <- windowNew
> onDelete window deleteEvent
> onDestroy window destroyEvent
> windowSetTitle window "HRay - a Haskell raytracer"
creating a place to show the rendered image
> scrollWindow <- scrolledWindowNew Nothing Nothing
> containerSetBorderWidth scrollWindow 10
> image <- imageNewFromFile "default.png"
> scrolledWindowAddWithViewport scrollWindow image
> widgetSetSizeRequest scrollWindow 800 600
creating the control panel
> controlPanel <- vBoxNew False 2
> containerSetBorderWidth controlPanel 10
setting up the file entry box
> entry <- entryNew
> entrySetWidthChars entry 20
setting up the load button
> loadButton <- buttonNewWithLabel "Load scene"
setting up the message label
> messageLabel <- labelNew (Just "\nNo scene loaded.\n")
setting up the render button
> renderButton <- buttonNewWithLabel "Render scene"
setting up the scene description label
> descrLabel <- labelNew (Just "\nScene description:\n\n Resolution: <none>\n Objects: <none>\n Lights: <none>\n")
setting up the render time label
> renderTimeLabel <- labelNew (Just "\nRender time:\n\n <none>\n")
preparing scene
> renderDescrRef <- newIORef Nothing
setting click actions
> onClicked loadButton $ do
> fileStr <- (entryGetText entry)
> renderDescr <- loadScene fileStr messageLabel descrLabel renderTimeLabel
> writeIORef renderDescrRef renderDescr
> onClicked renderButton $ do
> renderDescr <- readIORef renderDescrRef
> let loop = do
> n <- eventsPending
> if n == 0 then return () else mainIterationDo False >> loop
> if isNothing renderDescr then
> labelSetMarkupWithMnemonic messageLabel "\n<b>Please load a scene.</b>\n"
> else do
> timeBefore <- getCPUTime
> labelSetMarkupWithMnemonic messageLabel ("\n<span foreground=\"red\">"++
> "<b>Rendering scene...</b></span>\n")
> loop
> pixBuf <- renderScene renderDescr descrLabel
> labelSetText messageLabel "\nScene rendered !\n"
> imageSetFromPixbuf image pixBuf
> timeAfter <- getCPUTime
> labelSetText renderTimeLabel $ "\nRender time:\n\n " ++
> (getRenderTime timeBefore timeAfter) ++ "\n"
adding everything to the control panel
> boxPackStart controlPanel entry PackNatural 0
> boxPackStart controlPanel loadButton PackNatural 0
> boxPackStart controlPanel messageLabel PackNatural 0
> boxPackStart controlPanel renderButton PackNatural 0
> boxPackStart controlPanel descrLabel PackNatural 0
> boxPackStart controlPanel renderTimeLabel PackNatural 0
adding everything to the window
> hBox <- hBoxNew False 2
> boxPackStart hBox scrollWindow PackNatural 0
> boxPackStart hBox controlPanel PackNatural 0
> containerAdd window hBox
packing and showing everything
> widgetShowAll window
wait for events to occure
> mainGUI