-- -- | -- Module : UIUtils -- Author : Sean Seefried (http://www.cse.unsw.edu.au/~sseefried) -- Copyright : (c) 2005 -- License : BSD3 -- Created : 16 Jun 2005 -- module UIUtils where -- library imports import Data.List import Data.Array import Data.Array.Base (unsafeAt) import Data.IORef import System.Directory import Control.Monad.Error -- for instance of MonadPlus IO import GHC.Base import GHC.Float import GHC.Int import Foreign import System.Random -- wxHaskell import Graphics.UI.WX hiding ( Size, marginWidth ) import Graphics.UI.WXCore hiding ( Size, marginWidth, Colour, Region) import qualified Graphics.UI.WX as WX import qualified Graphics.UI.WXCore as WXCore -- Pan! import Pan -- local import GlobalData import PanicConfAPI import Utils import WXExts import Paint -- -- makeWidgetAPaintController takes a reactive widget and makes it such -- that when the widget is clicked the paint events are disabled and -- reenabled when unclicked. makeWidgetAPaintController :: Reactive w => IORef TopLevelData -> IORef ViewerData -> w -> IO () makeWidgetAPaintController tldRef vwdRef w = set w [ on click := \_ -> do disablePaint vwdRef propagateEvent , on unclick := \_ -> do enablePaint tldRef vwdRef propagateEvent ] -- -- | addUIElem takes a window, creates IORefs, and adds a user -- interface element to it. Returns the refs and the layout. -- FIXME: Only handles sliders at present. -- addUIElem :: IORef TopLevelData -> IORef ViewerData -> Window a -> UIElem -> IO (UIRef, Layout) addUIElem tldRef vwdRef w uiElem= do tld <- readIORef tldRef let pc = tldPanicConf tld case uiElem of s@(ISlider label (lower, upper) def) -> do slider <- hslider w True lower upper [selection := def] uiRef@(UIInt ref) <- newUIRef s stext <- staticText w [text := label ] -- Just gets the fields the right length let lenUpper = length (show upper) lenLower = length (show lower) len = max lenUpper lenLower diff = 2*(len - length (show def)) valText <- staticText w [ text := show def ++ take diff (repeat ' ')] set slider [ on command := iSliderHandler vwdRef slider valText ref ] makeWidgetAPaintController tldRef vwdRef slider return ( uiRef , hfill $ row 5 [widget stext, widget valText , fill $ widget slider]) s@(Slider label (lower, upper) def) -> do let val = floor $ (def - lower) / (upper - lower) * (fromIntegral tICKS) slider <- hslider w False 0 tICKS [ selection := val ] uiRef@(UIFloat ref) <- newUIRef s stext <- staticText w [ text := label ] -- Just gets the fields the right length let lenUpper = length (show upper) lenLower = length (show lower) len = max lenUpper lenLower diff = 2*(len - length (show def)) valText <- staticText w [ text := showPlaces (placesToShow pc) def ++ take diff (repeat ' ') ] set slider [ on command := sliderHandler vwdRef slider valText (lower, upper) ref ] makeWidgetAPaintController tldRef vwdRef slider return (uiRef, hfill $ row 5 [widget stext, widget valText , fill $ widget slider]) BitmapFile partFilePath -> do bmpButton <- button w [text := "Load bitmap"] let currentDir = tldCurrentDirectory tld filePath <- if not (absolutePath partFilePath) then do return (currentDir ++ partFilePath) else do path <- expandTilde partFilePath return path txt <- textEntry w [ enabled := False ] set txt [ text := filePath , on resize := set txt [ text := filePath] ] exists <- doesFileExist filePath if not exists then do infoDialog w "File not found" ("`" ++ filePath ++ "' not found. Using the empty " ++ "image instead.") else return () uiRef@(UIImageC ref) <- newUIRef (BitmapFile filePath) set bmpButton [ on command := bitmapButtonHandler vwdRef w txt ref ] return (uiRef, hfill $ row 5 [ widget bmpButton, fill $ widget txt ]) -- -- | Event handler for integer slider -- iSliderHandler :: IORef ViewerData -> Slider a -- ^ the slider -> Window b -- ^ staticText window with current value -> IORef Int -- ^ variable to communicate current value -> IO () iSliderHandler vwdRef slider valText ref = do i <- get slider selection set valText [ text := show i ] vwd <- readIORef vwdRef writeIORef vwdRef (vwd { vwdChanged = True }) writeIORef ref i -- -- | Event handler for continuous slider -- sliderHandler :: IORef ViewerData -> Slider a -- ^ the slider -> Window b -- ^ staticText window with current value -> (Frac,Frac) -- ^ lower/upper bounds -> IORef Frac -- ^ variable to communicate current value -> IO () sliderHandler vwdRef slider valText (lower,upper) ref = do i <- get slider selection -- a value between 0 and tICKS let val = (fromIntegral i / fromIntegral tICKS) * range + lower range = upper - lower set valText [ text := showPlaces 4 val ] -- FIXME: Magic number vwd <- readIORef vwdRef writeIORef vwdRef (vwd { vwdChanged = True }) writeIORef ref val -- -- | Event handler for bitmap button. Loads a bitmap and turns it into an -- image. -- bitmapButtonHandler :: IORef ViewerData -> Window a -> TextCtrl () -> IORef ImageC -> IO () bitmapButtonHandler vwdRef w txt imageRef = do vwd <- readIORef vwdRef mFilePath <- fileOpenDialog w True True "Select bitmap file" imageFileFormats "" "" case mFilePath of Just filePath -> do image <- getImageCFromFile filePath set txt [ text := filePath , on resize := set txt [ text := filePath ] ] writeIORef imageRef image writeIORef vwdRef (vwd { vwdChanged = True }) Nothing -> return () -- -- Creates new UIRef`s. -- newUIRef :: UIElem -> IO UIRef newUIRef (Slider _ _ def) = do ref <- newIORef def return (UIFloat ref) newUIRef (ISlider _ _ def) = do ref <- newIORef def return (UIInt ref) newUIRef (BitmapFile filePath) = do image <- getImageCFromFile filePath ref <- newIORef image return (UIImageC ref) ---------------------------------------------------------------------- -- -- Bitmap support for Panic -- -- -- Returns the empty image (@emptyI) if the file doesn't exist. -- getImageCFromFile :: FilePath -> IO ImageC getImageCFromFile filePath = do (do guardM (doesFileExist filePath) bmpArray <- loadBitmap filePath return (reconstruct bmpArray)) `mplus` (do return emptyI) guardM :: MonadPlus m => m Bool -> m () guardM mBool = do bool <- mBool guard bool data BitmapArray c = BitmapArray Int Int (Array Int c) -- -- Loads from a bitmap file to a BitmapArray -- -- Modified from version contributed by shelarcy - -- http://page.freett.com/shelarcy -- loadBitmap :: FilePath -> IO (BitmapArray Colour) loadBitmap fname = do withImageFromFile fname loadImage' where pointColourRed col = (/256) . realToFrac . (+1) . colorRed $ col pointColourGreen col = (/256) $ realToFrac $ (+1) $ colorGreen $ col pointColourBlue col = (/256) $ realToFrac $ (+1) $ colorBlue $ col pointPanColour col = Col (pointColourRed col) (pointColourGreen col) (pointColourBlue col) 1 wxPointToPair w h (WX.Point x y) = w * ((h-1) - y) + x loadImage' img = do arr <- imageGetPixelArray img w <- imageGetWidth img h <- imageGetHeight img let elems = assocs arr newElems = map (\(i,e) -> (wxPointToPair w h i, pointPanColour e)) elems newArr = array (0, w*h-1) newElems return (BitmapArray w h newArr) withImageFromFile :: FilePath -> (WXCore.Image () -> IO a) -> IO a withImageFromFile fname f = bracket (imageCreateFromFile fname) (imageDelete) f -- -- Bitmap reconstruction. Account for finiteness. Doesn't use bilerp -- (bilinear interpolation) like Elliott et al.'s original -- implementation. -- reconstruct :: BitmapArray Colour -> ImageC reconstruct bmpArray@(BitmapArray w h arr) = -- Move bitmap's center to the origin. Use integer div so we'll get an -- integral motion even for odd width or height. Helps speed. translate (Vec (- fromIntegral (w `div` 2)) (- fromIntegral (h `div` 2))) cropped where cropped = crop (inBounds (w-1) (h-1)) bilerped bilerped = arrayToImageC bmpArray -- -- Doesn't use bilinear interpolation. Result looks pixelated. -- arrayToImageC :: BitmapArray Colour -> ImageC arrayToImageC (BitmapArray w _ arr) = \ (Pt (F# x) (F# y)) -> let i = I# (floor' x) j = I# (floor' y) in arr `unsafeAt` (w*j + i) -- -- Whether a point is within array bounds. -- inBounds :: Int -> Int -> Region inBounds (I# w) (I# h) = \ (Pt (F# x) (F# y)) -> x `under` w && y `under` h under :: Float# -> Int# -> Bool z `under` m = (0# <=# zI) && (zI <=# (m -# 1#)) where zI = floor' z floor' :: Float# -> Int# floor' f = case ltFloat# f 0.0# of True -> (float2Int# f) -# 1# _ -> float2Int# f ---------------------------------------------------------------------- -- -- Saving image support -- -- -- Converts a Pan image to a WX Image -- imageDisplayFunToWXImage :: ImageDisplayFun -> Int -> VSize -> VTrans -> (Int -> IO ()) -> IO (WXCore.Image ()) imageDisplayFunToWXImage imageDisplayFun n vsize@(w,h) vtrans updater = do (ptr :: Ptr Int8) <- mallocBytes (w*h*bytesPerColour) prepareImageForSaving imageDisplayFun n ptr vsize vtrans updater img <- imageBufToWXImage ptr vsize free ptr -- free the pointer return img imageBufToWXImage :: Ptr Int8 -> VSize -> IO (WXCore.Image ()) imageBufToWXImage ptr (w,h) = do pixelBuffer <- pixelBufferCreate (WX.Size w h) let setPixel x y = do let off = (w*(h - (y + 1)) + x) * bytesPerColour r <- peekByteOff ptr (off + 1) g <- peekByteOff ptr (off + 2) b <- peekByteOff ptr (off + 3) pixelBufferSetPixel pixelBuffer (WX.Point x y) (WX.rgb r g b) setPixels i j | j == h = return () | i == w = setPixels 0 (j+1) | otherwise = do setPixel i j setPixels (i+1) j setPixels 0 0 imageCreateFromPixelBuffer pixelBuffer prepareImageForSaving :: ImageDisplayFun -> Int -> Ptr Int8 -> VSize -> VTrans -> (Int -> IO ()) -> IO () prepareImageForSaving imageDisplayFun n ptr vsize vtrans updater = blitFrame 0 where blitFrame k | k == n = return () | otherwise = do xJitter <- randomRIO (0,1) yJitter <- randomRIO (0,1) imageDisplayFun ptr k xJitter yJitter vsize vtrans updater k blitFrame (k+1)