bogre-banana-0.0.1: src/Reactive/Banana/BOGRE.hs
{-
This is a fusion of the OIS and OGRE modules
-}
module Reactive.Banana.BOGRE (
HookedBogreSystem(
displaySystem,
inputSystem,
frameE
),
BogreFrame(..),
frameDt,
frameT,
GameBuilder,
runGame,
stopBogre,
setPosB,
setVelB,
getPositionB,
addEntity,
createNodeOnE,
getDelayedPosB,
getDynamicDelayedPosBs,
setDynamicPosBs,
setDynamicVelBs,
sphereCollisionsE,
getMousePosB,
getMouseVelB,
getKeyStateE,
getKeyDownE,
getKeyUpE,
getTimeB,
getRandomB,
getRandomVec3B,
velocityToPositionB
) where
import Reactive.Banana
import Reactive.Banana.Frameworks
import Reactive.Banana.BOGRE.OIS
import Reactive.Banana.BOGRE.OGRE hiding (addEntity)
import qualified Reactive.Banana.BOGRE.OGRE as OGRE
import Graphics.Ogre.HOgre
import Graphics.Ogre.Types
import BB.Workarounds
import BB.Util.Vec
import System.Random hiding (next)
import Data.Maybe
-- |The tuple of the OGER display system and OIS inputsystem
type BogreSystem = (DisplaySystem, InputSystem)
-- |An up and running boher system. This should only be used internally other than perhaps for accessing the frameE
data Frameworks t => HookedBogreSystem t = HookedBogreSystem {
displaySystem :: DisplaySystem,
inputSystem :: InputSystem,
frameE :: Event t BogreFrame,
_updateWorldE :: Event t BogreFrame -- world is to be updated internally on this event
-- strictly for internal use!
-- This is used to allow Behaviours that are stepped events to be realized in the same frame
}
-- |Gets the keyboard press event for a HookedBogreSystem, Keys are polled at each frame
keysPressE :: Frameworks t => HookedBogreSystem t -> Event t KeysPressed
keysPressE bs = frameKeysPress <$> (frameE bs)
-- |Gets the mouse move event for a HookedBogreSystem. Mouse position is polled at each frame.
mouseMoveE :: Frameworks t => HookedBogreSystem t -> Event t MouseState
mouseMoveE bs = frameMouseMove <$> (frameE bs)
-- |All information captured in a single frame. This includes timing information and captured input information.
data BogreFrame = BogreFrame {
-- |Start time of the frame.
frameTi :: Float,
-- |End time of the frame.
frameTf :: Float,
-- |Relative mouse position from the last frame
frameMouseMove :: MouseState,
-- |List of key codes of currently pressed keyboard keys.
frameKeysPress :: KeysPressed
}
-- |Get the time delta of the frame. This should be thought of as the amount of time that the frame is displayed.
frameDt :: BogreFrame -> Float
frameDt f = (frameTf f) - (frameTi f)
-- |This is the same as frameTf
frameT :: BogreFrame -> Float
frameT = frameTf
-- |This is a dummy frame that can be used, for example, as an initial vlaue for a frame Behaviour. The start time
-- and end time are 0, and there is no input from the user
nullFrame :: BogreFrame
nullFrame = BogreFrame {
frameTi = 0,
frameTf = 0,
frameMouseMove = (0,0),
frameKeysPress = []
}
-- |All games should be described in a function of this type
type GameBuilder t = HookedBogreSystem t -> SceneManager -> Moment t ()
-- |Given a 'GameBuilder', this will setup the Boger system and run the game
runGame :: (forall t. Frameworks t => GameBuilder t) -> IO ()
runGame gameBuilder = do
-- init the display system
ds <- createDisplaySystem
let smgr = sceneManager ds
-- init input system
handle <- getWindowHandler (window ds)
is <- createInputSystem handle
-- default camera
cam <- sceneManager_getCamera smgr "PlayerCam"
camera_setPosition_CameraPfloatfloatfloat cam 0 0 500
camera_lookAt cam 0 0 (-300)
-- default ambient light
colourValue_with 0.5 0.5 0.5 1.0 (sceneManager_setAmbientLight smgr)
-- create frame addhandler
(frameAddHandler, frameFire) <- newAddHandler
(updateWorldAddHandler, updateWorld) <- newAddHandler
let
frameworkNetwork bs = do
hookedBogreSystem <- hookBogerSystem bs frameAddHandler updateWorldAddHandler
gameBuilder hookedBogreSystem smgr
eventNet <- compile $ frameworkNetwork (ds, is)
actuate eventNet
-- A proper mechanism of handeling child threads is needed (withh respect to ending the main thread)
startBogreSync (ds, is) frameFire updateWorld -- this will block the main thread untill the window is closed
-- |Call this function at the end the game to stop the Boger system. This can be done through reactimate as follows
--
--
-- > reactimate $ (stopBogre bs) <$ someEvent@
--
stopBogre :: Frameworks t => HookedBogreSystem t -> IO ()
stopBogre bs = do
-- TODO clean stop
closeDisplaySystem $ displaySystem bs
-- |starts the Boger system and blocks untill 'stopBogre' is called
startBogreSync :: BogreSystem -> (BogreFrame -> IO ()) -> (BogreFrame -> IO ()) -> IO ()
startBogreSync (ds, is) frameFire updateWorld = do
render win r () handler where
win = window ds
r = root ds
handler _ ti tf _ = do
(ms, kp) <- capture is
let frame = BogreFrame{
frameTi = ti,
frameTf = tf,
frameMouseMove = ms,
frameKeysPress = kp
}
frameFire frame
updateWorld frame
return ((), True)
{-
startBogre :: BogreSystem -> (BogreFrame -> IO ()) -> (BogreFrame -> IO ()) -> IO ()
startBogre bs frameFire updateWorld = do
_ <- forkIO $ startBogreSync bs frameFire updateWorld
return ()
-}
-- |Will unhook a 'HookedBogerSystem' so that it is not tied to a Reactive-Banana context 't'
unhookBogerSystem :: Frameworks t => HookedBogreSystem t -> BogreSystem
unhookBogerSystem bs = (displaySystem bs, inputSystem bs)
-- | creates the basic events from the input system (can be done by hand, but using multiple input events causes Reactive-banana
-- to run into memory leaks (e.g. using 2 different frameE to reactimate the same behaviour causes a mem leak))
hookBogerSystem :: Frameworks t => BogreSystem -> AddHandler BogreFrame -> AddHandler BogreFrame -> Moment t (HookedBogreSystem t)
hookBogerSystem (ds,is) frameAddHandler updateWorldAddHandler = do
fE <- fromAddHandler frameAddHandler
uwE <- fromAddHandler updateWorldAddHandler
return HookedBogreSystem {
displaySystem = ds,
inputSystem = is,
frameE = fE,
_updateWorldE = uwE
}
-- |Given a scene node this will get the position as returned by the OGRE engine. Not that this is, conseptually, the nodes position
-- Behaviour if set elsewhere, but there is no guarantee that the behaviors will be equal at all times:
--
-- @
-- setPosB bs node posB1
-- posB2 <- getPositionB node
-- @
--
-- here @posB1@ and @posB2@ may have different values at any given time.
getPositionB :: Frameworks t => SceneNode -> Moment t (Behavior t Vec3)
getPositionB n = fromPoll $ getPosition n
-- |Get's the absolute position of the mouse. The position is not constrained to a window, so can grow indefinetly. The initial
-- mouse position is (0,0,0)
getMousePosB :: Frameworks t => HookedBogreSystem t -> Behavior t Vec3
getMousePosB bs = velocityToPositionB bs (0,0,0) (getMouseVelB bs)
-- |Get's the velocity of the mouse. This is technically the average velocity of the mouse over the current frame
getMouseVelB :: Frameworks t => HookedBogreSystem t -> Behavior t Vec3
getMouseVelB bs = stepper (0,0,0) (frameToVelocity <$> fE) where
sensitivity = 0.5
fE = frameE bs
frameToVelocity f = scale (sensitivity / (frameDt f)) (mouseMoveToVec3 (frameMouseMove f))
mouseMoveToVec3 (x,y) = (fromIntegral x, negate (fromIntegral y), 0)
{-
DYNAMIC FUNCTIONS THAT HANDLE DYNAMICALLY CREATED NODES
Due to not being able to dynamiclaly modify the EventNetwork with currentinput
(e.g. REACTIMATE create new Behaviors and Event based on current Behs/Events)
Implement everything in this dynamic way takign events with new nodes, and then
allow a conversion to non-dynamic version that can simple take the arguments and
artificially create an event for it that just fires once at time 0.
-}
-- |Use this to dynamically create new nodes whenever the passed 'Event' occurs. The resulting 'Event' will contain the newly created node.
-- The value of the passed 'Event' is ignored.
createNodeOnE :: Frameworks t => HookedBogreSystem t -> Event t String -> Moment t (Event t SceneNode)
createNodeOnE bs createOnE = do
let ubs = unhookBogerSystem bs
let
createNode :: Frameworks s => String -> Moment s (SceneNode)
createNode mesh = do
(_,node) <- liftIO $ OGRE.addEntity (fst ubs) mesh
liftIO $ setPosition node (10000000,10000000,10000000)
return node
execute ((\mesh -> FrameworksMoment (createNode mesh)) <$> createOnE)
-- |Set the position of a note to match a given 'Behavior t Vec3' at all times.
setPosB :: Frameworks t => HookedBogreSystem t -> SceneNode -> Behavior t Vec3 -> Moment t ()
setPosB bs node posB = do
let dynamicB = ((:[]) . ((flip (,)) node)) <$> posB
setDynamicPosBs bs dynamicB
-- |Set the velocity of a note to match a given 'Behavior t Vec3' at all times. Not that the velocity 'Behavior' is only sampled
-- at the end of each frame.
setVelB :: Frameworks t => HookedBogreSystem t -> SceneNode -> Behavior t Vec3 -> Moment t ()
setVelB bs node velB = do
let dynamicB = ((:[]) . ((,) node)) <$> velB
setDynamicVelBs bs dynamicB
-- |This will set the velocities of a variable number of nodes according to a 'Behavior' of a list of node-velocity pairs. Use this to
-- set the velocity of dynamically created nodes.
setDynamicVelBs :: Frameworks t => HookedBogreSystem t -> Behavior t [(SceneNode, Vec3)] -> Moment t ()
setDynamicVelBs bs nodeVelB = do
let uwE = _updateWorldE bs
let sampleE = ((\nvs frame -> (frameDt frame, nvs)) <$> nodeVelB) <@> uwE
let
-- covert velocities to change in position
toDPoses :: (Float, [(SceneNode, Vec3)]) -> [(SceneNode, Vec3)]
toDPoses (dt, nodeVels) = map toDPos nodeVels where
toDPos (node, vel) = (node, scale dt vel)
-- move the nodes
doUpdates :: [(SceneNode, Vec3)] -> IO ()
doUpdates nodeDPoses = mapM_ doUpdate nodeDPoses where
doUpdate (node, dPos) = setPositionRelative node dPos
reactimate $ (doUpdates . toDPoses) <$> sampleE
-- |This will set positions of a variable number of nodes according to a 'Behavior' of a list of node-position pairs. Use this to
-- set the position of dynamically created nodes. Note that this has a close relation to the output of 'getDynamicDelayedPosBs'
setDynamicPosBs :: Frameworks t => HookedBogreSystem t -> Behavior t [(Vec3, SceneNode)] -> Moment t ()
setDynamicPosBs bs nodeVelB = do
let uwE = _updateWorldE bs
let sampleE = nodeVelB <@ uwE
let
-- move the nodes
doUpdates :: [(Vec3, SceneNode)] -> IO ()
doUpdates nodeDPoses = mapM_ doUpdate nodeDPoses where
doUpdate (pos, node) = setPosition node pos
reactimate $ doUpdates <$> sampleE
-- | take a behaviour and dynamically create delays. Only the currently needed history is stored, so
-- if a large delay is added, the resulting value will just be the latest recorded value untill history catches up. The passed
-- Event should specify the delays. The output is a behaviour of corresponding delayed Vec3 (latest added delay is at the head of the list)
getDynamicDelayedPosBs :: Frameworks t => HookedBogreSystem t -> Behavior t Vec3 -> Event t (Float, a) -> Moment t (Behavior t [(Vec3, a)])
getDynamicDelayedPosBs bs masterB delayTaggedE = getWithInitDynamicDelayedPositionBs bs masterB [] delayTaggedE
-- |Used internally to implement delayed position behaviors
type DynamicDelayStep a = (BogreFrame, [(Float,Vec3)], Float, [Float], [a], [Vec3])
-- |Used internally to implement delaye
getWithInitDynamicDelayedPositionBs :: Frameworks t => HookedBogreSystem t -> Behavior t Vec3 -> [(Float, a)] -> Event t (Float, a) -> Moment t (Behavior t [(Vec3, a)])
getWithInitDynamicDelayedPositionBs bs masterB initDelaysTaggeed delayTaggedE = do
-- as it may take some time for the history to fill up before the delay can produce values, we need some default temporary value
let defaultVal = (0,0,0)
let initHist = [(0, defaultVal)]
let
-- whenever there is a new delay, dynamically add it to the list
-- as it may take some time for the history to fill up before the delay can produce values,
-- simply set it to defaultVal
addDelay :: (Float, a) -> DynamicDelayStep a -> DynamicDelayStep a
addDelay (newDelay, newTag) (frame, history, maxDelay, delays, tags, delayedVals) = next where
next = (frame, history, maxDelay', delays', tags', delayedVals')
maxDelay' = max maxDelay newDelay
delays' = delays ++ [newDelay]
tags' = tags ++ [newTag]
delayedVals' = delayedVals ++ [defaultVal]
-- whenever there is a change to the master behaviour, add it to the history
-- we assume the behaviour changed at the start of the current frame
-- This also prunes old events that are older than maxDelay
addToHistory :: Vec3 -> DynamicDelayStep a -> DynamicDelayStep a
addToHistory newVal (frame, history, maxDelay, delays, tags, delayedVals) = next where
next = (frame, history', maxDelay, delays, tags, delayedVals)
newValTime = frameTf frame
history' = (newValTime, newVal) : prune history where
-- prune old events
prune [] = []
prune hist'@((a@(at,_)):xs)
| at >= newValTime - maxDelay = a : prune xs
-- save 1 extra element used in derive function --, and a final default value
| otherwise = (head hist'):[] --initHist
-- update the current frame
updateFrame :: BogreFrame -> DynamicDelayStep a -> DynamicDelayStep a
updateFrame frameNew (_, history, maxDelay, delays, tags, delayedVals) = next where
next = (frameNew, history, maxDelay, delays, tags, delayedVals)
-- whenever ready, progress the delayed behaviours to fit the current frame
stepFrame :: DynamicDelayStep a -> DynamicDelayStep a
stepFrame (frame, history, maxDelay, delays, tags, _) = next where
next = (frame, history, maxDelay, delays, tags, delayedVals')
delayedVals' = map derive delays where
time = frameTf frame
histInc = reverse history -- history in increasing time
dt = frameDt frame
derive delay = derivedVel where
delayTime = time-delay
derivedVel = derivedVelInteg
derivedVelInteg | dt == 0 = defaultVal
| otherwise = derive' histInc
derive' [] = error("no previouse event???")
derive' ((_,av):[]) = av
derive' ((at,av):rest@((bt,bv):_))
| bt <= delayTime = derive' rest -- move to first applicable velocity function
-- once pruned, linearly interpolate the position
| at <= delayTime = (scale wa av) `add` (scale wb bv)
| otherwise = av where
dtatb = bt - at
wb = (delayTime - at) / dtatb
wa = 1 - wb
-- convert the output of these functions, to the actual delayed values
getDelayedVals :: DynamicDelayStep a -> [(Vec3, a)]
getDelayedVals (_,_,_,_,tags,dVals) = zip dVals tags
-- frame event
let fE = frameE bs
-- changes to the master behavior Event
masterChangeE <- changes masterB
-- dynamically add a delay Event
-- delayE
let initProps = foldl (flip addDelay) (nullFrame, initHist, 0, [], [], []) initDelaysTaggeed
let stepsB = (accumB initProps (
(addDelay <$> delayTaggedE) `union`
(updateFrame <$> fE) `union`
(addToHistory <$> masterChangeE) `union` -- use previouse time as that is when the behaviour started (at the start of this frame)
(stepFrame <$ fE)
))
let delayedB = getDelayedVals <$> stepsB
return delayedB
-- |Converts a velocity to position 'Behavior'. Note that the velocity is simply sampled at the end of each frame, so if the velocity
-- changes many times in a frame, or was not valid for the duration of that frame, then the resulting posiiton may be inacurate.
velocityToPositionB :: Frameworks t => HookedBogreSystem t -> Vec3 -> Behavior t Vec3 -> Behavior t Vec3
velocityToPositionB bs initPos vel = accumB initPos (add <$> dPosE) where
dPosE = (((flip scale) <$> vel) <@> (frameDt <$> (frameE bs)))
-- |Time delay a position 'Behavior'
getDelayedPosB :: Frameworks t => HookedBogreSystem t -> Behavior t Vec3 -> Float -> Moment t (Behavior t Vec3)
getDelayedPosB bs velB delay = do
dynVelBs <- getWithInitDynamicDelayedPositionBs bs velB [(delay, ())] never
return $ (fst . head) <$> dynVelBs where
{- NOT USED AS VELOCITIES ARE NOT PROPERLLY INTERPOLATED OVER FRAMES
-- |Time delay a velocity 'Behavior'
getDelayedPosB :: Frameworks t => HookedBogreSystem t -> Behavior t Vec3 -> Float -> Moment t (Behavior t Vec3)
getDelayedPosB bs velB delay = do
dynVelBs <- getWithInitDynamicDelayedPositionBs bs velB [(delay, ())] never
return $ (fst . head) <$> dynVelBs where
-}
-- |The current frame time (see 'framT'). Not that as this is a stepped 'Behavior', it only changes after the frame event occurs,
-- so if this is sampled on the frame event, it wall only be the previouse frame's time.
getTimeB :: Frameworks t => HookedBogreSystem t -> Behavior t Float
getTimeB bs = stepper 0 (frameT <$> (frameE bs))
-- |Get the KeyState changes (Up and Down) Event for a single key. Note that only the changes are visible, so the
-- events will always alternate be Up and Down (i.e. there will not be 2 Down events or 2 Up events in sequence)
getKeyStateE :: Frameworks t => HookedBogreSystem t -> KeyCode -> Event t KeyState
getKeyStateE bs key = removeDuplicates myKeyStatesE where
allKeyPressE = keysPressE bs
-- convert to Mouse state (now we have runs of Ups and Downs)
myKeyStatesE = toMouseState <$> allKeyPressE where
toMouseState keysDown | elem key keysDown = Down
| otherwise = Up
-- |Get the key down event, for a given key, that occurs when a key is pushed down.
getKeyDownE :: Frameworks t => HookedBogreSystem t -> KeyCode -> Event t KeyState
getKeyDownE bs key = filterE (== Down) (getKeyStateE bs key)
-- |Get the key up event, for a given key, that occurs when a key is released.
getKeyUpE :: Frameworks t => HookedBogreSystem t -> KeyCode -> Event t KeyState
getKeyUpE bs key = filterE (== Up) (getKeyStateE bs key)
-- |Adds a mesh to the world, given the mesh's file name.
addEntity :: Frameworks t => HookedBogreSystem t -> String -> IO (SceneNode)
addEntity bs meshFileName = fmap snd (OGRE.addEntity (displaySystem bs) meshFileName)
-- |Gets a 'Behavior' or random values. This can be called multiple times to get multiple different random 'Behavior's:
--
-- @
-- r1B <- getRandomB
-- r2B <- getRandomB
-- @
--
-- In this case @r1B@ and @r2B@ will be 2 seperatly generated randome values.
-- Note that values will be generated according to how 'a' is defined as an instance of the 'Random' class.
getRandomB :: (Frameworks t, Random a) => Moment t (Behavior t a)
getRandomB = fromPoll randomIO
-- |Gets a 'Behavior' or random 'Vec3' values. This can be called multiple times to get multiple different random 'Behavior's.
-- The value of each dimention is generated independantly to be a value between 0 and 1.
getRandomVec3B :: Frameworks t => Moment t (Behavior t Vec3)
getRandomVec3B = do
xB <- getRandomB
yB <- getRandomB
zB <- getRandomB
let xyzB = (\x y z -> (x,y,z)) <$> xB <*> yB <*> zB
return xyzB
-- |Checks for collisions at each frame and fires an event when they colide. The 2 position behaviours must move appart before
-- a second event is fired (if the objects colide and stay colidded, only one event will be fired).
sphereCollisionsE :: Frameworks t => HookedBogreSystem t -> Float -> SceneNode -> SceneNode -> Moment t (Event t (SceneNode,SceneNode))
sphereCollisionsE bs radius nodeA nodeB = do
posAB <- getPositionB nodeA
posBB <- getPositionB nodeB
let
collisionE = (nodeA, nodeB) <$ (filterE (\(col,fid) -> col && (fid /= 0)) collideFidE)
collideFidE = accumE (False, -1) (collideFidInc <$> collideE)
collideFidInc col (_, i) = (col, i+1)
collideE = removeDuplicates (isCollidedB <@ uwE)
uwE = _updateWorldE bs
isCollidedB = (<= sqrRadius) <$> (sqrDistB)
sqrDistB = sqrDist <$> posAB <*> posBB
sqrRadius = radius**2
return collisionE
-- |Filters an 'Event' such that the save event only occurse once. i.e. events [1,1,1,2,2,2,1,1,1,4,5,5,4,5,6] would become [1,2,1,4,5,4,5,6]
removeDuplicates :: (Frameworks t, Eq a) => Event t a -> Event t a
removeDuplicates e = dubE where
dubE = (fromJust . fst) <$> (filterE (uncurry (/=)) prevZip)
prevZip = accumE (Nothing,Nothing) ((\curr (prev,_) -> (Just curr, prev)) <$> e)