GtkTV 0.1.4 → 0.1.6
raw patch · 3 files changed
+303/−115 lines, 3 filesdep +bitmapdep +bitmap-opengldep +stb-imagedep ~TypeCompose
Dependencies added: bitmap, bitmap-opengl, stb-image, vector-space
Dependency ranges changed: TypeCompose
Files
- GtkTV.cabal +14/−9
- src/Interface/TV/Gtk.hs +254/−96
- src/test.hs +35/−10
GtkTV.cabal view
@@ -1,5 +1,5 @@ Name: GtkTV-Version: 0.1.4+Version: 0.1.6 Cabal-Version: >= 1.2 Synopsis: Gtk-based GUIs for Tangible Values Category: User Interfaces@@ -11,26 +11,31 @@ Author: Conal Elliott Maintainer: conal@conal.net Homepage: http://haskell.org/haskellwiki/GtkTV-Package-Url: http://code.haskell.org/~conal/code/GtkTV Copyright: (c) 2009, 2010 by Conal Elliott License: BSD3 License-File: COPYING Stability: experimental build-type: Simple- extra-source-files:- examples/test+ examples/test+Package-Url: http://code.haskell.org/~conal/code/GtkTV+-- Wait until Cabal 1.6 is more wide-spread and then add the following+-- in place of the Package-Url field and bump Cabal-Version to >= 1.6.+-- +-- Source-Repository head+-- type: darcs+-- location: http://code.haskell.org/~conal/code/GtkTV Library hs-Source-Dirs: src Extensions:- Build-Depends: base<5, time, gtk, TypeCompose>=0.6.7, TV- , OpenGL, gtkglext+ Build-Depends: base<5, time, gtk, TypeCompose>=0.7, TV, vector-space+ , OpenGL, gtkglext, bitmap, bitmap-opengl, stb-image Exposed-Modules: Interface.TV.Gtk ghc-options: -Wall --- ghc-prof-options: -prof -auto-all ---- The dependence on OpenGL and gtkglext is a bit unfortunate. Maybe+-- The dependence on OpenGL, gtkglext etc is a bit unfortunate. Maybe -- factor out the GL stuff to another package.++-- ghc-prof-options: -prof -auto-all
src/Interface/TV/Gtk.hs view
@@ -1,5 +1,8 @@-{-# LANGUAGE RecursiveDo, MultiParamTypeClasses #-}+{-# LANGUAGE RecursiveDo, MultiParamTypeClasses, ScopedTypeVariables+ , TypeFamilies+ #-} {-# OPTIONS_GHC -Wall #-}+-- {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-} -- TEMP ---------------------------------------------------------------------- -- | -- Module : Interface.TV.Gtk@@ -16,7 +19,10 @@ ( -- * TV type specializations In, Out, GTV, gtv, runGTV, runOut, runOutIO -- * UI primitives- , R, sliderRIn, sliderIIn, clockIn, fileNameIn, renderOut+ , R, sliderRIn, sliderIIn, clockIn+ , rateSliderIn, integralIn+ , fileNameIn, renderOut+ , emptyTexture, textureIsEmpty, textureIn , module Interface.TV ) where @@ -29,13 +35,20 @@ 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 Control.Compose (ToOI(..),Cofunctor(..),Flip(..),result,argument,(~>)) import Interface.TV @@ -55,7 +68,11 @@ runGTV :: GTV a -> IO () runGTV = runTV +-- Equivalently:+-- +-- runGTV :: RunTV MkI MkO + {-------------------------------------------------------------------- Actions & info sinks --------------------------------------------------------------------}@@ -77,33 +94,48 @@ --------------------------------------------------------------------} -- Make a input UI.-newtype MkI a = MkI (MkI' a)+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'. Takes a change call-back and produces a widget, a -- polling operation and a termination clean-up action. type MkI' a = Action -> IO (Widget, IO a, Action) -- Make an output UI.-newtype MkO a = MkO (MkO' a)+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+ -- 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) ++{--------------------------------------------------------------------+ Instances+--------------------------------------------------------------------}+ -- Currently, the clean-up actions are created only by clockDtI, and just -- propagated by the other combinators. instance Functor MkI where- fmap f (MkI h) = MkI h'+ fmap f = inMkI ((result.fmap) f') where- h' refresh = do (wid,poll,clean) <- h refresh- return (wid, fmap f poll, clean)+ f' (wid,poll,clean) = (wid, fmap f poll, clean) instance Cofunctor MkO where- cofmap f (MkO io) = MkO io'+ cofmap f = inMkO (fmap f') where- io' = do (wid,sink,cleanup) <- io- return (wid,sink . f,cleanup)+ 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@@ -131,16 +163,64 @@ do w <- checkButtonNew return (toWidget w, toggleButtonSetActive w, return ()) +instance Pair MkI where+ -- pair (MkI ia) (MkI ib) = MkI $ \ refresh ->+ pair = inMkI2 $ \ ia ib -> \ refresh ->+ do box <- boxNew Horizontal False 10+ (wa,geta,cleana) <- ia refresh+ (wb,getb,cleanb) <- ib refresh+ set box [ containerChild := wa , containerChild := wb ]+ return (toWidget box, liftA2 (,) geta getb, cleana >> cleanb) --- | Add post-processing. (Could use 'fmap' instead, but 'result' is more--- specifically typed.)-result :: (b -> b') -> ((a -> b) -> (a -> b'))-result = (.)+instance Pair MkO where+ pair = inMkO2 $ \ oa ob ->+ do box <- boxNew Horizontal False 10+ (wa,snka,cleana) <- oa+ (wb,snkb,cleanb) <- ob+ set box [ containerChild := wa , containerChild := wb ]+ return (toWidget box, snka >+> snkb, cleana >> cleanb) --- | Add pre-processing.-argument :: (a' -> a) -> ((a -> b) -> (a' -> b))-argument = flip (.)+instance Title_f MkI where+ title_f str = inMkI $ \ ia -> \ refresh ->+ do (widget,geta,cleana) <- ia refresh+ frame <- frameNew+ set frame [ frameLabel := str+ -- , frameShadowType := ShadowEtchedOut+ , containerChild := widget ]+ return (toWidget frame, geta, cleana) +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 ->+ 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)+++{--------------------------------------------------------------------+ Execution+--------------------------------------------------------------------}+ runMkO :: String -> MkO a -> a -> Action runMkO = (result.result.argument) return runMkOIO @@ -188,7 +268,6 @@ UI primitives --------------------------------------------------------------------} - data Orient = Horizontal | Vertical deriving (Read,Show) boxNew :: Orient -> Bool -> Int -> IO Box@@ -198,55 +277,6 @@ boxer :: BoxClass box => (a -> b -> IO box) -> (a -> b -> IO Box) boxer = (result.result.fmap) toBox -instance Pair MkI where- pair (MkI ia) (MkI ob) = MkI $ \ refresh ->- do box <- boxNew Horizontal False 10- (wa,geta,cleana) <- ia refresh- (wb,getb,cleanb) <- ob refresh- set box [ containerChild := wa , containerChild := wb ]- return (toWidget box, liftA2 (,) geta getb, cleana >> cleanb)--instance Pair MkO where- pair (MkO oa) (MkO ob) = MkO $- do box <- boxNew Horizontal False 10- (wa,snka,cleana) <- oa- (wb,snkb,cleanb) <- ob- set box [ containerChild := wa , containerChild := wb ]- return (toWidget box, snka >+> snkb, cleana >> cleanb)--instance Title_f MkI where- title_f str (MkI ia) = MkI $ \ refresh ->- do (widget,geta,cleana) <- ia refresh- frame <- frameNew- set frame [ frameLabel := str- -- , frameShadowType := ShadowEtchedOut- , containerChild := widget ]- return (toWidget frame, geta, cleana)--instance Title_f MkO where- title_f str (MkO oa) = MkO $- 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 (MkI ia) (MkO ob) = MkO $- mdo box <- boxNew Vertical False 0 -- 10?- reff <- newIORef (error "mkLambda: no function yet")- let update = do f <- readIORef reff- a <- geta -- note loop- snkb (f a)- (wa,geta,cleana) <- ia update- (wb,snkb,cleanb) <- ob- set box [ containerChild := wa , containerChild := wb ]- return ( toWidget box- , \ f -> writeIORef reff f >> update- , cleana >> cleanb)-- primMkI :: MkI' a -> In a primMkI = iPrim . MkI @@ -261,7 +291,7 @@ -- being float on the GLSL side. sliderRIn :: (R,R) -> R -> In R-sliderRIn = sliderGIn realToFrac realToFrac 0.01 5+sliderRIn = sliderGIn realToFrac realToFrac 0.005 5 sliderIIn :: (Int,Int) -> Int -> In Int sliderIIn = sliderGIn fromIntegral round 1 0@@ -291,25 +321,13 @@ -- TODO: experiment with return False vs True return (toWidget w, getter, return ()) +-- -- 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) -fileNameIn :: FilePath -> In FilePath-fileNameIn start = primMkI $ \ refresh ->- do w <- fileChooserButtonNew "Select file" FileChooserActionOpen- fileChooserSetFilename w start- onCurrentFolderChanged w refresh- -- fileChooserGetFilename w >>= print -- testing- return ( toWidget w- , fromMaybe start <$> fileChooserGetFilename w- , return () ) --- mkTextureI :: GlTexture -> In GlTexture--- mkTextureI = error "mkTexture: not yet implemented"---- mkTexture start refresh (BaseG oi) = do ...--- mkTexture _ _ _ = error "mkTexture: not BaseG"---- onEntryActivate :: EntryClass ec => ec -> Action -> IO (ConnectId ec)- -- | A clock that reports time in seconds and updates at the given period -- (in seconds). clockDtI :: R -> In R@@ -325,7 +343,6 @@ -- 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)@@ -335,18 +352,68 @@ 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 $ \ refresh ->+ do refT <- time >>= newIORef+ refX <- newIORef zeroV+ (w,getV,cleanV) <- mkI' (return ())+ timeout <- timeoutAddFull (refresh >> 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)+ 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 initGL- glconfig <- glConfigNew [ GLModeRGBA, GLModeDepth- , GLModeDouble, GLModeAlpha ]- canvas <- glDrawingAreaNew glconfig+ 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@@ -359,22 +426,113 @@ clearColor $= Color4 0 0 0.2 1 -- Stash the latest draw action for use in onExpose drawRef <- newIORef (return ())- -- Sync canvas size with GL viewport, and use draw action let display draw = -- Draw in context- withGLDrawingArea canvas $ \glwindow ->+ 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 onExpose canvas $ \_ -> do (w',h') <- widgetGetSize canvas- let w = fromIntegral w' ; h = fromIntegral h'- let dim :: GLsizei; start :: GLsizei -> GLint- dim = w `min` h ; start s = fromIntegral ((s - dim) `div` 2)- viewport $= (Position (start w) (start h), Size dim dim) -- square??+ 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 $ \ refresh ->+ do w <- fileChooserButtonNew "Select file" FileChooserActionOpen+ fileChooserSetFilename w start+ onCurrentFolderChanged w refresh+ return ( toWidget w+ , fromMaybe start <$> fileChooserGetFilename w+ , return () )++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 $ \ refresh ->+ 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.+ 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 ())+++-- 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?+
src/test.hs view
@@ -14,7 +14,7 @@ import Control.Arrow ((&&&)) -import Interface.TV.Gtk+import Interface.TV.Gtk2 import Control.Arrow.DeepArrow import Data.FunArr @@ -86,6 +86,8 @@ t9 :: Action t9 = testI $ stringIn "bloop" +i5 :: In String+i5 = fileNameIn "bloop" {-------------------------------------------------------------------- Taken from GuiTV (based on Reactive, Phooey, and wxhaskell)@@ -141,21 +143,38 @@ renderGray :: Sink Float renderGray x' = do -- putStrLn "renderGray" color (Color4 x x x x)- square+ renderSquare where x = realToFrac x' :: GLfloat -square :: Action-square = renderPrimitive Quads $ -- start drawing a polygon (4 sided)- do vert (-o) o -- top left- vert o o -- top right- vert o (-o) -- bottom right- vert (-o) (-o) -- bottom left+-- Render a square with vertex coordinates ranging from -1 to 1 and+-- texture coordinates ranging from 0 to 1+renderSquare :: Action+renderSquare =+ do renderPrimitive Quads $ -- start drawing a polygon (4 sided)+ do vert 0 1 -- top left+ vert 1 1 -- top right+ vert 1 0 -- bottom right+ vert 0 0 -- bottom left where- vert x y = vertex (Vertex3 x y (0 :: GLfloat))- o = 0.9+ vert :: GLfloat -> GLfloat -> Action+ vert u v = do texCoord (TexCoord2 u v)+ vertex (Vertex2 (q u) (q v))+ where q w = 2 * w - 1 +renderTexture :: Sink TextureObject+renderTexture tex | textureIsEmpty tex = return ()+ | otherwise = do useTexture tex+ renderSquare++useTexture :: Sink TextureObject+useTexture obj =+ do texture Texture2D $= Enabled+ activeTexture $= TextureUnit 0+ textureBinding Texture2D $= Just obj++ iGray :: In R iGray = title "gray level" $ sliderRIn (0,1) 0.5 @@ -198,3 +217,9 @@ tv12 :: GTV (R -> (Action,Action)) tv12 = result dupA $$ tv8++tv13 :: GTV (TextureObject -> Action)+tv13 = tv (lambda textureIn renderOut) renderTexture++tv14 :: GTV (R -> R)+tv14 = tv (lambda (title "rate" $ integralIn $ sliderRIn (-10,10) 0) defaultOut) id