diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -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. + diff --git a/GtkGLTV.cabal b/GtkGLTV.cabal new file mode 100644 --- /dev/null +++ b/GtkGLTV.cabal @@ -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 diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/src/Interface/TV/Gtk/GL.hs b/src/Interface/TV/Gtk/GL.hs new file mode 100644 --- /dev/null +++ b/src/Interface/TV/Gtk/GL.hs @@ -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? diff --git a/src/Interface/TV/Gtk/GL2.hs b/src/Interface/TV/Gtk/GL2.hs new file mode 100644 --- /dev/null +++ b/src/Interface/TV/Gtk/GL2.hs @@ -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) diff --git a/src/test.hs b/src/test.hs new file mode 100644 --- /dev/null +++ b/src/test.hs @@ -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 +