{-#LANGUAGE FlexibleInstances , FlexibleContexts, DoRec, NoMonomorphismRestriction, TypeFamilies #-} module Graphics.Tools.DefaultGUI ( defaultGUI, testFunction, module Graphics.Tools.Tangible, module Graphics.Tools.Tangible.Instances, module Utils.Persist, module Graphics.Tools.WX, module GHC.Generics ) where import Graphics.UI.WX hiding (image,value,parent,get) import qualified Graphics.UI.WX as WX (value,parent,get) import Graphics.Tools.WX import Graphics.Tools.CV2WX() import CV.Image as CV import CV.Filters import Data.IORef import Control.Applicative import Utils.Persist import System.Directory (doesFileExist) import qualified Data.Map as Map import Graphics.Tools.Tangible import Graphics.Tools.Tangible.Instances import GHC.Generics defaultGUI :: (Tangible α, Persist α, Default α, WxPaintable β, WxImage (Image c d), Loadable (Image c d)) => FilePath -- ^ File to store the filter parameters in -> FilePath -- ^ Initial image file -> (α -> Image c d -> β) -- ^ The processing function -> IO () defaultGUI storeFile imageFile = start . buildGUI imageFile . mkGUIOp storeFile testFunction :: Int -> Image GrayScale D32 -> Image GrayScale D32 testFunction i img = (!!i) . iterate (gaussian (3,3)) $ img type GUIOp c d= IORef (Image c d) -> Frame () -> Panel () -> Frame () -> IO (IO ()) mkGUIOp :: (Persist α, Default α, Tangible α, WxPaintable β) => FilePath -- ^ File to persist parameters -> (α -> Image c d -> β) -- ^ A function to transform a tangible value and image to something -- that WX knows how to paint -> GUIOp c d -- ^ Operation that can be given to `defaultMain` mkGUIOp storeFile function imageRef frame surface controls = let update lastValue value = do image <- readIORef imageRef let display = function value image set frame [outerSize := paintSize display] updateSurface surface display store <- readIORef lastValue let store' = Map.union (put "" value) store writeIORef lastValue store' writeFile storeFile (show store') in do e <- doesFileExist storeFile store <- if e then read <$> readFile storeFile else return Map.empty lastValue <- newIORef store c <- present (get "" store) (update lastValue) controls set controls [layout := widget c] return (readIORef lastValue >>= update lastValue . get "") buildGUI :: (WxImage (Image c d), Loadable (Image c d)) => FilePath -> GUIOp c d -> IO () buildGUI imagePath guiOp = do -- Program state image <- CV.readFromFile imagePath imageRef <- newIORef image -- Main window f <- frame [ text := "Filter Tuner" ] -- Create the menu file <- menuPane [text := "&File"] mopen <- menuItem file [text := "&Open Image\tCtrl+O" , help := "Open image to be processed"] msave <- menuItem file [text := "&Save Image\tCtrl+O" , help := "Save current image"] mclose <- menuQuit file [] set f [menuBar := [file]] -- Create the image viewer imgPanel <- panel f [] surface <- createSurface imgPanel image -- Create the control panel controls <- frameTool [] f update <- guiOp imageRef f surface controls -- Hook everything together set f [on (menu mopen) := openFile f imageRef >> update ,on (menu mclose) := close f ,on (menu msave) := saveFile f imageRef ] set f [layout := row 2 [widget imgPanel]] -- Make sure the image is current set f [on idle := update >> return False] return () saveFile :: Window a -> IORef (Image c d) -> IO () saveFile f imageRef = do file <- fileSaveDialog f True False "Save as" [("Image file",["*.png","*.jpg","*.tif","*.tiff"])] "" "" case file of Nothing -> return () Just filename -> readIORef imageRef >>= saveImage filename openFile :: (CV.Sized a1, Loadable a1, CV.Size a1 ~ (Int, Int)) => Window a -> IORef a1 -> IO () openFile f imageRef = do file <- fileOpenDialog f True True "Select Image" [("Image file",["*.png","*.jpg","*.tif","*.tiff"])] "" "" case file of Nothing -> return () Just newFile -> do img <- readFromFile newFile writeIORef imageRef img imageSize :: (Num b, CV.Sized a, CV.Size a ~ (b, b)) => a -> Size2D b imageSize = uncurry Size . getSize paintSurface' :: WxPaintable p => p -> DC a -> t -> IO () paintSurface' p dc _ = doPaint dc (point 0 0) p createSurface :: WxPaintable p => Window a -> p -> IO (Panel ()) createSurface f p = panel f [ on paint := paintSurface' p, outerSize := paintSize p ] updateSurface :: (Paint w, Dimensions w, WxPaintable p) => w -> p -> IO () updateSurface s p = do set s [ on paint := paintSurface p, outerSize := paintSize p ] repaint s paintSurface :: WxPaintable p => p -> DC a -> t -> IO () paintSurface p dc _ = doPaint dc (point 0 0) p