GtkTV 0.1.1 → 0.1.4
raw patch · 4 files changed
+343/−142 lines, 4 filesdep +OpenGLdep +gtkglext
Dependencies added: OpenGL, gtkglext
Files
- GtkTV.cabal +5/−1
- examples/test.hs +0/−83
- src/Interface/TV/Gtk.hs +138/−58
- src/test.hs +200/−0
GtkTV.cabal view
@@ -1,5 +1,5 @@ Name: GtkTV-Version: 0.1.1+Version: 0.1.4 Cabal-Version: >= 1.2 Synopsis: Gtk-based GUIs for Tangible Values Category: User Interfaces@@ -25,8 +25,12 @@ hs-Source-Dirs: src Extensions: Build-Depends: base<5, time, gtk, TypeCompose>=0.6.7, TV+ , OpenGL, gtkglext 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+-- factor out the GL stuff to another package.
− examples/test.hs
@@ -1,83 +0,0 @@--- {-# LANGUAGE #-}-{-# OPTIONS_GHC -Wall #-}-------------------------------------------------------------------------- |--- Module : test--- Copyright : (c) Conal Elliott 2009--- License : BSD3--- --- Maintainer : conal@conal.net--- Stability : experimental--- --- Test GtkTV-------------------------------------------------------------------------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 Interface.TV.Gtk---{--------------------------------------------------------------------- Tests---------------------------------------------------------------------}--i1 :: In R-i1 = title "size" $ sliderRIn (0,10) 3--i2 :: In Bool-i2 = title "happy" $ boolIn False--i3 :: In (R, Bool)-i3 = pair i1 i2--i4 :: In Int-i4 = title "cookies" $ sliderIIn (0,10) 5---- testI i = runOut "test" (lambda i stringOut) show--testI :: Show a => In a -> IO ()---- testI i = runTV (tv (lambda i (stringOut :: Out String)) show)---- The explicit typing is unfortunate here. Alternatively, use gtv or runGTV:--testI i = runGTV (tv (oLambda i showOut) id)---t1,t2,t3,t4,t5 :: IO ()-t1 = testI i1-t2 = testI i2-t3 = testI i3-t4 = testI i4-t5 = testI (pair i1 i4)--o6 :: Out (R -> Bool -> String)-o6 = lambda i1 $ lambda i2 $ stringOut--t6 :: IO ()-t6 = runTV $ tv (title "currying" o6) (curry show)---- t6 = runOut "currying" o6 (\ a b -> show (a,b))--{---t7 = testI TextureIn 0--tryTex str = do allInit - loadTexture' str >>= print- IL.showErrors- showGLErrors--t8 = tryTex "marble-256.png"--main = t6---- With a bogus file, I get errors. With a legit file I get no errors and--- texture 0. Hm! Could 0 be correct? Try applying the texture.---}
src/Interface/TV/Gtk.hs view
@@ -14,9 +14,9 @@ module Interface.TV.Gtk ( -- * TV type specializations- In, Out, GTV, gtv, runGTV+ In, Out, GTV, gtv, runGTV, runOut, runOutIO -- * UI primitives- , R, sliderRIn, sliderIIn, clockIn, fileNameIn+ , R, sliderRIn, sliderIIn, clockIn, fileNameIn, renderOut , module Interface.TV ) where @@ -27,23 +27,18 @@ import Data.Time (getCurrentTime,utctDayTime) +import Graphics.UI.Gtk hiding (Action)+import Graphics.UI.Gtk.OpenGL+import Graphics.Rendering.OpenGL hiding (Sink,get)++-- From TypeCompose import Data.Title import Data.Pair import Data.Lambda--import qualified Control.Compose as C-import Control.Compose (ToOI(..),Cofunctor(..))+import Control.Compose (ToOI(..),Cofunctor(..),Flip(..)) import Interface.TV --- import Interface.TV.Input--- import Interface.TV.Output--- import Interface.TV.Tangible--- import Interface.TV.Common--import Graphics.UI.Gtk -- as Gtk-- {-------------------------------------------------------------------- TV type specializations --------------------------------------------------------------------}@@ -52,40 +47,52 @@ type Out = Output MkI MkO type GTV = TV MkI MkO --- Type specialization of 'tv'+-- | Type specialization of 'tv' gtv :: Out a -> a -> GTV a gtv = tv --- Type specialization of 'runTV'+-- | Type specialization of 'runTV' runGTV :: GTV a -> IO () runGTV = runTV {--------------------------------------------------------------------+ 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 (MkI' a) --- Representation type for 'MkI'. Takes a change call-back and produces a widget and a--- polling operation and a clean-up action.-type MkI' a = IO () -> IO (Widget, IO a, IO ())+-- 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) --- Representation type for 'MkO'. Give a widget and a way to send it new--- info to display and a clean-up action.-type MkO' a = IO (Widget, OI a, IO ())+-- 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. --- | Sink of information-type OI a = a -> IO ()-- instance Functor MkI where fmap f (MkI h) = MkI h' where@@ -115,9 +122,6 @@ onToggled w refresh return (toWidget w, toggleButtonGetActive w, return ()) --- TODO: refactor textI, toggleI. Or eliminate them, and just use--- stringIn, boolIn in their place.- instance CommonOuts MkO where putString = MkO $ do entry <- entryNew@@ -128,34 +132,58 @@ return (toWidget w, toggleButtonSetActive w, return ()) --- | Add post-processing+-- | Add post-processing. (Could use 'fmap' instead, but 'result' is more+-- specifically typed.) result :: (b -> b') -> ((a -> b) -> (a -> b')) result = (.) --- runOut :: String -> Out a -> a -> IO ()--- runOut name out a = runMkO name (output out) a+-- | Add pre-processing.+argument :: (a' -> a) -> ((a -> b) -> (a' -> b))+argument = flip (.) -runMkO :: String -> MkO a -> OI a-runMkO name (MkO mko') a = do+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 initGUI (wid,sink,cleanup) <- mko'- sink a window <- windowNew- set window [ windowDefaultWidth := 200 -- , windowDefaultHeight := 200- -- , containerBorderWidth := 10+ set window [ windowDefaultWidth := 200+ -- , windowDefaultHeight := 200+ -- , containerBorderWidth := 10 , containerChild := wid- , windowFocusOnMap := True -- helpful?+ -- , windowFocusOnMap := True -- helpful? , windowTitle := name ] 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 = C.Flip (runMkO "GtkTV" mkO)+ 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 --------------------------------------------------------------------}@@ -172,7 +200,7 @@ instance Pair MkI where pair (MkI ia) (MkI ob) = MkI $ \ refresh ->- do box <- boxNew Horizontal True 10+ do box <- boxNew Horizontal False 10 (wa,geta,cleana) <- ia refresh (wb,getb,cleanb) <- ob refresh set box [ containerChild := wa , containerChild := wb ]@@ -180,11 +208,11 @@ instance Pair MkO where pair (MkO oa) (MkO ob) = MkO $- do box <- boxNew Horizontal True 10+ do box <- boxNew Horizontal False 10 (wa,snka,cleana) <- oa (wb,snkb,cleanb) <- ob set box [ containerChild := wa , containerChild := wb ]- return (toWidget box, \ (a,b) -> snka a >> snkb b, cleana >> cleanb)+ return (toWidget box, snka >+> snkb, cleana >> cleanb) instance Title_f MkI where title_f str (MkI ia) = MkI $ \ refresh ->@@ -206,7 +234,7 @@ instance Lambda MkI MkO where lambda (MkI ia) (MkO ob) = MkO $- mdo box <- boxNew Vertical True 10+ mdo box <- boxNew Vertical False 0 -- 10? reff <- newIORef (error "mkLambda: no function yet") let update = do f <- readIORef reff a <- geta -- note loop@@ -222,9 +250,11 @@ primMkI :: MkI' a -> In a primMkI = iPrim . MkI --- primMkO :: MkO' a -> Out a--- primMkO = oPrim . MkO+-- Currently unused +primMkO :: MkO' a -> Out a+primMkO = oPrim . MkO+ type R = Float -- TODO: Consider using R == Double (for constant folding), while really@@ -236,26 +266,32 @@ 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 :: Eq a => (a -> Double) -> (Double -> a) -> a -> Int+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 $ \ refresh ->- let changeTo getter new =- do old <- getter- -- putStrLn $ "(old,new) ==" ++ show (old,new)- when (old /= new) refresh- in- do w <- hScaleNewWithRange (toD lo) (toD hi) (toD step)- set w [ rangeValue := toD a0, scaleDigits := digits ]- -- Unlike wxHaskell, I guess call-backs aren't attributes in gtk2hs.- let getter = fromD <$> get w rangeValue- onRangeChangeValue w (\ _ x -> changeTo getter (fromD x) >> return False)- -- TODO: experiment with return False vs True- return (toWidget w, getter, return ())+ 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+ changeTo new =+ do old <- readIORef oldRef+ when (old /= new) $+ do refresh+ writeIORef oldRef new+ -- Unlike wxHaskell, I guess call-backs aren't attributes in gtk2hs.+ afterRangeChangeValue w (\ _ x -> changeTo (fromD x) >> return False)+ -- TODO: experiment with return False vs True+ return (toWidget w, getter, return ()) + fileNameIn :: FilePath -> In FilePath fileNameIn start = primMkI $ \ refresh -> do w <- fileChooserButtonNew "Select file" FileChooserActionOpen@@ -272,7 +308,7 @@ -- mkTexture start refresh (BaseG oi) = do ... -- mkTexture _ _ _ = error "mkTexture: not BaseG" --- onEntryActivate :: EntryClass ec => ec -> IO () -> IO (ConnectId ec)+-- onEntryActivate :: EntryClass ec => ec -> Action -> IO (ConnectId ec) -- | A clock that reports time in seconds and updates at the given period -- (in seconds).@@ -298,3 +334,47 @@ time :: IO R time = (fromRational . toRational . utctDayTime) <$> getCurrentTime ++{--------------------------------------------------------------------+ GtkGL stuff+--------------------------------------------------------------------}++-- | 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+ 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 $+ 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 ())+ -- Sync canvas size with GL viewport, and use draw action+ let display draw =+ -- Draw in context+ withGLDrawingArea canvas $ \glwindow ->+ do clear [DepthBuffer, ColorBuffer]+ draw+ -- glWaitVSync+ finish+ glDrawableSwapBuffers glwindow+ writeIORef drawRef draw+ 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??+ readIORef drawRef >>= display+ return True+ return (toWidget canvas, display, return ())
+ src/test.hs view
@@ -0,0 +1,200 @@+-- {-# LANGUAGE #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : test+-- Copyright : (c) Conal Elliott 2009+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Test GtkTV+----------------------------------------------------------------------++import Control.Arrow ((&&&))++import Interface.TV.Gtk+import Control.Arrow.DeepArrow+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+--------------------------------------------------------------------}++i1 :: In R+i1 = title "size" $ sliderRIn (0,10) 3++i2 :: In Bool+i2 = title "happy" $ boolIn False++i3 :: In (R, Bool)+i3 = pair i1 i2++i4 :: In Int+i4 = title "cookies" $ sliderIIn (0,10) 5++-- testI i = runOut "test" (lambda i stringOut) show++testI :: Show a => Sink (In a)++-- testI i = runTV (tv (lambda i (stringOut :: Out String)) show)++-- The explicit typing is unfortunate here. Alternatively, use gtv or runGTV:++testI i = runGTV (tv (oLambda i showOut) id)+++t1,t2,t3,t4,t5 :: Action+t1 = testI i1+t2 = testI i2+t3 = testI i3+t4 = testI i4+t5 = testI (pair i1 i4)++o6 :: Out (R -> Bool -> String)+o6 = lambda i1 $ lambda i2 $ stringOut++tv6 :: GTV (R -> Bool -> String)+tv6 = tv (title "currying" o6) (curry show)++-- t6 = runOut "currying" o6 (\ a b -> show (a,b))++t7 :: Action+t7 = testI $ sliderIIn (0,5) 3 ++t8 :: Action+t8 = testI $ boolIn True++t9 :: Action+t9 = testI $ stringIn "bloop"+++{--------------------------------------------------------------------+ Taken from GuiTV (based on Reactive, Phooey, and wxhaskell)+--------------------------------------------------------------------}++apples, bananas :: CInput Int+apples = title "apples" defaultIn+bananas = title "bananas" defaultIn++total :: Show a => COutput a+total = title "total" showOut++shoppingO :: COutput (Int -> Int -> Int)+shoppingO = title "shopping list" $+ oLambda apples (oLambda bananas total)++shopping :: CTV (Int -> Int -> Int)+shopping = tv shoppingO (+)++-- Uncurried variant+shoppingPr :: CTV ((Int,Int) -> Int)+shoppingPr = tv ( title "shopping list -- curried" $ + oLambda (iPair apples bananas) total )+ (uncurry (+))++-- Or simply use uncurryA+shoppingPr' :: CTV ((Int,Int) -> Int)+shoppingPr' = uncurryA $$ shopping+++-- Sliders instead of default inputs+applesU, bananasU :: In Int+applesU = title "apples" (sliderIIn (0,10) 3)+bananasU = title "bananas" (sliderIIn (0,10) 7)++shoppingUO :: Out (Int -> Int -> Int)+shoppingUO = title "shopping list" $+ oLambda applesU (oLambda bananasU total)++shoppingU :: GTV (Int -> Int -> Int)+shoppingU = tv shoppingUO (+)++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)+ square+ 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+ where+ vert x y = vertex (Vertex3 x y (0 :: GLfloat))+ o = 0.9+++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