-- -- | -- Module : Panic -- Author : Sean Seefried (http://www.cse.unsw.edu.au/~sseefried) -- Copyright : (c) 2005 -- License : BSD3 -- Created : 31 March 2005 -- module Main where -- Standard Library imports import Data.IORef import Data.Char import Monad import GHC.Float import System.IO import System.Time import System.Random import System.Cmd import System.Exit import System.Directory import Foreign import Graphics.Rendering.OpenGL hiding (set,get) import qualified Graphics.Rendering.OpenGL as OpenGL -- -- Package imports -- -- wxhaskell import Graphics.UI.WX hiding ( Size, marginWidth ) import Graphics.UI.WXCore hiding ( Size, marginWidth) import qualified Graphics.UI.WX as WX -- hs-plugins import System.Plugins import qualified System.Plugins as Plugins -- Pan! import Pan -- local imports import Consts import PanicConfAPI import GlobalData import UIUtils import Utils import WXExts import Paint -- -- The single constant of this program. The rest are dynamically loaded -- from PanicConf.hs at run-time. -- panicConfFile = appDir ++ "/PanicConf.hs" -- -- I've always wanted to call a function this. -- "Help! The main frame is self aware and taking over the world!" -- mainFrame :: IO () mainFrame = do f <- frame [ text := "Panic" , resizeable := False , visible := False ] panicConf <- loadPanicConf f -- -- create file menu -- file <- menuPane [text := "&File"] openEffect <- menuItem file [ text := "&Open Effect\tCtrl-O" ] saveImage <- menuItem file [ text := "&Save Image\tCtrl-S" , enabled := False] -- -- Set up top-level data -- tldRef <- newIORef (TopLevelData { tldPanicConf = panicConf , tldOpenMenuItem = openEffect , tldSaveMenuItem = saveImage , tldTopLevelFrame = f , tldCurrentDirectory = "." , tldCurrentFile = Nothing }) -- -- Provide functionality for "open effect" menu item -- set openEffect [ on command := do res <- selectAndDisplayEffect tldRef f case res of Left displayIO -> do displayIO if macOSX then set f [ visible := False ] else return () Right errStr -> infoDialog f "Info" errStr ] quit <- menuQuit file [help := "Quit Panic", on command := close f] -- create Help menu hlp <- menuHelp [] about <- menuAbout hlp [help := "About Panic"] let aboutDialog = infoDialog f "About Panic" "Copyright (c) Sean Seefried 2005" -- Extra menu items for mac OS X apps if macOSX then do quit' <- menuItem file [ text := "&Quit Panic\tCtrl-Q" , on command := close f] about' <- menuItem hlp [ text := "About Panic" , on command := aboutDialog ] return () else return () noEffectText <- staticText f [ text := "Open an effect from the file menu" ] set f [ menubar := [file,hlp] , layout := margin (marginWidth panicConf) $ fill $ widget noEffectText , on (menu about) := aboutDialog , WX.position := defaultMainPos panicConf , on closing := exitWith ExitSuccess , visible := True ] focusOn f -- -- Loads the panic conf file and exits if there is an error. -- Returns a PanicConf data structure -- loadPanicConf :: Frame () -> IO PanicConf loadPanicConf f = do tmpDir <- getTemporaryDirectory _ <- loadModule (appDir ++ "/PanicConfAPI.o") makeStatus <- make panicConfFile [ "-fglasgow-exts" , "-package Pan" , "-package wx" , "-package wxcore" , "-i" ++ appDir , "-odir", tmpDir] case makeStatus of MakeSuccess _ obj -> do loadStatus <- load_ obj [tmpDir] "resource" case loadStatus of LoadSuccess _ panicConf -> do return panicConf LoadFailure errs -> do infoDialog f "Error" (loadFailureStr ++ (unlines $ take maxLines errs)) exitWith (ExitFailure 1) MakeFailure errs -> do infoDialog f "Error" (notFoundStr ++ (unlines $ take maxLines errs)) exitWith (ExitFailure 1) where loadFailureStr = "`resource' could not be loaded from `" ++ panicConfFile ++ "'\n" notFoundStr = panicConfFile ++ " could not be compiled\n" maxLines = 30 -- | Takes an animation and creates a new window, along with user -- interface elements, that displays the effect. -- The result of this function should be passed to wxHaskell's -- @windowCreate@. displayEffect :: IORef TopLevelData -> UI DisplayFun -> [Plugins.Module] -> IO () displayEffect tldRef uiDisplayFun modules = do tld <- readIORef tldRef let pc = tldPanicConf tld -- Create frame f <- frame [ text := "Effect" , visible := False ] -- FIXME: Minimum size is (defaultWidth, defaultHeight) glCanvas <- glCanvasCreateEx f 0 (Rect 0 0 (defaultWidth pc) (defaultHeight pc)) 0 "GLCanvas" [GL_RGBA] nullPalette -- create statusBar frameHeaderText <- staticText f [ text := "Frames/s:"] frameText <- staticText f [ text := "" ] sizeText <- staticText f [ text := show (defaultWidth pc, defaultHeight pc) ] -- -- The vwdRef does not contain a complete ViewerData at this point -- The vwdUIRefs field still needs to be filled in -- vwdRef <- mkVwd pc f glCanvas frameText sizeText modules uiDisplayFun -- create user interface items let elems = getUIElems uiDisplayFun refsAndLayouts <- mapM (addUIElem tldRef vwdRef f) elems let (refs, layouts) = unzip refsAndLayouts -- -- Set the vwdUIRefs field -- modifyIORef vwdRef (\vwd -> vwd { vwdUIRefs = refs}) -- -- set resize handler for glCanvas -- putStrLn "Attempting to display effect..." set glCanvas [ on resize := propagateEvent , on click := clickHandler vwdRef , on unclick := unclickHandler vwdRef , on drag := dragHandler vwdRef , on keyboard := effectKeyboardHandler tldRef vwdRef , fullRepaintOnResize := False ] -- -- Reload button -- reloadButton <- button f [ text := "Reload" , on command := do tld <- readIORef tldRef let mbCurrentFile = tldCurrentFile tld tlFrame = tldTopLevelFrame tld case mbCurrentFile of Just currentFile -> do res <- loadAndDisplayEffect tldRef tlFrame currentFile case res of Left displayIO -> do close f -- close the window displayIO -- open the new one Right errString -> infoDialog f "Info" errString Nothing -> error "No current file. (Should not happen.)" ] let statusLayout = hfill $ row 5 [ widget frameHeaderText , widget frameText , glue , widget sizeText ] reloadLayout = hfill $ row 5 [ glue, widget reloadButton ] glCanvasLayout = fill $ widget glCanvas newLayout = margin (marginWidth pc) $ column 5 (glCanvasLayout : layouts ++ [reloadLayout, statusLayout]) -- -- Set handler for save image menu item -- set (tldSaveMenuItem tld) [ enabled := True , on command := do widthHeightDialog tldRef vwdRef ] -- -- Set the frame properties -- set f [ layout := newLayout , on idle := do { paintEffect tldRef vwdRef ; return True } , on paint := \dc rect -> paintEffect tldRef vwdRef , WX.position := defaultEffectPos pc , on closing := closeEffect tldRef vwdRef -- -- This hack makes the effect window resize properly. -- Note the explicit call to resizeGLCanvas. See its comment -- for more details. -- , on resize := do set glCanvas [ clientSize := sz 0 0 ] windowLayout f WX.Size w h <- get glCanvas clientSize resizeGLCanvas glCanvas vwdRef set sizeText [ text := show (w,h) ] return () , visible := True ] closeEffect :: IORef TopLevelData -> IORef ViewerData -> IO () closeEffect tldRef vwdRef = do tld <- readIORef tldRef vwd <- readIORef vwdRef mapM_ unload (vwdModules vwd) -- -- Re-enable openMenuItem -- let openMenuItem = tldOpenMenuItem tld saveMenuItem = tldSaveMenuItem tld set openMenuItem [ enabled := True ] set saveMenuItem [ enabled := False ] writeIORef tldRef (tld { tldCurrentFile = Nothing }) -- return focus to parent windows propagateEvent -- -- Keyboard handler for the effect. Requires focus on the effect. -- effectKeyboardHandler :: IORef TopLevelData -> IORef ViewerData -> EventKey -> IO () effectKeyboardHandler tldRef vwdRef eventKey = do tld <- readIORef tldRef let panicConf = tldPanicConf tld let zStep = zoomStep panicConf vwd <- readIORef vwdRef case eventKey of EventKey (KeyChar '-') _ _ -> zoomOut zStep vwd EventKey (KeyChar '+') _ _ -> zoomIn zStep vwd EventKey (KeyChar '=') _ _ -> zoomIn zStep vwd _ -> return () where zoomIn zStep vwd = let (panX, panY, zoom) = vwdVTrans vwd in writeIORef vwdRef (vwd { vwdVTrans = (panX, panY, zoom*(1-zStep)) , vwdChanged = True }) zoomOut zStep vwd = let (panX, panY, zoom) = vwdVTrans vwd in writeIORef vwdRef (vwd { vwdVTrans = (panX, panY, zoom*(1+zStep)) , vwdChanged = True }) -- -- Resizes the GL canvas. This cannot be set as the resize handler on -- wxGTK 2.4.2 for some reason. It just keeps receiving the resize event -- even though no resizing has occured. -- -- Thus, you will see that I call it explicitly from the main frame -- resize handler. -- resizeGLCanvas :: Window a -> IORef ViewerData -> IO () resizeGLCanvas glCanvas vwdRef = do vwd <- readIORef vwdRef -- get new window size (WX.Size w h) <- get glCanvas clientSize -- reallocate memory free (vwdPixels vwd) -- free the old pixels -- FIXME: no idea why I have to pass h + 1 here. Programming by coincidence -- Doesn't work with just h. pixels' <- mallocBytes (w*(h+1)*bytesPerColour) writeIORef vwdRef (vwd { vwdPixels = pixels' , vwdVSize = (w,h) , vwdChanged = True }) viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h)) propagateEvent -- on wxMac the glCanvas won't display w/o this. -- -- | clickHandler. Handles left click events -- clickHandler :: IORef ViewerData -> WX.Point -> IO () clickHandler vwdRef point = do vwd <- readIORef vwdRef writeIORef vwdRef (vwd { vwdMouseClickPoint = point , vwdMouseClicked = True}) unclickHandler :: IORef ViewerData -> WX.Point -> IO () unclickHandler vwdRef _ = do vwd <- readIORef vwdRef writeIORef vwdRef (vwd { vwdMouseClicked = False }) dragHandler :: IORef ViewerData -> WX.Point -> IO () dragHandler vwdRef pt@(WX.Point x2 y2) = do vwd <- readIORef vwdRef if vwdMouseClicked vwd then do let (WX.Point x1 y1) = vwdMouseClickPoint vwd (panX, panY, zoom) = vwdVTrans vwd xDelta = zoom * fromIntegral (x1 - x2) yDelta = zoom * fromIntegral (y2 - y1) writeIORef vwdRef (vwd { vwdVTrans = (panX + xDelta, panY + yDelta, zoom) , vwdMouseClickPoint = pt , vwdChanged = True }) else return () -- -- | selectFile -- selectFile :: Frame () -> IO (Maybe FilePath) selectFile f = do fileOpenDialog f True True "Select Pan effect file" [("Haskell", ["*.hs", "*.lhs"])] "" "" -- -- | Loads and displays the effect -- selectAndDisplayEffect :: IORef TopLevelData -> Frame () -> IO (Either (IO ()) String) selectAndDisplayEffect tldRef f = do mFileName <- selectFile f case mFileName of Just fileName -> loadAndDisplayEffect tldRef f fileName _ -> return (Left (return ())) -- Just do nothing. -- -- Returns either a computation that displays the effect or a string -- representing the errors during compilation -- loadAndDisplayEffect :: IORef TopLevelData -> Frame () -> FilePath -> IO (Either (IO ()) String) loadAndDisplayEffect tldRef f fileName = do tmpDir <- getTemporaryDirectory tld <- readIORef tldRef let pc = tldPanicConf tld maxLines' = maxLines pc -- build the file with make (from hs-plugins) let extraFlags = ["-fglasgow-exts" , "-package Pan" , "-odir", tmpDir , "-no-recomp"] ++ (extraGhcFlags pc) makeStatus <- make fileName extraFlags -- -- Change the current directory -- writeIORef tldRef (tld { tldCurrentDirectory = dirname fileName}) case makeStatus of MakeSuccess _ mainObj -> return $ Left $ do loadStatus <- load_ mainObj [tmpDir] (effectFunctionName pc) case loadStatus of LoadSuccess mod effect -> do -- -- Disable the open menu item -- set (tldOpenMenuItem tld) [ enabled := False ] -- -- Set the current file. Used by reload button -- writeIORef tldRef (tld {tldCurrentFile = Just fileName}) displayEffect tldRef (effect :: UI DisplayFun) [mod] LoadFailure errs -> infoDialog f "Info" (unlines (take maxLines' errs)) MakeFailure errs -> return $ Right (unlines (take maxLines' errs)) saveImageHandler :: IORef TopLevelData -> IORef ViewerData -> IO () saveImageHandler tldRef vwdRef = do tld <- readIORef tldRef vwd <- readIORef vwdRef let pc = tldPanicConf tld let f = vwdEffectFrame vwd displayFun <- runUI (vwdDisplayFun vwd) (vwdUIRefs vwd) case displayFun of AnimDisplay _ -> infoDialog f "Animation can't be saved" "Animations cannot be saved to image files" ImageDisplay image -> do mbResult <- fileSaveDialogImage f True True "Enter name" case mbResult of Just (filePath, imageFileType) -> do let (panX, panY, zoom) = vwdVTrans vwd (w,h) = vwdVSize vwd (wd,ht) = vwdSaveSize vwd -- Zoom factor is based on y axis zoomFactor = fromIntegral h / fromIntegral ht progress <- progressDialogCreate "Progress" "Generating image..." (maxAliasIterations pc) f 0 progressDialogResume progress wxImage <- imageDisplayFunToWXImage image (maxAliasIterations pc) (wd,ht) (panX, panY, zoom * zoomFactor) (\k -> do { progressDialogUpdate progress k ; return ()}) imageSaveFile wxImage filePath imageFileType windowDestroy progress return () Nothing -> return () -- -- For selecting the width and height of the image you wish to -- generate -- widthHeightDialog :: IORef TopLevelData -> IORef ViewerData -> IO () widthHeightDialog tldRef vwdRef = do tld <- readIORef tldRef let pc = tldPanicConf tld vwd <- readIORef vwdRef let parentFrame = vwdEffectFrame vwd let (w,h) = vwdVSize vwd d <- dialog parentFrame [ text := "Save Image" , resizeable := False , closeable := False , visible := False ] p <- panel d [] widthStaticText <- staticText p [ text := "Width" ] widthTextEntry <- textEntry p [] heightStaticText <- staticText p [ text := "Height" ] heightTextEntry <- textEntry p [] aspectCheckBox <- checkBox p [ text := "Keep aspect ratio" , checked := True ] saveButton <- button p [ text := "Save Image" ] cancelButton <- button p [ text := "Cancel" ] -- -- Initialise the aspect flag -- writeIORef vwdRef (vwd {vwdAspectFlag = True }) let heightFromWidth (w,h) wd = (h * wd) `div` w widthFromHeight (w,h) ht = (w * ht) `div` h readTxt [] = 0 readTxt txt = read txt processKey key txt = do case key of KeyChar c | isDigit c -> do propagateEvent return $ txt ++ [c] KeyBack -> case txt of [] -> do propagateEvent return $ txt _ -> do propagateEvent return $ init txt _ -> return txt set widthTextEntry [ on keyboard := \ev@(EventKey key _ _) -> do txt <- get widthTextEntry text txt' <- processKey key txt vwd <- readIORef vwdRef let flag = vwdAspectFlag vwd (w,h) = vwdVSize vwd wd = readTxt txt' if flag then do let ht = heightFromWidth (w,h) wd set heightTextEntry [ text := show ht ] else return () , text := show w ] set heightTextEntry [ on keyboard := \ev@(EventKey key _ _) -> do txt <- get heightTextEntry text txt' <- processKey key txt vwd <- readIORef vwdRef let flag = vwdAspectFlag vwd (w,h) = vwdVSize vwd ht = readTxt txt' if flag then do let wd = widthFromHeight (w,h) ht set widthTextEntry [ text := show wd ] else return () , text := show h ] -- -- Set the aspect flag when the check box is clicked -- set aspectCheckBox [ on command := do b <- get aspectCheckBox checked writeIORef vwdRef (vwd { vwdAspectFlag = b }) ] let sizeLayout = margin (marginWidth pc) $ column 5 [ row 5 [ widget widthStaticText , fill $ widget widthTextEntry] , row 5 [ widget heightStaticText , fill $ widget heightTextEntry] , row 5 [ widget aspectCheckBox ] , row 5 [ widget saveButton, widget cancelButton ] ] (WX.Point ex ey) <- get parentFrame WX.position -- set p [ defaultButton := saveButton ] set d [ WX.position := WX.Point (ex + 20) (ey + 20) , layout := container p sizeLayout ] showModal d (\stop -> do -- -- The save button needs to read the text from the -- two text entry boxes and set vwdSaveSize -- appropriately -- set saveButton [ on command := do wdTxt <- get widthTextEntry text htTxt <- get heightTextEntry text let wd = readTxt wdTxt ht = readTxt htTxt writeIORef vwdRef (vwd { vwdSaveSize = (wd,ht)}) stop (Just ()) saveImageHandler tldRef vwdRef] set cancelButton [ on command := stop (Just ())]) return () -- | The main function main = do start mainFrame