diff --git a/GtkTV.cabal b/GtkTV.cabal --- a/GtkTV.cabal +++ b/GtkTV.cabal @@ -1,5 +1,5 @@ Name: GtkTV -Version: 0.1.6 +Version: 0.1.7 Cabal-Version: >= 1.2 Synopsis: Gtk-based GUIs for Tangible Values Category: User Interfaces @@ -33,7 +33,10 @@ , OpenGL, gtkglext, bitmap, bitmap-opengl, stb-image Exposed-Modules: Interface.TV.Gtk + Interface.TV.Gtk2 ghc-options: -Wall + +-- I'll keep either Gtk or Gtk2 and drop the other (maybe renaming Gtk2 to Gtk) -- The dependence on OpenGL, gtkglext etc is a bit unfortunate. Maybe -- factor out the GL stuff to another package. diff --git a/src/Interface/TV/Gtk.hs b/src/Interface/TV/Gtk.hs --- a/src/Interface/TV/Gtk.hs +++ b/src/Interface/TV/Gtk.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecursiveDo, MultiParamTypeClasses, ScopedTypeVariables +{-# LANGUAGE DoRec, MultiParamTypeClasses, ScopedTypeVariables , TypeFamilies #-} {-# OPTIONS_GHC -Wall #-} @@ -26,7 +26,7 @@ , module Interface.TV ) where -import Control.Applicative (liftA2,(<$>)) +import Control.Applicative (liftA2,(<$>),(<*>),(<$)) import Control.Monad (when) import Data.IORef import Data.Maybe (fromMaybe) @@ -145,13 +145,13 @@ getString start = MkI $ \ refresh -> do entry <- entryNew entrySetText entry start - onEntryActivate entry refresh + forget $ onEntryActivate entry refresh return (toWidget entry, entryGetText entry, return ()) getRead = getReadF -- thanks to MkI Functor getBool start = MkI $ \ refresh -> do w <- checkButtonNew toggleButtonSetActive w start - onToggled w refresh + forget $ onToggled w refresh return (toWidget w, toggleButtonGetActive w, return ()) instance CommonOuts MkO where @@ -200,21 +200,19 @@ instance Lambda MkI MkO where lambda = (unMkI ~> unMkO ~> MkO) $ \ ia ob -> - mdo box <- boxNew Vertical False 0 -- 10? - reff <- newIORef (error "mkLambda: no function yet") - let refresh = do f <- readIORef reff - a <- geta -- forward ref geta - snkb (f a) -- forward ref snkb - (wa,geta,cleana) <- ia refresh - (wb,snkb,cleanb) <- ob - -- set box [ containerChild := wa , containerChild := wb ] - -- Hack: stretch output but not input. Really I want to choose - -- per widget and propagate upward. - boxPackStart box wa PackNatural 0 - boxPackStart box wb PackGrow 0 - return ( toWidget box - , \ f -> writeIORef reff f >> refresh - , cleana >> cleanb) + do box <- boxNew Vertical False 0 -- 10? + reff <- newIORef (error "mkLambda: no function yet") + rec let refresh = readIORef reff <*> geta >>= snkb + (wa,geta,cleana) <- ia refresh + (wb,snkb,cleanb) <- ob + -- set box [ containerChild := wa , containerChild := wb ] + -- Hack: stretch output but not input. Really I want to choose + -- per widget and propagate upward. + boxPackStart box wa PackNatural 0 + boxPackStart box wb PackGrow 0 + return ( toWidget box + , \ f -> writeIORef reff f >> refresh + , cleana >> cleanb) {-------------------------------------------------------------------- @@ -229,7 +227,7 @@ runMkOIO :: String -> MkO a -> IO a -> Action runMkOIO name (MkO mko') mkA = do - initGUI + forget $ initGUI (wid,sink,cleanup) <- mko' window <- windowNew set window [ windowDefaultWidth := 200 @@ -239,7 +237,7 @@ -- , windowFocusOnMap := True -- helpful? , windowTitle := name ] - onDestroy window (cleanup >> mainQuit) + forget $ onDestroy window (cleanup >> mainQuit) widgetShowAll window -- Initial sink. Must come after show-all for the GLDrawingArea. mkA >>= sink @@ -317,7 +315,7 @@ do refresh writeIORef oldRef new -- Unlike wxHaskell, I guess call-backs aren't attributes in gtk2hs. - afterRangeChangeValue w (\ _ x -> changeTo (fromD x) >> return False) + forget $ afterRangeChangeValue w (\ _ x -> changeTo (fromD x) >> return False) -- TODO: experiment with return False vs True return (toWidget w, getter, return ()) @@ -412,14 +410,14 @@ -- Intended as an implementation substrate for functional graphics. renderOut :: Out Action renderOut = primMkO $ - do initGL + do forget $ initGL canvas <- mkCanvas widgetSetSizeRequest canvas 300 300 -- Initialise some GL setting just before the canvas first gets shown -- (We can't initialise these things earlier since the GL resources that -- we are using wouldn't have been set up yet) -- TODO experiment with moving some of these steps. - onRealize canvas $ withGLDrawingArea canvas $ const $ + forget $ onRealize canvas $ withGLDrawingArea canvas $ const $ do -- setupMatrices -- do elsewhere, e.g., runSurface depthFunc $= Just Less drawBuffer $= BackBuffers @@ -438,7 +436,7 @@ glDrawableSwapBuffers glwindow writeIORef drawRef draw -- Sync canvas size with and use draw action - onExpose canvas $ \_ -> + forget $ onExpose canvas $ \_ -> do (w',h') <- widgetGetSize canvas let w = fromIntegral w' :: GLsizei h = fromIntegral h' @@ -487,8 +485,8 @@ fileNameIn :: FilePath -> In FilePath fileNameIn start = primMkI $ \ refresh -> do w <- fileChooserButtonNew "Select file" FileChooserActionOpen - fileChooserSetFilename w start - onCurrentFolderChanged w refresh + forget $ fileChooserSetFilename w start + forget $ onCurrentFolderChanged w refresh return ( toWidget w , fromMaybe start <$> fileChooserGetFilename w , return () ) @@ -511,7 +509,7 @@ -- onFileActivated w $ putStrLn "onFileActivated" -- I'm changing the value on preview. TODO: change back if the -- user cancels. - onUpdatePreview w $ + forget $ onUpdatePreview w $ do -- putStrLn "onUpdatePreview" mb <- fileChooserGetFilename w case mb of @@ -536,3 +534,11 @@ -- I'd like to move to a consistently GC'd setting, in which textures, -- shaders, etc are GC'd. In that case, what keeps GPU resources alive? + +{-------------------------------------------------------------------- + Misc +--------------------------------------------------------------------} + +forget :: Functor f => f a -> f () +forget = (() <$) +-- forget = fmap (const ()) diff --git a/src/Interface/TV/Gtk2.hs b/src/Interface/TV/Gtk2.hs new file mode 100644 --- /dev/null +++ b/src/Interface/TV/Gtk2.hs @@ -0,0 +1,621 @@ +{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies #-} +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Interface.TV.Gtk +-- Copyright : (c) Conal Elliott 2009 +-- License : BSD3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Gtk-based GUIs in the TV (tangible value) framework +-- +-- This variation eliminates mdo by having MkI' produce a consumer of +-- refresh actions rather than taking a refresh action as argument. +---------------------------------------------------------------------- + +module Interface.TV.Gtk2 + ( -- * TV type specializations + In, Out, GTV, gtv, runGTV, runOut, runOutIO + -- * UI primitives + , R, sliderRIn, sliderIIn, clockIn + , rateSliderIn, integralIn + , fileNameIn, renderOut + , emptyTexture, textureIsEmpty, textureIn + , module Interface.TV + ) where + +import Control.Applicative (liftA2,(<$>),(<*>),(<$)) +import Control.Monad (when,join) +import Data.IORef +import Data.Maybe (fromMaybe) + +import Data.Time (getCurrentTime,utctDayTime) + +import Graphics.UI.Gtk hiding (Action) +import Graphics.UI.Gtk.OpenGL +import qualified Graphics.Rendering.OpenGL as G +import Graphics.Rendering.OpenGL hiding (Sink,get) +-- For textures +import Data.Bitmap.OpenGL +import Codec.Image.STB + +-- From vector-space +import Data.VectorSpace + +-- From TypeCompose +import Data.Title +import Data.Pair +import Data.Lambda +import Control.Compose (ToOI(..),Cofunctor(..),Flip(..)) + +import Interface.TV + +{-------------------------------------------------------------------- + TV type specializations +--------------------------------------------------------------------} + +type In = Input MkI +type Out = Output MkI MkO +type GTV = TV MkI MkO + +-- | Type specialization of 'tv' +gtv :: Out a -> a -> GTV a +gtv = tv + +-- | Type specialization of 'runTV' +runGTV :: GTV a -> IO () +runGTV = runTV + +-- Equivalently: +-- +-- runGTV :: RunTV MkI MkO + + +{-------------------------------------------------------------------- + Misc +--------------------------------------------------------------------} + +-- | Add post-processing. (Could use 'fmap' instead, but 'result' is more +-- specifically typed.) +result :: (b -> b') -> ((a -> b) -> (a -> b')) +result = (.) + +-- | Add pre-processing. +argument :: (a' -> a) -> ((a -> b) -> (a' -> b)) +argument = flip (.) + +infixr 1 ~> +-- | Add pre- and post processing +(~>) :: (a' -> a) -> (b -> b') -> ((a -> b) -> (a' -> b')) +f ~> h = result h . argument f + +-- (f ~> h) g = h . g . f + +-- More generally, +-- +-- (~>) :: Category (-->) => (a' --> a) -> (b --> b') -> ((a --> b) -> (a' --> b')) + +-- If I add argument back to DeepArrow, we can get a different generalization: +-- +-- (~>) :: DeepArrow (-->) => (a' --> a) -> (b --> b') -> ((a -> b) --> (a' -> b')) +-- f ~> h = result h . argument f -- generalized (.) + + +{-------------------------------------------------------------------- + Actions & info sinks +--------------------------------------------------------------------} + +-- | Convenient shorthand +type Action = IO () + +-- | Sink of information +type Sink a = a -> Action + +infixl 1 >+> -- first guess +-- | Combine sinks +(>+>) :: Sink a -> Sink b -> Sink (a,b) +(snka >+> snkb) (a,b) = snka a >> snkb b + + +{-------------------------------------------------------------------- + Representations +--------------------------------------------------------------------} + +-- Make a input UI. +newtype MkI a = MkI { unMkI :: MkI' a } + +inMkI :: (MkI' a -> MkI' b) -> (MkI a -> MkI b) +inMkI = unMkI ~> MkI + +inMkI2 :: (MkI' a -> MkI' b -> MkI' c) -> (MkI a -> MkI b -> MkI c) +inMkI2 = unMkI ~> inMkI + +-- Representation type for 'MkI'. Produces a widget, a polling operation, +-- a termination clean-up action, and a sink for a refresh action to be +-- constructed later. +type MkI' a = IO (Widget, IO a, Action, Sink Action) + +-- TODO: Look to reformulate to make the explicit class instances unnecessary. + +-- Make an output UI. +newtype MkO a = MkO { unMkO :: MkO' a } + +inMkO :: (MkO' a -> MkO' b) -> (MkO a -> MkO b) +inMkO = unMkO ~> MkO + +inMkO2 :: (MkO' a -> MkO' b -> MkO' c) -> (MkO a -> MkO b -> MkO c) +inMkO2 = unMkO ~> inMkO + + +{-------------------------------------------------------------------- + Instances +--------------------------------------------------------------------} + +-- Representation type for 'MkO'. Produce a widget, a way to send it new +-- info to display, and a termination clean-up action. +type MkO' a = IO (Widget, Sink a, Action) + +-- Currently, the clean-up actions are created only by clockDtI, and just +-- propagated by the other combinators. + +instance Functor MkI where + fmap f = inMkI (fmap f') + where + f' (wid,poll,clean,install) = (wid, fmap f poll, clean, install) + +-- Or +-- +-- fmap = inMkI . fmap . h +-- where +-- h f (wid,poll,clean,install) = (wid, fmap f poll, clean, install) + +-- Or +-- +-- fmap = inMkI . fmap . \ f (wid,poll,clean,install) -> (wid, fmap f poll, clean, install) + +-- Better yet: tweak the representation so that Functor is derived. + +instance Cofunctor MkO where + cofmap f = inMkO (fmap f') + where + f' (wid,sink,cleanup) = (wid, sink . f, cleanup) + +-- cofmap f (MkO mk) = MkO (fmap f' mk) +-- where +-- f' (wid,sink,cleanup) = (wid, sink . f, cleanup) + +-- Note that Functor & Cofunctor are isomorphic to a standard form. +-- Consider redefining MkI' and MkO' accordingly. See how other instances +-- work out. + +forget2 :: Monad m => (w -> a -> m b) -> (w -> a -> m ()) +forget2 = (result.result) ( >> return ()) + +-- forget2 h w a = h w a >> return () + +instance CommonIns MkI where + getString start = MkI $ + do w <- entryNew + entrySetText w start + return (toWidget w, entryGetText w, return (), forget2 onEntryActivate w) + getRead = getReadF -- thanks to MkI Functor + getBool start = MkI $ + do w <- checkButtonNew + toggleButtonSetActive w start + return (toWidget w, toggleButtonGetActive w, return (), forget2 onToggled w) + +instance CommonOuts MkO where + putString = MkO $ + do entry <- entryNew + return (toWidget entry, entrySetText entry, return ()) + putShow = putShowC -- thanks to MkO Cofunctor + putBool = MkO $ + do w <- checkButtonNew + return (toWidget w, toggleButtonSetActive w, return ()) + + +boxed :: Orient -> Widget -> Widget -> IO Widget +boxed o wa wb = + do box <- boxNew o False 10 + set box [ containerChild := wa , containerChild := wb ] + return (toWidget box) + +hboxed :: Widget -> Widget -> IO Widget +hboxed = boxed Horizontal + +instance Pair MkI where + pair = inMkI2 $ \ ia ib -> + do (wa,geta,cleana,installa) <- ia + (wb,getb,cleanb,installb) <- ib + box <- wa `hboxed` wb + return ( box + , liftA2 (,) geta getb + , cleana >> cleanb + , liftA2 (>>) installa installb + ) + +instance Pair MkO where + pair = inMkO2 $ \ oa ob -> + do (wa,snka,cleana) <- oa + (wb,snkb,cleanb) <- ob + box <- wa `hboxed` wb + return (box, snka >+> snkb, cleana >> cleanb) + +-- These Pair instances are getting closer to vanishing. Regular +-- structure is emerging. Keep inching along. One wart is that hboxed is +-- an IO operation, unlike the other combiners. + +instance Title_f MkI where + title_f str = inMkI $ \ ia -> + do (widget,geta,cleana,installa) <- ia + frame <- frameNew + set frame [ frameLabel := str + -- , frameShadowType := ShadowEtchedOut + , containerChild := widget ] + return (toWidget frame, geta, cleana, installa) + +instance Title_f MkO where + title_f str = inMkO $ \ oa -> + do (widget,sink,clean) <- oa + frame <- frameNew + set frame [ frameLabel := str + -- , frameShadowType := ShadowEtchedOut + , containerChild := widget ] + return (toWidget frame, sink, clean) + +instance Lambda MkI MkO where + lambda = (unMkI ~> unMkO ~> MkO) $ \ ia ob -> + do box <- boxNew Vertical False 0 -- 10? + reff <- newIORef (error "mkLambda: no function yet") + (wa,geta,cleana,installa) <- ia + (wb,snkb,cleanb ) <- ob + let refresh = readIORef reff <*> geta >>= snkb + installa refresh + -- set box [ containerChild := wa , containerChild := wb ] + -- Hack: stretch output but not input. Really I want to choose + -- per widget and propagate upward. + boxPackStart box wa PackNatural 0 + boxPackStart box wb PackGrow 0 + return ( toWidget box + , \ f -> writeIORef reff f >> refresh + , cleana >> cleanb) + + +{-------------------------------------------------------------------- + Execution +--------------------------------------------------------------------} + +runMkO :: String -> MkO a -> a -> Action +runMkO = (result.result.argument) return runMkOIO + +-- runMkO name mko = runMkOIO name mko . return + + +runMkOIO :: String -> MkO a -> IO a -> Action +runMkOIO name (MkO mko') mkA = do + forget initGUI + (wid,sink,cleanup) <- mko' + window <- windowNew + set window [ windowDefaultWidth := 200 + -- , windowDefaultHeight := 200 + -- , containerBorderWidth := 10 + , containerChild := wid + -- , windowFocusOnMap := True -- helpful? + , windowTitle := name + ] + forget $ onDestroy window (cleanup >> mainQuit) + widgetShowAll window + -- Initial sink. Must come after show-all for the GLDrawingArea. + mkA >>= sink + mainGUI + return () + +instance ToOI MkO where + toOI mkO = Flip (runMkO "GtkTV" mkO) + + +-- | Run a visualization on a constructed ('IO'-extracted) value. The +-- action is executed just once, after the visualization is all set up, +-- which allows for things like OpenGL shader compilation. +runOutIO :: String -> Out a -> IO a -> Action +runOutIO name out = runMkOIO name (output out) + +runOut :: String -> Out a -> a -> Action +runOut = (result.result.argument) return runOutIO +-- runOut name out = runOutIO name out . return + +-- I'd like to eliminate the glew dependency, and I don't know how. The +-- ToOI method doesn't get a chance to pass in specialized info. Hm. + + +{-------------------------------------------------------------------- + UI primitives +--------------------------------------------------------------------} + + +data Orient = Horizontal | Vertical deriving (Read,Show) + +boxNew :: Orient -> Bool -> Int -> IO Box +boxNew Vertical = boxer vBoxNew +boxNew Horizontal = boxer hBoxNew + +boxer :: BoxClass box => (a -> b -> IO box) -> (a -> b -> IO Box) +boxer = (result.result.fmap) toBox + +primMkI :: MkI' a -> In a +primMkI = iPrim . MkI + +-- Currently unused + +primMkO :: MkO' a -> Out a +primMkO = oPrim . MkO + +type R = Float + +-- TODO: Consider using R == Double (for constant folding), while really +-- being float on the GLSL side. + +sliderRIn :: (R,R) -> R -> In R +sliderRIn = sliderGIn realToFrac realToFrac 0.005 5 + +sliderIIn :: (Int,Int) -> Int -> In Int +sliderIIn = sliderGIn fromIntegral round 1 0 + +-- The step argument indicates how big a jump to make when clicking to one +-- side of the slider tab. Seems to be a fraction of the whole range, +-- rather than a fixed amount. I don't know what makes a good choice. + +-- Generalized slider. Gtk's scaling widgets work with Double, so this +-- adapter takes some initial params for conversion. Only fires when a +-- value really changes. +sliderGIn :: (Show a, Eq a) => (a -> Double) -> (Double -> a) -> a -> Int + -> (a,a) -> a -> In a +sliderGIn toD fromD step digits + (lo,hi) a0 = primMkI $ + do oldRef <- newIORef a0 + w <- hScaleNewWithRange (toD lo) (toD hi) (toD step) + set w [ rangeValue := toD a0, scaleDigits := digits ] + let getter = fromD <$> get w rangeValue + install refresh = forget2 afterRangeChangeValue w + (\ _ x -> changeTo (fromD x) >> return False) + where + changeTo new = + do old <- readIORef oldRef + when (old /= new) $ + do forget refresh + writeIORef oldRef new + -- TODO: experiment with return False vs True + return (toWidget w, getter, return (), install) + +-- -- Prevent vertical stretching +-- noVert :: WidgetClass w => w -> IO Widget +-- noVert w = do b <- boxNew Vertical False 0 +-- boxPackStart b w PackNatural 0 +-- return (toWidget b) + + +-- | A clock that reports time in seconds and updates at the given period +-- (in seconds). +clockDtI :: R -> In R +clockDtI period = primMkI $ + do start <- time + -- Start with a do-nothing refresh action. + refreshRef <- newIORef (return ()) + timeout <- timeoutAddFull (join (readIORef refreshRef) >> return True) + priorityDefaultIdle (round (period * 1000)) + w <- vBoxNew True 0 -- size 0 box + return ( toWidget w, subtract start <$> time + , timeoutRemove timeout, writeIORef refreshRef ) + + +-- Deactivating the clock's timeout during clean-up prevents it from +-- running when gtk starts up again. Particularly useful in ghci, where +-- restarting gtk is commonplace. + +-- | A clock that updates every 1/60 second +clockIn :: In R +clockIn = clockDtI (1/60) + +-- Get the time since midnight, in seconds +time :: IO R +time = (fromRational . toRational . utctDayTime) <$> getCurrentTime + + +-- | Rate slider. Convenience function built from 'sliderRin' and 'integralDtIn'. +rateSliderDtIn :: R -> (R,R) -> R -> In R +rateSliderDtIn period = (result.result) (integralDtIn period) sliderRIn + +-- | Rate slider. Updates result (integral) 60 times per second. +-- Specialization of 'rateSliderDtIn'. +rateSliderIn :: (R,R) -> R -> In R +rateSliderIn = rateSliderDtIn (1/60) + +-- | Integral of an input, with given update interval (in seconds) +integralDtIn :: (VectorSpace v, Eq v, Scalar v ~ Float) => + R -> In v -> In v +integralDtIn period inp = primMkI $ + do refT <- time >>= newIORef + refX <- newIORef zeroV + refreshRef <- newIORef (return ()) + (w,getV,cleanV,_) <- mkI' + timeout <- timeoutAddFull (join (readIORef refreshRef) >> return True) + priorityDefaultIdle (round (period * 1000)) + let getX = do v <- getV + prevX <- readIORef refX + if (v /= zeroV) then + do t <- time + prevT <- readIORef refT + let x = prevX ^+^ (t - prevT) *^ v + writeIORef refT t + writeIORef refX x + return x + else + return prevX + return (w, getX, timeoutRemove timeout >> cleanV, writeIORef refreshRef) + where + MkI mkI' = input inp + +-- Better: getX changes no state. Instead, update refT & refX when slider changes. +-- In any case, only invoke refresh when the rate is nonzero + +-- | Integral of an input. Updates result (integral) 60 times per second. +integralIn :: (VectorSpace v, Eq v, Scalar v ~ Float) => + In v -> In v +integralIn = integralDtIn (1/60) + + +-- CONCERN: integration can apply to pair-valued inputs (e.g., constructed +-- by 'pair'), but the DeepArrow dissecting operations will not be able to +-- split apart the (pair-valued) integral input. + + +{-------------------------------------------------------------------- + GtkGL stuff +--------------------------------------------------------------------} + +mkCanvas :: IO GLDrawingArea +mkCanvas = + glConfigNew [ GLModeRGBA, GLModeDepth , GLModeDouble, GLModeAlpha ] + >>= glDrawingAreaNew + +-- | Render output, given a rendering action. Handles all set-up. +-- Intended as an implementation substrate for functional graphics. +renderOut :: Out Action +renderOut = primMkO $ + do forget initGL + canvas <- mkCanvas + widgetSetSizeRequest canvas 300 300 + -- Initialise some GL setting just before the canvas first gets shown + -- (We can't initialise these things earlier since the GL resources that + -- we are using wouldn't have been set up yet) + -- TODO experiment with moving some of these steps. + forget $ onRealize canvas $ withGLDrawingArea canvas $ const $ + do -- setupMatrices -- do elsewhere, e.g., runSurface + depthFunc $= Just Less + drawBuffer $= BackBuffers + clearColor $= Color4 0 0 0.2 1 + -- Stash the latest draw action for use in onExpose + drawRef <- newIORef (return ()) + let display draw = + -- Draw in context + withGLDrawingArea canvas $ \ glwindow -> + do clear [DepthBuffer, ColorBuffer] + flipY + draw + flipY + -- glWaitVSync + finish + glDrawableSwapBuffers glwindow + writeIORef drawRef draw + -- Sync canvas size with and use draw action + forget $ onExpose canvas $ \_ -> + do (w',h') <- widgetGetSize canvas + let w = fromIntegral w' :: GLsizei + h = fromIntegral h' + maxWH = w `max` h + start s = fromIntegral ((s - maxWH) `div` 2) + viewport $= (Position (start w) (start h), Size maxWH maxWH) -- square + readIORef drawRef >>= display + return True + return (toWidget canvas, display, return ()) + +flipY :: Action +flipY = scale 1 (-1 :: GLfloat) 1 + +-- Is there another way to flip Y? + +-- | An empty texture. Test with 'textureIsEmpty' +emptyTexture :: TextureObject +emptyTexture = TextureObject bogusTO + +bogusTO :: G.GLuint +bogusTO = -1 + +-- | Is a texture empty? +textureIsEmpty :: TextureObject -> Bool +textureIsEmpty (TextureObject i) = i == bogusTO + +loadTexture :: FilePath -> IO (Either String TextureObject) +loadTexture path = + do e <- loadImage path + case e of + Left err -> return (Left err) + Right im -> Right <$> makeSimpleBitmapTexture im + + +-- Is there a more elegant formulation of loadTex? It's close to +-- being fmap on Either. I can almost get there as follows: +-- +-- foo :: FilePath -> IO (Either String (IO TextureObject)) +-- foo = (result.fmap.fmap) makeSimpleBitmapTexture loadImage + +-- loadImage :: FilePath -> IO (Either String Image) +-- makeSimpleBitmapTexture :: Image -> IO TextureObject + + + +fileNameIn :: FilePath -> In FilePath +fileNameIn start = primMkI $ + do w <- fileChooserButtonNew "Select file" FileChooserActionOpen + forget $ fileChooserSetFilename w start + return ( toWidget w + , fromMaybe start <$> fileChooserGetFilename w + , return () + , forget2 onCurrentFolderChanged w + ) + +textureIn :: In TextureObject +textureIn = fileMungeIn loadTexture deleteTexture emptyTexture + +deleteTexture :: Sink TextureObject +deleteTexture tex | textureIsEmpty tex = return () + | otherwise = + do -- putStrLn $ "deleteTexture " ++ show tex + deleteObjectNames [tex] + +fileMungeIn :: -- Show a => -- for debugging + (FilePath -> IO (Either String a)) -> Sink a -> a -> In a +fileMungeIn munge free start = primMkI $ + do w <- fileChooserButtonNew "Select file" FileChooserActionOpen + current <- newIORef start + -- onCurrentFolderChanged w $ putStrLn "onCurrentFolderChanged" + -- onFileActivated w $ putStrLn "onFileActivated" + -- I'm changing the value on preview. TODO: change back if the + -- user cancels. + let install refresh = + forget2 onUpdatePreview w $ + do -- putStrLn "onUpdatePreview" + mb <- fileChooserGetFilename w + case mb of + Nothing -> return () + Just path -> + do e <- munge path + case e of + Left _ -> return () + -- Left err -> putStrLn $ "fileMungeIn error: " ++ err + Right a -> do readIORef current >>= free + writeIORef current a + -- putStrLn $ "fileMungeIn: new value " ++ show a + refresh + return (toWidget w, readIORef current, return (), install) + + +-- TODO: Replace the error message with a GUI version. + +-- We're freeing the old thingie before saving the new thingie. In a +-- multi-threaded setting, there could be dire consequences. + +-- I'd like to move to a consistently GC'd setting, in which textures, +-- shaders, etc are GC'd. In that case, what keeps GPU resources alive? + + + +{-------------------------------------------------------------------- + Misc +--------------------------------------------------------------------} + +forget :: Functor f => f a -> f () +forget = (() <$) +-- forget = fmap (const ()) diff --git a/src/test.hs b/src/test.hs --- a/src/test.hs +++ b/src/test.hs @@ -14,7 +14,7 @@ import Control.Arrow ((&&&)) -import Interface.TV.Gtk2 +import Interface.TV.Gtk -- or Gtk2 import Control.Arrow.DeepArrow import Data.FunArr @@ -75,7 +75,8 @@ tv6 :: GTV (R -> Bool -> String) tv6 = tv (title "currying" o6) (curry show) --- t6 = runOut "currying" o6 (\ a b -> show (a,b)) +tv6' :: GTV ((R, Bool) -> String) +tv6' = uncurryA $$ tv6 t7 :: Action t7 = testI $ sliderIIn (0,5) 3