GtkGLTV (empty) → 0.2.0
raw patch · 6 files changed
+491/−0 lines, 6 filesdep +GtkTVdep +OpenGLdep +basesetup-changed
Dependencies added: GtkTV, OpenGL, base, bitmap, bitmap-opengl, gtk, gtkglext, stb-image, time
Files
- COPYING +25/−0
- GtkGLTV.cabal +38/−0
- Setup.lhs +3/−0
- src/Interface/TV/Gtk/GL.hs +158/−0
- src/Interface/TV/Gtk/GL2.hs +150/−0
- src/test.hs +117/−0
+ COPYING view
@@ -0,0 +1,25 @@+Copyright (c) 2009 Conal Elliott+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. The names of the authors may not be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.+IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ GtkGLTV.cabal view
@@ -0,0 +1,38 @@+Name: GtkGLTV+Version: 0.2.0+Cabal-Version: >= 1.2+Synopsis: OpenGL support for Gtk-based GUIs for Tangible Values+Category: User Interfaces+Description:+ GtkGLTV adds OpenGL support to GtkTV, which is a Gtk back-end for+ tangible values. +Author: Conal Elliott+Maintainer: conal@conal.net+Copyright: (c) 2009-2011 by Conal Elliott+License: BSD3+License-File: COPYING+Stability: experimental+build-type: Simple+extra-source-files:+ src/test.hs+Package-Url: http://code.haskell.org/~conal/code/GtkGLTV+-- 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/GtkGLTV++Library+ hs-Source-Dirs: src+ Extensions:+ Build-Depends: base<5, time, gtk, GtkTV+ , OpenGL, gtkglext, bitmap, bitmap-opengl, stb-image+ Exposed-Modules:+ Interface.TV.Gtk.GL+ Interface.TV.Gtk.GL2+ ghc-options: -Wall++-- I'll keep either Gtk or Gtk2 and drop the other (maybe renaming Gtk2 to Gtk)++-- ghc-prof-options: -prof -auto-all
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ src/Interface/TV/Gtk/GL.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE DoRec, MultiParamTypeClasses, ScopedTypeVariables+ , TypeFamilies+ #-}+{-# OPTIONS_GHC -Wall #-}+-- {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-} -- TEMP+----------------------------------------------------------------------+-- |+-- Module : Interface.TV.Gtk.GL+-- Copyright : (c) Conal Elliott 2009+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Gtk-based GUIs in the TV (tangible value) framework+----------------------------------------------------------------------++module Interface.TV.Gtk.GL+ ( module Interface.TV.Gtk+ , renderOut, emptyTexture, textureIsEmpty, textureIn+ ) where+++import Control.Applicative ((<$>))+import Data.IORef++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++import Interface.TV.Gtk+++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++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.+ forget $ 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/Interface/TV/Gtk/GL2.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Interface.TV.GtkGL2+-- 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.Gtk.GL2+ ( module Interface.TV.Gtk2+ , renderOut, emptyTexture, textureIsEmpty, textureIn+ ) where++import Control.Applicative ((<$>))+import Data.IORef++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++import Interface.TV.Gtk2+++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++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)
+ src/test.hs view
@@ -0,0 +1,117 @@+-- {-# LANGUAGE #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : test+-- Copyright : (c) Conal Elliott 2009-2011+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Test GtkGLTV+----------------------------------------------------------------------++import Control.Arrow ((&&&))++import Interface.TV.Gtk.GL2 -- or Gtk.GL+import Control.Arrow.DeepArrow ((->|),result,dupA)+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)+++{--------------------------------------------------------------------+ 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++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+