Reactive.hs

   
----------------------------------------------------------------------
-- |
-- Module      :  Graphics.SceneGraph.Reactive
-- Copyright   :  (c) Mark Wassell 2008
-- License     :  LGPL
-- 
-- Maintainer  :  mwassell@bigpond.net.au
-- Stability   :  experimental
-- Portability :  portable
-- 
-- This module provides the ability to 'enliven' a scene with widgets
-- which act as sources of events and are sinks. For example button widgets
-- and text string display areas.
--
-- runSceneReactive takes a scene and an instance of SGM monad. The latter
-- would have been built up to provide a series of actions to enliven
-- the scene. The monad is run prior to passing the scene to the viewport 
-- engine.
----------------------------------------------------------------------

module Graphics.SceneGraph.Reactive where

import Data.Reactive
import Graphics.SceneGraph.Basic
import Control.Monad.State
import Control.Concurrent.MVar
import Graphics.SceneGraph.MySTM
import Graphics.SceneGraph.SimpleViewport
import Data.IORef
import Graphics.Rendering.OpenGL.GL.BasicTypes (GLdouble)
import Data.Graph.Inductive (Node)

import Graphics.SceneGraph.SimpleViewport (GSRef,GraphicsState(..))

data Widget = Button Scene | Slider Scene | Wheel Scene  | WText Scene


{-- 
   The widget building functions below assume the following structure in the 
   scene graph for the following widgets:
   
        Simple Button:   Handler -> Switch -> Material -> Sphere
                                           -> Material -> Sphere

        Button -> Group -> Group -> Transform -> Material -> Transform -> Torus
                                    Transform -> Material -> Cube
                        -> Transform -> Simple Button

        Slider == Same as button in structure BUT has a different output and the button can slide.
 
        Text = Text 
--}

-- | This monad allows us to compose widget building actions on the scene.
type SGM  = StateT (Scene,MVar Bool ,GSRef) IO


getNodeByLabel :: String -> SGM Node
getNodeByLabel lbl = do
                       ((sg,_),_,_) <- get
                       return $ getByLabel sg lbl

-- | Turn the supplied node into an button style widget
-- Int needs to reference a handler
mkButton :: Int -> SGM (Event Bool)
mkButton nde = do
             ((sg,start),sem,ref) <- get
             let nde' = findHandlerDown sg nde
             -- lift $ putStrLn $ "handler " ++ show nde'
             (ev,snk') <- lift $ mkEvent
             let snk _ = snk' True
             let (SceneNode ide (Handler (Just (f,_)) dh)) = llab sg nde'
                 sg' = replaceNode'' sg (SceneNode ide (Handler (Just (f,snk)) dh ))
             put ((sg',start),sem,ref)
             return $ ev

-- | Turn the referenced node into a slider style widget
mkSlider :: Int -> SGM (Event GLdouble)
mkSlider nde = do
             ((sg,start),sem,ref) <- get
             (ev,snk) <- lift $ mkEvent
             let (SceneNode ide (Handler ch (Just (f,_)))) = llab sg nde
                 sg' = replaceNode'' sg (SceneNode ide (Handler ch (Just (f,snk)) ))
             put ((sg',start),sem,ref)
             return $ ev


doText ::  Int  -> MVar Bool -> GSRef ->  Sink String
doText nde sem ref a = updateNode nde sem ref (Text $ a)

updateNode :: Node -> MVar Bool -> IORef GraphicsState -> SceneData -> IO ()
updateNode nde sem ref dte = atomically sem $ do 
                          gs <- readIORef ref
                          case gsScene gs of
                                 Just (gr,start) -> do
                                                let   (SceneNode lab _) = llab gr nde
                                                      gr' = replaceNode'' gr (SceneNode lab dte)
                                                writeIORef ref (gs { gsDisplayList=Nothing,gsScene = Just (gr',start)})
                                                return ()
                                 _ -> return ()

-- | Turn the referenced node into a text sink widget
mkText ::  Int -> SGM (Sink String)
mkText nde = do
             ((sg,_),sem,ref) <- get
             let nde' = findTextDown sg nde
             return $ doText nde' sem ref


-- | Run a scene with supplied Event Action builder
runSceneReactive :: Scene -> SGM (Event Action) -> IO ()
runSceneReactive scene sr  = do
           sem <- newMVar True
           ref <- newTVar newState
           
           -- We have pass sem and ref as these are need when the widgets are 
           -- doing something when we run the scene.
           (x, (scene',sem,ref)) <- runStateT sr  (scene,sem,ref)
           modifyIORef ref  (\s -> s { gsScene = Just scene' })
           forkE x

           setupGUI sem ref