packages feed

reactive-glut (empty) → 0.0.1

raw patch · 13 files changed

+626/−0 lines, 13 filesdep +GLUTdep +OpenGLdep +basesetup-changed

Dependencies added: GLUT, OpenGL, base, old-time, reactive, vector-space

Files

+ Makefile view
@@ -0,0 +1,1 @@+include ../conal-cabal-make.inc
+ README view
@@ -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
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ reactive-glut.cabal view
@@ -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: <http://haskell.org/haskellwiki/reactive-glut>+  .+  The module documentation pages have links to colorized source code and+  to wiki pages where you can read and contribute user comments.  Enjoy!+  .+  &#169; 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
+ src/.ghci view
@@ -0,0 +1,2 @@+-- While actively tweaking Reactive, make its sources visible to ghci+-- :set -i../../reactive/src
+ src/CheckTimes.hs view
@@ -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+
+ src/FRP/Reactive/GLUT/Adapter.hs view
@@ -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.+
+ src/FRP/Reactive/GLUT/SimpleGL.hs view
@@ -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
+ src/FRP/Reactive/GLUT/SimpleGfx.hs view
@@ -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) ] )
+ src/FRP/Reactive/GLUT/UI.hs view
@@ -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
+ src/FTest.hs view
@@ -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 }
+ src/Test.hs view
@@ -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)]
+ wikipage.tw view
@@ -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 <code>conal.net</code> 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: '''<tt>darcs get http://conal.net/repos/reactive-glut</tt>'''.+* 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]].