diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,1 @@ +include ../conal-cabal-make.inc diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,21 @@ +project-foo [1] is a template for a package, to make it easy to copy & +modify. It uses cabal-make [2] for convenience. It's even equipped with +a darcs repo. Copy the directory ("cp -rp"), "darcs mv" the .cabal file, +edit README and wikipage.tw. Then "darcs update" the changes and add new +content with "make check-add" and "make add-new". When ready, do a "darcs +put" or "make repo". + +Please share any comments & suggestions on the discussion (talk) page at +[1]. + +You can configure, build, and install all in the usual way with Cabal +commands. + + runhaskell Setup.lhs configure + runhaskell Setup.lhs build + runhaskell Setup.lhs install + +References: + +[1] http://haskell.org/haskellwiki/project-foo +[1] http://haskell.org/haskellwiki/cabal-make 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/reactive-glut.cabal b/reactive-glut.cabal new file mode 100644 --- /dev/null +++ b/reactive-glut.cabal @@ -0,0 +1,41 @@ +Name: reactive-glut +Version: 0.0.1 +Cabal-Version: >= 1.2 +Synopsis: Connects Reactive and GLUT +Category: FRP, graphics +Description: + This package contains an adapter that connects OpenGL/GLUT to the + library FRP \"Reactive\". + . + Project wiki page: + . + The module documentation pages have links to colorized source code and + to wiki pages where you can read and contribute user comments. Enjoy! + . + © 2008 by Conal Elliott; BSD3 license. +Author: Conal Elliott +Maintainer: conal@conal.net +Homepage: http://haskell.org/haskellwiki/reactive-glut +Package-Url: http://code.haskell.org/reactive-glut +Copyright: (c) 2008 by Conal Elliott +License: BSD3 +Stability: experimental +build-type: Simple + +Library + hs-Source-Dirs: src + Extensions: + Build-Depends: base, old-time, OpenGL, GLUT, vector-space, reactive >= 0.8.3 + Exposed-Modules: + FRP.Reactive.GLUT.Adapter + Other-Modules: + FRP.Reactive.GLUT.SimpleGL + FRP.Reactive.GLUT.UI + Test +-- Relies on fieldtrip +-- FTest + + ghc-options: -Wall + + +-- ghc-prof-options: -prof -auto-all diff --git a/src/.ghci b/src/.ghci new file mode 100644 --- /dev/null +++ b/src/.ghci @@ -0,0 +1,2 @@ +-- While actively tweaking Reactive, make its sources visible to ghci +-- :set -i../../reactive/src diff --git a/src/CheckTimes.hs b/src/CheckTimes.hs new file mode 100644 --- /dev/null +++ b/src/CheckTimes.hs @@ -0,0 +1,17 @@ +-- Hack to check some timings. Requires some editor magic to format times. + +import Data.List (findIndices) + +ts :: [Float] + +ts = [6.484375,6.5,6.515625,6.53125,6.5625,6.578125,6.59375,6.609375,6.625] + +diffs xs = uncurry subtract `fmap` (xs `zip` tail xs) + +ds = diffs ts + +es = (round . (* 100000)) `fmap` ds + +esi = findIndices (> 20) es +esid = diffs esi + diff --git a/src/FRP/Reactive/GLUT/Adapter.hs b/src/FRP/Reactive/GLUT/Adapter.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/GLUT/Adapter.hs @@ -0,0 +1,109 @@ +{-# OPTIONS -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.GLUT.Adapter +-- Copyright : (c) Conal Elliott 2008 +-- License : BSD3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Connect Reactive + GLUT +---------------------------------------------------------------------- + +module FRP.Reactive.GLUT.Adapter + ( adapt + , Action, Sink + , UI(..) + ) where + +-- import Control.Concurrent (yield) + +import Control.Applicative ((<$>)) +import Control.Monad ((>=>)) + +import qualified Graphics.UI.GLUT as G + +import FRP.Reactive (Behavior,stepper) + +import FRP.Reactive.Internal.Misc (Sink,Action) +import FRP.Reactive.Internal.Clock (makeClock,cGetTime) +import FRP.Reactive.Internal.TVal (makeEvent) +import FRP.Reactive.Internal.Timing (mkUpdater) + +import FRP.Reactive.GLUT.UI +import FRP.Reactive.GLUT.SimpleGL + +-- | Adapter to connect @FRP.Reactive@ with @GLUT@. +adapt :: String -> Sink (UI -> Behavior Action) +adapt title f = + do initGfx title + clock <- makeClock + let mkE = makeEvent clock + (mousePosE, mousePosSink ) <- mkE + (leftDown , leftDownSink ) <- mkE + (rightDown, rightDownSink) <- mkE + (keyPress , keyPressSink ) <- mkE + (tick , tickSink ) <- mkE + -- TODO: let the initial mouse position be its actual position + let windowPoint' p = do -- putStrLn $ "window point " ++ show p + windowPoint p + mousePosSink' p = do -- putStrLn $ "mouse " ++ show p + mousePosSink p + -- yield + mousePos = (0.0,0.0) `stepper` mousePosE + mouseCB = Just (windowPoint' >=> mousePosSink') + -- Callbacks + G.passiveMotionCallback G.$= mouseCB + G.motionCallback G.$= mouseCB + G.displayCallback G.$= return () + G.keyboardMouseCallback G.$= Just (\k ks _ _ -> + case (k,ks) of + (G.MouseButton G.LeftButton ,G.Down) -> leftDownSink () + (G.MouseButton G.RightButton,G.Down) -> rightDownSink () + (G.Char c ,G.Down) -> keyPressSink (Char c) + (G.SpecialKey s,G.Down) -> keyPressSink (SpecialKey s) + _ -> return () + ) + updater <- mkUpdater + (cGetTime clock) + (glwrap <$> f (UI mousePos leftDown rightDown keyPress tick)) + schedule (updater >> tickSink ()) + -- putStrLn "mainLoop" + G.mainLoop + +-- TODO: figure out how to exit cleanly. Right now mainLoop never returns +-- killThread programTid +-- exitWith ExitSuccess +-- Better yet, don't kill the process. Instead leave the GL state such +-- that ghci can continue with more graphical yumminess. + + +-- Schedule an action for regular execution. This version uses idle +-- callback. Could instead use a chain of timer call-backs, which could +-- then limit the update rate. (On my Windows machine, I'm getting exactly +-- 64fps most of the time for extremely simple graphics. I guess there's +-- something wired into G.idleCallback. -Conal) + +-- Schedule using idle callback. +scheduleIdle :: Sink Action +scheduleIdle act = G.idleCallback G.$= Just act + +-- Schedule using the timer callback. No matter how small an interval I +-- choose, I still get max 64 frames/sec. +scheduleTimer :: Sink Action +scheduleTimer act = G.addTimerCallback ms (act >> scheduleTimer act) + where + ms = 10 + +-- Schedule an action for repeated execution +schedule :: Sink Action +schedule | useIdle = scheduleIdle + | otherwise = scheduleTimer + +-- Whether to use the 'scheduleIdle' or 'scheduleTimer'. +useIdle :: Bool +useIdle = False + +-- Both schedulers seem to work great. + diff --git a/src/FRP/Reactive/GLUT/SimpleGL.hs b/src/FRP/Reactive/GLUT/SimpleGL.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/GLUT/SimpleGL.hs @@ -0,0 +1,122 @@ +{-# OPTIONS -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.GLUT.SimpleGL +-- Copyright : (c) Conal Elliott 2008 +-- License : BSD3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Simplified GL/GLUT interface +-- +-- With much help from Andy Gill and David Sankel. +---------------------------------------------------------------------- + +module FRP.Reactive.GLUT.SimpleGL (initGfx, glwrap, windowPoint) where + + +import Graphics.UI.GLUT + + +-- Not sure about this, seems to work? (andy) +resizeScene :: Size -> IO () +resizeScene (Size w 0) = resizeScene (Size w 1) -- prevent divide by zero +resizeScene s@(Size width height) = do + -- putStrLn "resizeScene" + viewport $= (Position 0 0, s) + matrixMode $= Projection + loadIdentity + perspective 75 (w2/h2) 0.001 100 + matrixMode $= Modelview 0 + flush + where + w2 = half width + h2 = half height + half z = realToFrac z / 2 + +-- Initialize GL graphics +initGfx :: String -> IO () +initGfx title = do + do getArgsAndInitialize + + initialDisplayMode $= [ DoubleBuffered, RGBAMode, WithDepthBuffer, WithAlphaComponent ] + initialWindowSize $= Size 800 600 + createWindow title + + get windowSize >>= resizeScene + + -- ReverseBlend, Modulate, Blend, LessEqual, Decal, or Replace? + textureFunction $= Modulate + texture Texture2D $= Enabled + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + + blend $= Enabled + blendFunc $= (SrcAlpha, OneMinusSrcAlpha) + + lineSmooth $= Enabled + hint LineSmooth $= Nicest + shadeModel $= Smooth -- enables smooth color shading + + clearColor $= Color4 0 0 0 0 + clearDepth $= 1 -- enables clearing of the depth buffer + depthFunc $= Just Less -- type of depth test + + polygonMode $= (Fill,Fill) -- or Fill,Line + + -- Enable the following if non-uniform scaling will occur + normalize $= Enabled + -- Enable the following if only uniform scaling will occur + -- rescaleNormal $= Enabled + + -- lightModel undefined + -- Set the light up at an infinite distance behind the camera + lighting $= Enabled + position (Light 0) $= Vertex4 1 1 0 1 + light (Light 0) $= Enabled + + position (Light 0) $= Vertex4 0.0 0.0 1.0 0.0 + ambient (Light 0) $= Color4 0.0 0.0 0.0 1.0 + diffuse (Light 0) $= Color4 1.0 1.0 1.0 1.0 + specular (Light 0) $= Color4 1.0 1.0 1.0 1.0 + + -- Material properties + materialSpecular Front $= Color4 1.0 1.0 1.0 1.0 + materialEmission Front $= Color4 0.0 0.0 0.0 1.0 + materialShininess Front $= 70.0 + -- "If colorMaterial is defined, the normal calls to change the + -- material colors don't work and glColor must be used in its place." + -- (camio). + -- + -- colorMaterial $= Just (FrontAndBack,AmbientAndDiffuse) + -- colorMaterial $= Just (FrontAndBack,Specular) + + reshapeCallback $= Just resizeScene + + -- loadIdentity + + +-- | Convert a window position to a logical X,Y. Logical zero is at the +-- origin, and [size??]. +-- +-- TODO: this def is completely broken. What do I even want? Probably to +-- go backward through the viewing transform to the XY plane. +windowPoint :: Position -> IO (Double, Double) +windowPoint (Position x y) = do Size w h <- get windowSize + return (f w x, f h y) + where + -- Scale and translate coordinate. Put zero at the center, and give one + -- unit to 100 pixels. + f _ z = realToFrac z + -- f z maxZ = realToFrac (z - maxZ) / (100 * realToFrac maxZ) + + +-- | Wrap an OpenGL rendering action, to clear the frame-buffer before +-- swap buffers afterward. +glwrap :: IO () -> IO () +glwrap act = do clear [ColorBuffer, DepthBuffer] + -- putStrLn "glwrap" + -- loadIdentity + -- translate (Vector3 0 0 (-3 :: Float)) + act + swapBuffers diff --git a/src/FRP/Reactive/GLUT/SimpleGfx.hs b/src/FRP/Reactive/GLUT/SimpleGfx.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/GLUT/SimpleGfx.hs @@ -0,0 +1,110 @@ +{-# OPTIONS_GHC -Wall #-} + +module FRP.Reactive.GLUT.SimpleGfx + ( initGfx, glwrap, windowPoint + -- remove later + , drawBox + ) where + +import Graphics.UI.GLUT +-- import Graphics.Rendering.OpenGL as GL + +windowWidth, windowHeight :: GLint +windowWidth = 800 -- physical pixels +windowHeight = 600 -- physical pixels + +canvasMinX, canvasMaxX, canvasMinY, canvasMaxY :: Double +canvasMaxX = 400 -- logical units +canvasMinX = -400 -- logical units +canvasMaxY = 300 -- logical units +canvasMinY = -300 -- logical units + +canvasFarZ, canvasNearZ :: GLclampd +canvasFarZ = 4000 +canvasNearZ = -4000 + +-- Initialize GL graphics +initGfx :: String -> IO () +initGfx title = do + -- Glut Part + getArgsAndInitialize + initialWindowSize $= (Size windowWidth windowHeight) + initialDisplayMode $= [DoubleBuffered, RGBAMode] + createWindow title + -- OpenGL Part + shadeModel $= Smooth + lineSmooth $= Enabled + + lighting $= Enabled + -- Needs to be disabled for fieldtrip + -- colorMaterial $= Just (Front,AmbientAndDiffuse) + light (Light 0) $= Enabled + + -- Enable the following if non-uniform scaling will occur + normalize $= Enabled + -- Enable the following if only uniform scaling will occur + -- rescaleNormal $= Enabled + + -- Set the light up at an infinite distance behind the camera + position (Light 0) $= (Vertex4 0.0 0.0 1.0 0.0) + ambient (Light 0) $= (Color4 0.0 0.0 0.0 1.0) + diffuse (Light 0) $= (Color4 1.0 1.0 1.0 1.0) + specular (Light 0) $= (Color4 1.0 1.0 1.0 1.0) + + -- Some simple defaults here. + materialSpecular (Front) $= (Color4 1.0 1.0 1.0 1.0) + materialEmission (Front) $= (Color4 0.0 0.0 0.0 1.0) + materialShininess (Front) $= 70.0 + + blend $= Enabled + blendFunc $= (SrcAlpha, OneMinusSrcAlpha) + lineWidth $= 1.5 + clearColor $= Color4 0 0 0 0 + pointSmooth $= Enabled + -- pointSize $= 5.0 + clearDepth $= canvasFarZ + depthRange $= (canvasNearZ, canvasFarZ) + depthFunc $= Just Lequal + matrixMode $= Projection + loadIdentity + ortho canvasMinX canvasMaxX canvasMinY canvasMaxY canvasNearZ canvasFarZ + matrixMode $= Modelview 0 + loadIdentity + +-- | Convert a window position to a logical X,Y. Logical zero is at the +-- origin, and [size??]. +-- +-- TODO: fix to work with variable window size. +windowPoint :: Position -> IO (Double, Double) +windowPoint (Position x y) = return $ + let pixToLog p minP maxP l u = + let p0to1 = (realToFrac $ p-minP)/(realToFrac $ maxP-minP) + in (p0to1 * (u-l)) + l + in (pixToLog x 0 (windowWidth-1) canvasMinX canvasMaxX, + -(pixToLog y 0 (windowHeight-1) canvasMinY canvasMaxY)) + +-- | Wrap an OpenGL rendering action, to clear the frame-buffer before +-- swap buffers afterward. +glwrap :: IO () -> IO () +glwrap act = do clearScreen (0.0,0.0,0.0) + -- putStrLn "glwrap" + act + swapBuffers + +clearScreen :: (GLdouble, GLdouble, GLdouble) -> IO() +clearScreen (r,g,b) = do + clearColor $= Color4 (realToFrac r) (realToFrac g) (realToFrac b) 0 + clear [ColorBuffer, DepthBuffer] + + +vertexPF :: VertexComponent a => (a,a) -> IO () +vertexPF = vertex . (uncurry Vertex2) + +drawBox :: (MatrixComponent c, Fractional c) => (c, c) -> IO () +drawBox (centerX,centerY) = preservingMatrix $ do + translate $ Vector3 centerX centerY 0.0 + renderPrimitive Polygon (mapM_ vertexPF [ + (-10.0::GLdouble ,-10.0), + (-10.0,10.0), + (10.0,10.0), + (10.0,-10.0) ] ) diff --git a/src/FRP/Reactive/GLUT/UI.hs b/src/FRP/Reactive/GLUT/UI.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/GLUT/UI.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.GLUT.UI +-- Copyright : (c) Conal Elliott 2008 +-- License : BSD3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Simple UI type. +-- +-- Based on code from David Sankel. +---------------------------------------------------------------------- + +module FRP.Reactive.GLUT.UI + ( UI(..) + , Key(..), SpecialKey(..) + , uiIntegral + ) where + +import Control.Applicative (liftA2) +import Graphics.UI.GLUT(SpecialKey(..)) + +import Data.VectorSpace +import FRP.Reactive + +-- | Simple UI type. +data UI = UI { + mousePosition :: Behavior (Double,Double), + leftMousePressed :: Event (), + rightMousePressed :: Event (), + keyPressed :: Event Key, + framePass :: Event () +} + +-- | Key pressed +data Key = Char Char | SpecialKey SpecialKey + +-- | Integral tracking frame sampling +uiIntegral :: VectorSpace v TimeT => + (UI -> Behavior v) -> (UI -> Behavior v) +uiIntegral = liftA2 integral framePass diff --git a/src/FTest.hs b/src/FTest.hs new file mode 100644 --- /dev/null +++ b/src/FTest.hs @@ -0,0 +1,88 @@ +{-# OPTIONS -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : FTest +-- Copyright : (c) Conal Elliott 2008 +-- License : BSD3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Test Reactive + FieldTrip +---------------------------------------------------------------------- + +module FTest where + +import Data.Monoid +import Control.Applicative + +import Graphics.FieldTrip + +import FRP.Reactive (Behavior,time) +import FRP.Reactive.GLUT.Adapter + + +main :: IO () +main = -- anim2 $ pure.pure $ txt + -- anim2 $ pure $ rotTxt <$> time + -- anim2 track + anim3 spin + +txt :: Geometry2 +txt = utext "Reactive + FieldTrip" + +rotTxt :: Double -> Geometry2 +rotTxt t = rotate2 t *% txt + +track :: Anim Geometry2 +track = (fmap.fmap) (f . uncurry Vector2) mousePosition + where + f = (uscale2 (0.5::Float) *%) . utext . show + +spin :: Anim Geometry3 +spin = spinningG $ + -- usphere + torusPair + -- flatG txt + +torusPair :: Geometry3 +torusPair = f red (1/2) `mappend` pivot3X (f green (-1/2)) + where + tor = torus 1 (2/5) + f :: Col -> R -> Geometry3 + f col dx = plasmat col (move3X dx tor) + +---- + +plasmat :: Col -> Filter3 +plasmat col = materialG (plastic col) + +spinningG :: Geometry3 -> Anim Geometry3 +spinningG g env = liftA2 (*%) (spinning env) (pure g) + +spinning :: Anim (Transform3 Double) +spinning = const (xf . (*2) <$> time) + where + xf t = translate3 (Vector3 (0::Double) 0 (3*sin (-t/5))) + `mappend` rotate3 t (Vector3 0.1 0.2 0.3) + `mappend` scale3 0.2 0.2 0.2 + +{-------------------------------------------------------------------- + Move to reactive-fieldtrip +--------------------------------------------------------------------} + +view :: Filter3 +view = move3Z (-3 :: R) + +type Anim a = UI -> Behavior a + +animate :: Sink a -> Sink (Anim a) +animate f anim = adapt "Reactive + FieldTrip" ((fmap.fmap) f anim) + +anim2 :: Sink (Anim Geometry2) +anim2 = anim3 . (fmap.fmap) flatG + +anim3 :: Sink (Anim Geometry3) +anim3 = animate (renderWith3 gc . view) + where + gc = defaultGC { gcErr = 0.005 } diff --git a/src/Test.hs b/src/Test.hs new file mode 100644 --- /dev/null +++ b/src/Test.hs @@ -0,0 +1,53 @@ +{-# OPTIONS -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Test +-- Copyright : (c) Conal Elliott 2008 +-- License : BSD3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Testing out reactive+glut +---------------------------------------------------------------------- + +module Test where + +import Control.Applicative (pure,(<$>)) +import qualified Graphics.UI.GLUT as G + +import FRP.Reactive (Behavior,time) +import FRP.Reactive.GLUT.Adapter + +main :: IO () +main = adapt "Reactive on GLUT" $ (fmap.fmap) view t2 + +type G = UI -> Behavior Action + +t1, t2 :: G + +t1 = const (pure (drawBox (0::Double,0))) + +t2 = const (f <$> time) + where + f t = drawBox (t',t') where t' = t * 1 + + +---- Utilities + +view :: IO () -> IO () +view act = G.preservingMatrix $ + do G.translate (G.Vector3 0 0 (-30 :: Double)) + act + + +vertexPF :: G.VertexComponent a => (a,a) -> IO () +vertexPF = G.vertex . uncurry G.Vertex2 + +drawBox :: (G.MatrixComponent c, Fractional c) => (c, c) -> IO () +drawBox (centerX,centerY) = G.preservingMatrix $ + do G.translate $ G.Vector3 centerX centerY 0 + G.renderPrimitive G.Polygon (mapM_ vertexPF ps) + where + ps :: [(Float,Float)] + ps = [(-1,-1),(-1,1),(1,1),(1,-1)] diff --git a/wikipage.tw b/wikipage.tw new file mode 100644 --- /dev/null +++ b/wikipage.tw @@ -0,0 +1,15 @@ +[[Category:Packages]] + +== Abstract == + +'''reactive-glut''' connects [[Reactive]] with [[OpenGL#Additional_software|GLUT]] and with [[FieldTrip]]. It also serves as a demonstration for how to hook up imperative (i.e., legacy) libraries [[Reactive]]. + +'''Note:''' The conal.net locations below are temporary, while waiting for a project on code.haskell.org. + +Besides this wiki page, here are more ways to find out about reactive-glut: +* Read [http://conal.net/repos/reactive-glut/doc/html/ the library documentation]. +* Get the code repository: '''darcs get http://conal.net/repos/reactive-glut'''. +* Install from [http://hackage.haskell.org/cgi-bin/hackage-scripts/package/reactive-glut Hackage]. +* See the [[reactive-glut/Versions| version history]]. + +Please leave comments at the [[Talk:reactive-glut|Talk page]].