packages feed

GtkTV 0.1.9 → 0.2.0

raw patch · 5 files changed

+99/−155 lines, 5 filesdep −OpenGLdep −bitmapdep −bitmap-opengldep ~TypeCompose

Dependencies removed: OpenGL, bitmap, bitmap-opengl, gtkglext, stb-image

Dependency ranges changed: TypeCompose

Files

GtkTV.cabal view
@@ -1,17 +1,15 @@ Name:                GtkTV-Version:             0.1.9+Version:             0.2.0 Cabal-Version:       >= 1.2 Synopsis:            Gtk-based GUIs for Tangible Values Category:            User Interfaces Description:   GtkTV is a very small library that extends the TV (tangible value)   framework with graphical user interfaces, using gtk2hs.-  .-  &#169; 2009, 2010 by Conal Elliott; BSD3 license. Author:              Conal Elliott Maintainer:          conal@conal.net Homepage:            http://haskell.org/haskellwiki/GtkTV-Copyright:           (c) 2009, 2010 by Conal Elliott+Copyright:           (c) 2009-2011 by Conal Elliott License:             BSD3 License-File:        COPYING Stability:           experimental@@ -29,8 +27,8 @@ Library   hs-Source-Dirs:      src   Extensions:-  Build-Depends:       base<5, time, gtk, TypeCompose>=0.7, TV, vector-space-                     , OpenGL, gtkglext, bitmap, bitmap-opengl, stb-image+  Build-Depends:       base<5, time, gtk, TypeCompose>=0.9.1, TV, vector-space+                     -- , OpenGL, gtkglext, bitmap, bitmap-opengl, stb-image   Exposed-Modules:                        Interface.TV.Gtk                        Interface.TV.Gtk2@@ -38,7 +36,6 @@  -- 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.+-- I've moved the OpenGL functionality to the package GtkGLTV  --  ghc-prof-options:    -prof -auto-all
− Makefile 
@@ -1,1 +0,0 @@-include ../cho-home-cabal-make.inc
src/Interface/TV/Gtk.hs view
@@ -21,9 +21,12 @@     -- * UI primitives   , R, sliderRIn, sliderIIn, clockIn   , rateSliderIn, integralIn-  , fileNameIn, renderOut-  , emptyTexture, textureIsEmpty, textureIn+  , fileNameIn+  -- , renderOut, emptyTexture, textureIsEmpty, textureIn   , module Interface.TV+    -- * Extensibility+  , Action, Sink+  , MkI, MkI', MkO, MkO', primMkI, primMkO, forget, forget2   ) where  import Control.Applicative (liftA2,(<$>),(<*>),(<$))@@ -35,12 +38,14 @@  import Graphics.UI.Gtk hiding (Action) import qualified Graphics.UI.Gtk as Gtk+{- 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@@ -49,7 +54,7 @@ import Data.Title import Data.Pair import Data.Lambda-import Control.Compose (ToOI(..),Cofunctor(..),Flip(..),result,argument,(~>))+import Control.Compose (ToOI(..),ContraFunctor(..),Flip(..),result,argument,(~>))  import Interface.TV @@ -138,12 +143,12 @@     where       f' (wid,poll,clean) = (wid, fmap f poll, clean) -instance Cofunctor MkO where-  cofmap f = inMkO (fmap f')+instance ContraFunctor MkO where+  contraFmap f = inMkO (fmap f')    where      f' (wid,sink,cleanup) = (wid,sink . f,cleanup) --- Note that Functor & Cofunctor are isomorphic to a standard form.+-- Note that Functor & ContraFunctor are isomorphic to a standard form. -- Consider redefining MkI' and MkO' accordingly.  See how other instances -- work out. @@ -164,7 +169,7 @@   putString = MkO $     do entry <- entryNew        return (toWidget entry, entrySetText entry, return ())-  putShow = putShowC  -- thanks to MkO Cofunctor+  putShow = putShowC  -- thanks to MkO ContraFunctor   putBool = MkO $     do w <- checkButtonNew        return (toWidget w, toggleButtonSetActive w, return ())@@ -402,7 +407,9 @@ -- by 'pair'), but the DeepArrow dissecting operations will not be able to -- split apart the (pair-valued) integral input. +{- + {--------------------------------------------------------------------     GtkGL stuff --------------------------------------------------------------------}@@ -486,6 +493,7 @@ -- loadImage :: FilePath -> IO (Either String Image) -- makeSimpleBitmapTexture :: Image -> IO TextureObject +-}   fileNameIn :: FilePath -> In FilePath@@ -497,6 +505,8 @@             , fromMaybe start <$> fileChooserGetFilename w             , return () ) +{-+ textureIn :: In TextureObject textureIn = fileMungeIn loadTexture deleteTexture emptyTexture @@ -531,6 +541,7 @@                                   refresh      return (toWidget w, readIORef current, return ()) +-}  -- TODO: Replace the error message with a GUI version. @@ -548,3 +559,7 @@ forget :: Functor f => f a -> f () forget = (() <$) -- forget = fmap (const ())++forget2 :: Monad m => (w -> a -> m b) -> (w -> a -> m ())+forget2 = (result.result) ( >> return ())+-- forget2 h w a = h w a >> return ()
src/Interface/TV/Gtk2.hs view
@@ -21,9 +21,12 @@     -- * UI primitives   , R, sliderRIn, sliderIIn, clockIn   , rateSliderIn, integralIn-  , fileNameIn, renderOut-  , emptyTexture, textureIsEmpty, textureIn+  , fileNameIn+  -- , renderOut, emptyTexture, textureIsEmpty, textureIn   , module Interface.TV+    -- * Extensibility+  , Action, Sink+  , MkI, MkI', MkO, MkO', primMkI, primMkO, forget, forget2   ) where  import Control.Applicative (liftA2,(<$>),(<*>),(<$))@@ -35,6 +38,7 @@  import Graphics.UI.Gtk hiding (Action) import qualified Graphics.UI.Gtk as Gtk+{- import Graphics.UI.Gtk.OpenGL import qualified Graphics.Rendering.OpenGL as G import Graphics.Rendering.OpenGL hiding (Sink,get)@@ -42,6 +46,7 @@ -- For textures import Data.Bitmap.OpenGL import Codec.Image.STB+-}  -- From vector-space import Data.VectorSpace@@ -50,7 +55,7 @@ import Data.Title import Data.Pair import Data.Lambda-import Control.Compose (ToOI(..),Cofunctor(..),Flip(..))+import Control.Compose (ToOI(..),ContraFunctor(..),Flip(..))  import Interface.TV @@ -179,24 +184,19 @@  -- Better yet: tweak the representation so that Functor is derived. -instance Cofunctor MkO where-  cofmap f = inMkO (fmap f')+instance ContraFunctor MkO where+  contraFmap f = inMkO (fmap f')    where      f' (wid,sink,cleanup) = (wid, sink . f, cleanup) ---   cofmap f (MkO mk) = MkO (fmap f' mk)+--   contraFmap 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.+-- Note that Functor & ContraFunctor 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@@ -212,15 +212,11 @@   putString = MkO $     do entry <- entryNew        return (toWidget entry, entrySetText entry, return ())-  putShow = putShowC  -- thanks to MkO Cofunctor+  putShow = putShowC  -- thanks to MkO ContraFunctor   putBool = MkO $     do w <- checkButtonNew        return (toWidget w, toggleButtonSetActive w, return ()) --- For temporary use, since OpenGL added a 'set' between 2.2.3.0 and 2.4.0.1-gset :: o -> [AttrOp o] -> IO ()-gset = Gtk.set- boxed :: Orient -> Widget -> Widget -> IO Widget boxed o wa wb =   do box <- boxNew o False 10@@ -297,12 +293,17 @@  -- runMkO name mko = runMkOIO name mko . return +-- WORKING HERE. This new order appears to break the GtkGL examples:+-- +--   (<interactive>:62493): GtkGLExt-CRITICAL **:+--   gtk_widget_get_gl_context: *** Exception: user error (makeNewGObject: object is NULL) + runMkOIO :: String -> MkO a -> IO a -> Action runMkOIO name (MkO mko') mkA = do   forget initGUI-  (wid,sink,cleanup) <- mko'   window <- windowNew+  (wid,sink,cleanup) <- mko'   gset window [ windowDefaultWidth   := 200            -- , windowDefaultHeight  := 200            -- , containerBorderWidth := 10@@ -317,6 +318,33 @@   mainGUI   return () +{-+runMkOIO :: String -> MkO a -> IO a -> Action+runMkOIO name mko mkA = do+  forget initGUI+  window <- windowNew+  wid    <- runMkOWidget mko mkA +  gset window [ windowDefaultWidth   := 200+           -- , windowDefaultHeight  := 200+           -- , containerBorderWidth := 10+              , containerChild       := wid+           -- , windowFocusOnMap     := True       -- helpful?+              , windowTitle          := name+              ]+  forget $ onDestroy window mainQuit+  widgetShowAll window+  -- Initial sink.  Must come after show-all for the GLDrawingArea.+  mainGUI+  return ()++runMkOWidget :: MkO a -> IO a -> IO Widget+runMkOWidget (MkO mko') mkA = do+  (wid,sink,cleanup) <- mko'+  forget $ onDestroyEvent wid (\_ -> cleanup >> return True)+  mkA >>= sink+  return wid+-}+ instance ToOI MkO where   toOI mkO = Flip (runMkO "GtkTV" mkO) @@ -475,7 +503,12 @@ -- by 'pair'), but the DeepArrow dissecting operations will not be able to -- split apart the (pair-valued) integral input. +-- For temporary use, since OpenGL added a 'set' between 2.2.3.0 and 2.4.0.1+gset :: o -> [AttrOp o] -> IO ()+gset = Gtk.set +{-+ {--------------------------------------------------------------------     GtkGL stuff --------------------------------------------------------------------}@@ -559,18 +592,6 @@ -- 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 @@ -606,7 +627,20 @@                                         refresh      return (toWidget w, readIORef current, return (), install) +-} ++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+            )++ -- TODO: Replace the error message with a GUI version.  -- We're freeing the old thingie before saving the new thingie.  In a@@ -624,3 +658,7 @@ forget :: Functor f => f a -> f () forget = (() <$) -- forget = fmap (const ())++forget2 :: Monad m => (w -> a -> m b) -> (w -> a -> m ())+forget2 = (result.result) ( >> return ())+-- forget2 h w a = h w a >> return ()
src/test.hs view
@@ -3,7 +3,7 @@ ---------------------------------------------------------------------- -- | -- Module      :  test--- Copyright   :  (c) Conal Elliott 2009+-- Copyright   :  (c) Conal Elliott 2009-2011 -- License     :  BSD3 --  -- Maintainer  :  conal@conal.net@@ -12,30 +12,16 @@ -- Test GtkTV ---------------------------------------------------------------------- -import Control.Arrow ((&&&))--import Interface.TV.Gtk     -- or Gtk2-import Control.Arrow.DeepArrow-import Data.FunArr+import Interface.TV.Gtk2     -- or Gtk+import Control.Arrow.DeepArrow (uncurryA)+import Data.FunArr (($$))  import Data.Lambda (lambda) -- or use oLambda import Data.Pair   (pair)   -- or use iPair, oPair import Data.Title  (title)  -- or use iTitle, oTitle --- import Interface.TV (tv,runTV,boolIn,stringOut,oLambda)--- import Interface.TV.Gtk (In,Out,gtv,R,sliderRI,sliderII) -import Graphics.Rendering.OpenGL hiding (Sink,get)- {---------------------------------------------------------------------    Misc---------------------------------------------------------------------}--type Action = IO ()-type Sink a = a -> Action---{--------------------------------------------------------------------     Tests --------------------------------------------------------------------} @@ -133,94 +119,3 @@  shoppingPrU :: GTV ((Int,Int) -> Int) shoppingPrU = uncurryA $$ shoppingU---{---------------------------------------------------------------------    Rendering examples---------------------------------------------------------------------}---- Test renderer.--renderGray :: Sink Float-renderGray x' = do -- putStrLn "renderGray"-                   color (Color4 x x x x)-                   renderSquare- where-   x = realToFrac x' :: GLfloat---- 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 :: 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--tv7 :: GTV (R -> Action)-tv7 = tv (lambda iGray renderOut) renderGray---- Oscillate between 0 & 1-osc :: Floating n => n -> n-osc x = (sin x + 1) / 2---- osc = (sin + 1) / 2--- osc = (/ 2) . (+1) . sin--oscTV :: GTV (R -> R)-oscTV = tv (lambda (sliderRIn (0,10) 0) (title "osc" defaultOut)) osc--clockTV :: GTV (R -> R)-clockTV = tv (lambda clockIn defaultOut) id--clockOscTV :: GTV (R -> R)-clockOscTV = clockTV ->| oscTV--tv8 :: GTV (R -> Action)-tv8 = tv (lambda clockIn renderOut) (renderGray . osc)--tv8' :: GTV (R -> Action)--- tv8' = clockOscTV ->| tv7-tv8' = clockTV ->| oscTV ->| tv7--tv9 :: GTV (R -> (R,Action))-tv9 = tv (lambda clockIn (title "osc" defaultOut `pair` renderOut)) ((id &&& renderGray) . osc)---- TODO: refactor tv9--tv10 :: GTV (R -> (Action,Action))-tv10 = result dupA $$ tv7--tv11 :: GTV (R -> Action, R -> Action)-tv11 = dupA $$ tv7--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