bogre-banana (empty) → 0.0.1
raw patch · 19 files changed
+1325/−0 lines, 19 filesdep +basedep +hogredep +hoissetup-changed
Dependencies added: base, hogre, hois, monad-control, random, reactive-banana
Files
- LICENSE +24/−0
- Setup.hs +2/−0
- bogre-banana.cabal +59/−0
- src/BB/Examples/Snake.hs +82/−0
- src/BB/Types.hs +16/−0
- src/BB/Util/Vec.hs +71/−0
- src/BB/Workarounds.hs +43/−0
- src/Main.hs +22/−0
- src/Reactive/Banana/BOGRE.hs +493/−0
- src/Reactive/Banana/BOGRE/OGRE.hs +170/−0
- src/Reactive/Banana/BOGRE/OIS.hs +141/−0
- src/Workarounds/BB/Types.hs +13/−0
- src/Workarounds/BB/Workarounds.hs +43/−0
- src/Workarounds/cbits/Workarounds.cpp +42/−0
- src/Workarounds/cbits/Workarounds.h +27/−0
- src/Workarounds/cpp/Workarounds.h +45/−0
- src/Workarounds/interface/Workarounds.gr +1/−0
- src/Workarounds/interface/Workarounds.if +3/−0
- src/Workarounds/makefile +28/−0
+ LICENSE view
@@ -0,0 +1,24 @@+Copyright (c) 2013, David Michael Taro Eichmann+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * 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.+ * Neither the name of David Michael Taro Eichmann nor the+ names of its contributors may be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 COPYRIGHT OWNER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bogre-banana.cabal view
@@ -0,0 +1,59 @@+name: bogre-banana+description: Boge-Banana is a 3D game engine using the Reactive-Banana FRP library, the HOIS library for input, and the HOGRE library for output. An introductory tutorial is avilable at http:\/\/www.haskell.org\/haskellwiki\/User_talk:DavidE.+category: Game Engine+license: BSD3+license-file: LICENSE+version: 0.0.1+cabal-version: >= 1.4+build-type: Simple+Maintainer: EichmannD at gmail dot com+author: David Eichmann+copyright: David Michael Taro Eichmann++extra-source-files:+ src/Workarounds/makefile+ src/Workarounds/BB/Types.hs+ src/Workarounds/BB/Workarounds.hs+ src/Workarounds/cbits/Workarounds.cpp+ src/Workarounds/cbits/Workarounds.h+ src/Workarounds/cpp/Workarounds.h+ src/Workarounds/interface/Workarounds.gr+ src/Workarounds/interface/Workarounds.if+ +library+ hs-source-dirs: src+ build-depends: + base >= 4,+ base < 5,+ random,+ reactive-banana >= 0.7.1.0,+ hois,+ monad-control,+ hogre+ ghc-options: -Wall+ extensions: ForeignFunctionInterface ImpredicativeTypes+ extra-libraries: stdc+++ C-sources: src/Workarounds/cbits/Workarounds.cpp+ Exposed-modules:+ BB.Util.Vec+ Reactive.Banana.BOGRE+ Reactive.Banana.BOGRE.OIS+ Reactive.Banana.BOGRE.OGRE+ other-modules:+ BB.Types+ BB.Workarounds++executable bogre-banana-snake+ hs-source-dirs: src+ main-is: Main.hs+ build-depends: + base >= 4,+ random,+ hois,+ hogre+ ghc-options: -Wall+ extensions: ForeignFunctionInterface ImpredicativeTypes+ C-sources: ./src/Workarounds/cbits/Workarounds.cpp+ other-modules:+ BB.Examples.Snake+
+ src/BB/Examples/Snake.hs view
@@ -0,0 +1,82 @@+module BB.Examples.Snake+where++import Reactive.Banana+import Reactive.Banana.Frameworks++import Graphics.Ogre.HOgre+import Graphics.Ogre.Types+import OIS.Types++import Reactive.Banana.BOGRE++import BB.Util.Vec+++snake :: IO ()+snake = runGame myGame++-- init the world and return the FRP network+initWorld :: Frameworks t => HookedBogreSystem t -> SceneManager -> IO (SceneNode, SceneNode)+initWorld bs smgr = do+ -- create a light+ l <- sceneManager_createLight_SceneManagerPcharP smgr "MainLight"+ light_setPosition_LightPfloatfloatfloat l 0 0 500+ + -- default camera+ cam <- sceneManager_getCamera smgr "PlayerCam"+ camera_setPosition_CameraPfloatfloatfloat cam 0 0 1000+ + -- create first head and target+ head0 <- liftIO $ addEntity bs "ogrehead.mesh"+ target <- liftIO $ addEntity bs "ogrehead.mesh"+ + return (head0, target)+++myGame :: Frameworks t => GameBuilder t+myGame bs smgr = do+ -- init the world+ (head0, target)<- liftIO $ initWorld bs smgr+ + -- keyboard control+ let speed = 200+ let velB = stepper (0,0,0) ((scale speed) <$> (+ ((0,1,0) <$ (getKeyDownE bs KC_UP)) `union`+ ((0,-1,0) <$ (getKeyDownE bs KC_DOWN)) `union`+ ((-1,0,0) <$ (getKeyDownE bs KC_LEFT)) `union`+ ((1,0,0) <$ (getKeyDownE bs KC_RIGHT)) `union`+ ((0,0,-1) <$ (getKeyDownE bs KC_G)) `union`+ ((0,0,1) <$ (getKeyDownE bs KC_B))+ ))+ let head0PosB = velocityToPositionB bs (0,0,0) velB+ setPosB bs head0 head0PosB+ + -- random bounded positions for target+ randomVec3 <- getRandomVec3B+ let randomTargetPosB = ((sub (boxWidthH,boxWidthH,boxWidthH)) . (scale boxWidth)) <$> randomVec3 where+ boxWidthH = 150+ boxWidth = 2*boxWidthH+ + + -- target position changes on collision+ initTargetPos <- initial randomTargetPosB+ targetHitE <- sphereCollisionsE bs 40 head0 target+ let targetPosB = stepper initTargetPos (randomTargetPosB <@ targetHitE) where+ setPosB bs target targetPosB+ + -- dynamically add heads+ newHeadE <- createNodeOnE bs ("ogrehead.mesh" <$ targetHitE)+ -- delay heads+ let headCountB = accumB 1 ((+1) <$ newHeadE)+ let headsDelaysE = (((,) . (*0.2)) <$> headCountB) <@> newHeadE+ delayedB <- getDynamicDelayedPosBs bs head0PosB headsDelaysE+ setDynamicPosBs bs delayedB+ + -- stop on escape key+ let escE = getKeyDownE bs KC_ESCAPE+ reactimate $ (stopBogre bs) <$ escE+ return ()+ + +
+ src/BB/Types.hs view
@@ -0,0 +1,16 @@+module BB.Types+where++import qualified Graphics.Ogre.Types+import qualified OIS.Types++import Foreign+import Foreign.C.String+import Foreign.C.Types++type CBool = CChar -- correct?++type OIS__Mouse = OIS.Types.Mouse+type Ogre__RenderWindow = Graphics.Ogre.Types.RenderWindow+type Ogre__Vector3 = Graphics.Ogre.Types.Vector3+
+ src/BB/Util/Vec.hs view
@@ -0,0 +1,71 @@+module BB.Util.Vec (+ Vec3,+ scale,+ add,+ sub,+ to,+ dot,+ norm,+ dist,+ sqrNorm,+ sqrDist,+ unit,+ vecSum+) where+++type Vec3 = (Float, Float, Float)++-- helper++apply :: (Float -> Float) -> Vec3 -> Vec3+apply fn (x,y,z) = (fn x, fn y, fn z)++impose :: (Float -> Float -> Float) -> Vec3 -> Vec3 -> Vec3+impose fn (x1,y1,z1) (x2,y2,z2) = (fn x1 x2, fn y1 y2, fn z1 z2)++sum3 :: Vec3 -> Float+sum3 (a,b,c) = sum [a,b,c] ++zero :: Vec3+zero = (0,0,0)++-- exported++scale :: Float -> Vec3 -> Vec3+scale s = apply (*s)++add :: Vec3 -> Vec3 -> Vec3+add = impose (+)++vecSum :: [Vec3] -> Vec3+vecSum = foldr add zero++to :: Vec3 -> Vec3 -> Vec3+to a b = impose (-) b a++sub :: Vec3 -> Vec3 -> Vec3+sub = flip to++dot :: Vec3 -> Vec3 -> Float+dot a b = sum3 (impose (*) a b)++sqrDist :: Vec3 -> Vec3 -> Float+sqrDist a b = sqrNorm (a `to` b)++dist :: Vec3 -> Vec3 -> Float+dist a b = sqrt (sqrDist a b)++sqrNorm :: Vec3 -> Float+sqrNorm v = v `dot` v++norm :: Vec3 -> Float+norm = sqrt . sqrNorm ++unit :: Vec3 -> Vec3+unit v = scale (1/(norm v)) v++ + + +
+ src/BB/Workarounds.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module BB.Workarounds(+getMouseRelX, +getMouseRelY, +getVector3X, +getVector3Y, +getVector3Z, +getWindowHandler+)++where++import BB.Types+import Control.Monad++import Foreign+import Foreign.C.String+import Foreign.C.Types++foreign import ccall "Workarounds.h MyWorkaroundFunctions_getMouseRelX" c_getMouseRelX :: OIS__Mouse -> IO CInt+getMouseRelX :: OIS__Mouse -> IO Int+getMouseRelX p1 = liftM fromIntegral $ c_getMouseRelX p1++foreign import ccall "Workarounds.h MyWorkaroundFunctions_getMouseRelY" c_getMouseRelY :: OIS__Mouse -> IO CInt+getMouseRelY :: OIS__Mouse -> IO Int+getMouseRelY p1 = liftM fromIntegral $ c_getMouseRelY p1++foreign import ccall "Workarounds.h MyWorkaroundFunctions_getVector3X" c_getVector3X :: Ogre__Vector3 -> IO CFloat+getVector3X :: Ogre__Vector3 -> IO Float+getVector3X p1 = liftM realToFrac $ c_getVector3X p1++foreign import ccall "Workarounds.h MyWorkaroundFunctions_getVector3Y" c_getVector3Y :: Ogre__Vector3 -> IO CFloat+getVector3Y :: Ogre__Vector3 -> IO Float+getVector3Y p1 = liftM realToFrac $ c_getVector3Y p1++foreign import ccall "Workarounds.h MyWorkaroundFunctions_getVector3Z" c_getVector3Z :: Ogre__Vector3 -> IO CFloat+getVector3Z :: Ogre__Vector3 -> IO Float+getVector3Z p1 = liftM realToFrac $ c_getVector3Z p1++foreign import ccall "Workarounds.h MyWorkaroundFunctions_getWindowHandler" c_getWindowHandler :: Ogre__RenderWindow -> IO CSize+getWindowHandler :: Ogre__RenderWindow -> IO Int+getWindowHandler p1 = liftM fromIntegral $ c_getWindowHandler p1+
+ src/Main.hs view
@@ -0,0 +1,22 @@+module Main where++{-+import BB.Examples.KeyInput+import BB.Examples.Hogre01+import BB.Examples.HogreHois01+import BB.Examples.HogreHois02+import BB.Examples.HogreHois03+import BB.Examples.HogreHois04+-}+--import BB.Examples.HogreHois05+import BB.Examples.Snake++--import BB.Workarounds+++main::IO()+main = do+ --hogreHois05+ snake+ +
+ src/Reactive/Banana/BOGRE.hs view
@@ -0,0 +1,493 @@+{-+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)+++++++
+ src/Reactive/Banana/BOGRE/OGRE.hs view
@@ -0,0 +1,170 @@+--+-- Insert Documentation here :-)+--+module Reactive.Banana.BOGRE.OGRE where++++import Reactive.Banana+import Reactive.Banana.Frameworks (+ Frameworks,+ AddHandler,+ fromAddHandler,+ newAddHandler+ )++import Control.Concurrent (+ forkIO+ )+++++import System.Exit+import Control.Monad++import Graphics.Ogre.HOgre+import Graphics.Ogre.Types++import BB.Workarounds+++type Position = (Float,Float,Float)++data World = World {+ worldObject :: SceneNode,+ worldObjectPosition :: Position+ }+ +data DisplaySystem = DisplaySystem {+ window :: RenderWindow,+ root :: Root,+ sceneManager :: SceneManager+ }+++createDisplaySystem :: IO(DisplaySystem)+createDisplaySystem = do+ -- construct Ogre::Root+ root <- root_new "plugins.cfg" "ogre.cfg" "Ogre.log"++ -- setup resources+ root_addResourceLocation root "../Media" "FileSystem" "Group" True+ + -- configure+ -- show the configuration dialog and initialise the system+ restored <- root_restoreConfig root+ when (not restored) $ do+ configured <- root_showConfigDialog root+ when (not configured) $ exitWith (ExitFailure 1)+ window <- root_initialise root True "Render Window" ""+ + -- set default mipmap level (some APIs ignore this)+ root_getTextureManager root >>= \tmgr -> textureManager_setDefaultNumMipmaps tmgr 5+ + -- initialise all resource groups+ resourceGroupManager_getSingletonPtr >>= resourceGroupManager_initialiseAllResourceGroups+ + -- create the scene manager, here a generic one+ smgr <- root_createSceneManager_RootPcharPcharP root "DefaultSceneManager" "Scene Manager"+ + -- create and position the camera+ cam <- sceneManager_createCamera smgr "PlayerCam"+ frustum_setNearClipDistance (toFrustum cam) 5+ + -- create one viewport, entire window+ vp <- renderTarget_addViewport (toRenderTarget window) cam 0 0 0 1 1+ colourValue_with 0 0 0 1 $ viewport_setBackgroundColour vp+ + -- Alter the camera aspect ratio to match the viewport+ vpw <- viewport_getActualWidth vp+ vph <- viewport_getActualHeight vp+ frustum_setAspectRatio (toFrustum cam) (fromIntegral vpw / fromIntegral vph)+ + -- AddHandler for the render Event+ (renderAH, fireRenderEvent) <- newAddHandler+ + return DisplaySystem {+ window = window,+ root = root,+ sceneManager = smgr+ }+ +closeDisplaySystem :: DisplaySystem -> IO ()+closeDisplaySystem = root_delete . root+ +nullHandler :: Root -> Float -> () -> IO ((), Bool)+nullHandler _ _ _ = return ((), True)++addEntity :: DisplaySystem -> String -> IO (Entity, SceneNode)+addEntity ds mesh = do+ let smgr = sceneManager ds+ ent <- sceneManager_createEntity_SceneManagerPcharP smgr mesh+ rootNode <- sceneManager_getRootSceneNode smgr+ node <- sceneManager_createSceneNode_SceneManagerP smgr+ node_addChild (toNode rootNode) (toNode node)+ sceneNode_attachObject node (toMovableObject ent)+ return (ent, node)++getPosition :: SceneNode -> IO (Float, Float, Float)+getPosition sn = do+ pos <- node_getPosition (toNode sn)+ x <- getVector3X pos+ y <- getVector3Y pos+ z <- getVector3Z pos+ return (x,y,z)++setPosition :: SceneNode -> (Float, Float, Float) -> IO ()+setPosition sn (x,y,z) = node_setPosition (toNode sn) x y z++setPositionRelative :: SceneNode -> (Float, Float, Float) -> IO ()+setPositionRelative sn (x,y,z) = node_translate_NodePfloatfloatfloatNodeTransformSpace (toNode sn) x y z TS_WORLD++render :: RenderWindow -> Root -> a -> (Root -> Float -> Float -> a -> IO (a, Bool)) -> IO a+render win root value fun = do+ timer <- root_getTimer root+ time <- timer_getMicroseconds timer+ render' time win root value fun++render' :: Int -> RenderWindow -> Root -> a -> (Root -> Float -> Float -> a -> IO (a, Bool)) -> IO a+render' time win root value fun = + do windowEventUtilities_messagePump+ closed <- renderWindow_isClosed win+ if closed+ then return value+ else do+ success <- root_renderOneFrame_RootP root+ timer <- root_getTimer root+ time' <- timer_getMicroseconds timer+ let tiF = (fromIntegral (time)) / 1000000+ let tfF = (fromIntegral (time')) / 1000000+ (value', cont) <- fun root tiF tfF value+ if success && cont+ then render' time' win root value' fun+ else return value'+++++{-+create3DWindow :: Int -> IO (InputSystem)+create3DWindow hwnd = do+ im <- inputManager_createInputSystem_size_t hwnd+ -- get mouse and keyboard objects+ -- unsafeCoerce instead of static_cast+ mouse <- unsafeCoerce $ inputManager_createInputObject im OISMouse True ""+ keyboard <- unsafeCoerce $ inputManager_createInputObject im OISKeyboard True ""+ -- create the addhandlers+ mouseNewAddHandler <- newAddHandler+ keyboardNewAddHandler <- newAddHandler+ -- done, package into a InputSystem+ return ((keyboard, keyboardNewAddHandler), (mouse, mouseNewAddHandler)) -}+++++++++
+ src/Reactive/Banana/BOGRE/OIS.hs view
@@ -0,0 +1,141 @@+--+-- Insert Documentation here :-)+--+module Reactive.Banana.BOGRE.OIS (+ InputSystem,+ createInputSystem,+ getKeysPressE,+ getMouseE,+ capture,+ KeyCode(..),+ KeysPressed,+ KeyState(..),+ MouseState+) where+++++++import OIS+import OIS.Types hiding (MouseState)++import Reactive.Banana+import Reactive.Banana.Frameworks (+ Frameworks,+ AddHandler,+ fromAddHandler,+ newAddHandler+ )++import Foreign.C.Types (CInt(..))+import Unsafe.Coerce+import Control.Monad (+ filterM+ )+import Control.Concurrent (+ ThreadId,+ threadDelay+ )+ +import BB.Workarounds+++++++type InputSystem = (+ (Keyboard, (AddHandler KeysPressed, KeysPressed -> IO ())),+ (Mouse, (AddHandler MouseState, MouseState -> IO ()))+ )+type KeysPressed = [KeyCode]+type MouseState = (Int, Int) -- relative x and y values++data KeyState = Up | Down+ deriving Eq++createInputSystem :: Int -> IO (InputSystem)+createInputSystem hwnd = do+ im <- inputManager_createInputSystem_size_t hwnd+ -- get mouse and keyboard objects+ -- unsafeCoerce instead of static_cast+ mouse <- unsafeCoerce $ inputManager_createInputObject im OISMouse False ""+ keyboard <- unsafeCoerce $ inputManager_createInputObject im OISKeyboard True ""+ -- create the addhandlers+ mouseNewAddHandler <- newAddHandler+ keyboardNewAddHandler <- newAddHandler+ -- done, package into a InputSystem+ return ((keyboard, keyboardNewAddHandler), (mouse, mouseNewAddHandler))++getKeysPressE :: Frameworks t => InputSystem -> Moment t (Event t KeysPressed)+getKeysPressE is = (fromAddHandler . getKeyboardAddHandler) is++getMouseE :: Frameworks t => InputSystem -> Moment t (Event t MouseState)+getMouseE = fromAddHandler . getMouseAddHandler++-- | Get all the keys currenly down (being pressed)+getKeysPress :: InputSystem -> IO (KeysPressed)+getKeysPress is = filterM (isKeyDown is) allKeyCodes++--+-- some direct polling functions+--++-- call the capture function of all input Objects, and poll for changes+capture :: InputSystem -> IO (MouseState, KeysPressed)+capture is@((kb,_), (ms,_)) = do+ object_capture $ toObject kb + object_capture $ toObject ms+ + -- poll keyboard+ keyPressed <- getKeysPress is+ + -- poll mouse+ relX <- getMouseRelX ms+ relY <- getMouseRelY ms+ return ((relX, relY), keyPressed)++-- Check if a key is down. Note that you should call capture before using isKeyDown+isKeyDown :: InputSystem -> KeyCode -> IO (Bool)+isKeyDown ((kb,_), _) = keyboard_isKeyDown kb++-- Check if a mouse button down. Note that you should call capture before using isKeyDown+isMouseButtonDown :: InputSystem -> KeyCode -> IO (Bool)+isMouseButtonDown ((kb,_), _) = keyboard_isKeyDown kb++--+-- some accessor functions+--++getKeyboardAddHandler :: InputSystem -> AddHandler KeysPressed+getKeyboardAddHandler ((_, (kbah,_)), _) = kbah++getMouseAddHandler :: InputSystem -> AddHandler MouseState+getMouseAddHandler (_, (_, (msah,_))) = msah+ +fireKeyboadEvent :: InputSystem -> KeysPressed -> IO ()+fireKeyboadEvent ((_, (_,kbcb)), _) = kbcb++fireMouseEvent :: InputSystem -> MouseState -> IO ()+fireMouseEvent (_, (_, (_,mscb))) = mscb++-- modify the KeyCodes to be more usable+allKeyCodes :: [KeyCode]+allKeyCodes = [KC_UNASSIGNED,KC_ESCAPE,KC_1,KC_2,KC_3,KC_4,KC_5,KC_6,KC_7,KC_8,KC_9,KC_0,KC_MINUS,KC_EQUALS,KC_BACK,KC_TAB,KC_Q,KC_W,KC_E,KC_R,KC_T,KC_Y,KC_U,KC_I,KC_O,KC_P,KC_LBRACKET,KC_RBRACKET,KC_RETURN,KC_LCONTROL,KC_A,KC_S,KC_D,KC_F,KC_G,KC_H,KC_J,KC_K,KC_L,KC_SEMICOLON,KC_APOSTROPHE,KC_GRAVE,KC_LSHIFT,KC_BACKSLASH,KC_Z,KC_X,KC_C,KC_V,KC_B,KC_N,KC_M,KC_COMMA,KC_PERIOD,KC_SLASH,KC_RSHIFT,KC_MULTIPLY,KC_LMENU,KC_SPACE,KC_CAPITAL,KC_F1,KC_F2,KC_F3,KC_F4,KC_F5,KC_F6,KC_F7,KC_F8,KC_F9,KC_F10,KC_NUMLOCK,KC_SCROLL,KC_NUMPAD7,KC_NUMPAD8,KC_NUMPAD9,KC_SUBTRACT,KC_NUMPAD4,KC_NUMPAD5,KC_NUMPAD6,KC_ADD,KC_NUMPAD1,KC_NUMPAD2,KC_NUMPAD3,KC_NUMPAD0,KC_DECIMAL,KC_OEM_102,KC_F11,KC_F12,KC_F13,KC_F14,KC_F15,KC_KANA,KC_ABNT_C1,KC_CONVERT,KC_NOCONVERT,KC_YEN,KC_ABNT_C2,KC_NUMPADEQUALS,KC_PREVTRACK,KC_AT,KC_COLON,KC_UNDERLINE,KC_KANJI,KC_STOP,KC_AX,KC_UNLABELED,KC_NEXTTRACK,KC_NUMPADENTER,KC_RCONTROL,KC_MUTE,KC_CALCULATOR,KC_PLAYPAUSE,KC_MEDIASTOP,KC_VOLUMEDOWN,KC_VOLUMEUP,KC_WEBHOME,KC_NUMPADCOMMA,KC_DIVIDE,KC_SYSRQ,KC_RMENU,KC_PAUSE,KC_HOME,KC_UP,KC_PGUP,KC_LEFT,KC_RIGHT,KC_END,KC_DOWN,KC_PGDOWN,KC_INSERT,KC_DELETE,KC_LWIN,KC_RWIN,KC_APPS,KC_POWER,KC_SLEEP,KC_WAKE,KC_WEBSEARCH,KC_WEBFAVORITES,KC_WEBREFRESH,KC_WEBSTOP,KC_WEBFORWARD,KC_WEBBACK,KC_MYCOMPUTER,KC_MAIL,KC_MEDIASELECT]++instance Enum KeyCode where+ toEnum = cintToKeyCode . CInt . fromIntegral+ fromEnum = fromIntegral . keyCodeToCInt+instance Eq KeyCode where+ a == b = (fromEnum a) == (fromEnum b)+instance Show KeyCode where+ show = show . fromEnum+-- TODO make KeyCodes instance of Enum and Bounded++++++
+ src/Workarounds/BB/Types.hs view
@@ -0,0 +1,13 @@+module BB.Types+where++import Foreign+import Foreign.C.String+import Foreign.C.Types++type CBool = CChar -- correct?++newtype OIS__Mouse = OIS__Mouse (Ptr OIS__Mouse) -- nullary data type+newtype Ogre__RenderWindow = Ogre__RenderWindow (Ptr Ogre__RenderWindow) -- nullary data type+newtype Ogre__Vector3 = Ogre__Vector3 (Ptr Ogre__Vector3) -- nullary data type+
+ src/Workarounds/BB/Workarounds.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module BB.Workarounds(+getMouseRelX, +getMouseRelY, +getVector3X, +getVector3Y, +getVector3Z, +getWindowHandler+)++where++import BB.Types+import Control.Monad++import Foreign+import Foreign.C.String+import Foreign.C.Types++foreign import ccall "Workarounds.h MyWorkaroundFunctions_getMouseRelX" c_getMouseRelX :: OIS__Mouse -> IO CInt+getMouseRelX :: OIS__Mouse -> IO Int+getMouseRelX p1 = liftM fromIntegral $ c_getMouseRelX p1++foreign import ccall "Workarounds.h MyWorkaroundFunctions_getMouseRelY" c_getMouseRelY :: OIS__Mouse -> IO CInt+getMouseRelY :: OIS__Mouse -> IO Int+getMouseRelY p1 = liftM fromIntegral $ c_getMouseRelY p1++foreign import ccall "Workarounds.h MyWorkaroundFunctions_getVector3X" c_getVector3X :: Ogre__Vector3 -> IO CFloat+getVector3X :: Ogre__Vector3 -> IO Float+getVector3X p1 = liftM realToFrac $ c_getVector3X p1++foreign import ccall "Workarounds.h MyWorkaroundFunctions_getVector3Y" c_getVector3Y :: Ogre__Vector3 -> IO CFloat+getVector3Y :: Ogre__Vector3 -> IO Float+getVector3Y p1 = liftM realToFrac $ c_getVector3Y p1++foreign import ccall "Workarounds.h MyWorkaroundFunctions_getVector3Z" c_getVector3Z :: Ogre__Vector3 -> IO CFloat+getVector3Z :: Ogre__Vector3 -> IO Float+getVector3Z p1 = liftM realToFrac $ c_getVector3Z p1++foreign import ccall "Workarounds.h MyWorkaroundFunctions_getWindowHandler" c_getWindowHandler :: Ogre__RenderWindow -> IO CSize+getWindowHandler :: Ogre__RenderWindow -> IO Int+getWindowHandler p1 = liftM fromIntegral $ c_getWindowHandler p1+
+ src/Workarounds/cbits/Workarounds.cpp view
@@ -0,0 +1,42 @@+#define CGEN_OUTPUT_INTERN+#include "Workarounds.h"+void MyWorkaroundFunctions_delete(MyWorkaroundFunctions* this_ptr)+{+ delete this_ptr;+}++MyWorkaroundFunctions* MyWorkaroundFunctions_new()+{+ return new MyWorkaroundFunctions();+}++int MyWorkaroundFunctions_getMouseRelX(OIS::Mouse* m)+{+ return MyWorkaroundFunctions::getMouseRelX(m);+}++int MyWorkaroundFunctions_getMouseRelY(OIS::Mouse* m)+{+ return MyWorkaroundFunctions::getMouseRelY(m);+}++float MyWorkaroundFunctions_getVector3X(Ogre::Vector3* v)+{+ return MyWorkaroundFunctions::getVector3X(v);+}++float MyWorkaroundFunctions_getVector3Y(Ogre::Vector3* v)+{+ return MyWorkaroundFunctions::getVector3Y(v);+}++float MyWorkaroundFunctions_getVector3Z(Ogre::Vector3* v)+{+ return MyWorkaroundFunctions::getVector3Z(v);+}++size_t MyWorkaroundFunctions_getWindowHandler(Ogre::RenderWindow* win)+{+ return MyWorkaroundFunctions::getWindowHandler(win);+}+
+ src/Workarounds/cbits/Workarounds.h view
@@ -0,0 +1,27 @@+#ifndef CGEN_WORKAROUNDS_H+#define CGEN_WORKAROUNDS_H++#include "../cpp/Workarounds.h"++extern "C"+{+++++#ifdef CGEN_HS+#endif++void MyWorkaroundFunctions_delete(MyWorkaroundFunctions* this_ptr);+MyWorkaroundFunctions* MyWorkaroundFunctions_new();+int MyWorkaroundFunctions_getMouseRelX(OIS::Mouse* m);+int MyWorkaroundFunctions_getMouseRelY(OIS::Mouse* m);+float MyWorkaroundFunctions_getVector3X(Ogre::Vector3* v);+float MyWorkaroundFunctions_getVector3Y(Ogre::Vector3* v);+float MyWorkaroundFunctions_getVector3Z(Ogre::Vector3* v);+size_t MyWorkaroundFunctions_getWindowHandler(Ogre::RenderWindow* win);++}++#endif+
+ src/Workarounds/cpp/Workarounds.h view
@@ -0,0 +1,45 @@+#include <iostream>+#include "OIS/OISMouse.h"+#include "OIS/OISPrereqs.h"+#include "OGRE/OgreRenderWindow.h"++class MyWorkaroundFunctions {+public:++ //+ // OIS+ //+ + static int getMouseRelX(OIS::Mouse* m) {+ int x = m->getMouseState().X.rel;+ return x;+ };+ + static int getMouseRelY(OIS::Mouse* m) {+ int y = m->getMouseState().Y.rel;+ return y;+ };+ + + //+ // OGRE+ //+ + static float getVector3X(Ogre::Vector3* v) {+ return v->x;+ }+ + static float getVector3Y(Ogre::Vector3* v) {+ return v->y;+ }+ + static float getVector3Z(Ogre::Vector3* v) {+ return v->z;+ }+ + static size_t getWindowHandler(Ogre::RenderWindow* win) {+ size_t windowHnd = 0;+ win->getCustomAttribute("WINDOW", &windowHnd);+ return windowHnd;+ };+};
+ src/Workarounds/interface/Workarounds.gr view
@@ -0,0 +1,1 @@+MyWorkaroundFunctions|
+ src/Workarounds/interface/Workarounds.if view
@@ -0,0 +1,3 @@+@exclude+new+delete
+ src/Workarounds/makefile view
@@ -0,0 +1,28 @@+default: clean main++main:+ # generate c code+ cgen -o cbits --header=Workarounds.h --interface=interface/Workarounds.if cpp/Workarounds.h+ # generate graph file+ grgen -o interface/Workarounds.gr --interface=interface/Workarounds.if cpp/Workarounds.h+ # generate haskell+ cgen-hs --inherit interface/Workarounds.gr --interface=interface/Workarounds.if --hierarchy BB. -o BB cbits/*.h+ # copy files+ cp BB/*.hs ../BB+ # modify types to work with HOGRE and HOIS+ sed -i 's/newtype \(.*\)= Ogre__\([a-z,A-Z,0-9]*\).*/type \1 = Graphics.Ogre.Types.\2/g' ../BB/Types.hs+ sed -i 's/newtype \(.*\)= OIS__\([a-z,A-Z,0-9]*\).*/type \1 = OIS.Types.\2/g' ../BB/Types.hs+ sed -i '4i import qualified Graphics.Ogre.Types\nimport qualified OIS.Types\n' ../BB/Types.hs+ sed -i 's/#include <Workarounds.h>/#include "..\/cpp\/Workarounds.h"/g' ./cbits/Workarounds.h+ +clean:+ rm -f -r 'cbits'+ rm -f -r 'BB'+ rm -f -r 'interface/Dfn.gr'+ rm -f -r *.o+ rm -f -r *.hi+ rm -f -r hs/*.o+ rm -f -r hs/*.hi+ rm -f -r *.a+ rm -f -r *.hs+ rm -f main