diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bogre-banana.cabal b/bogre-banana.cabal new file mode 100644 --- /dev/null +++ b/bogre-banana.cabal @@ -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 + diff --git a/src/BB/Examples/Snake.hs b/src/BB/Examples/Snake.hs new file mode 100644 --- /dev/null +++ b/src/BB/Examples/Snake.hs @@ -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 () + + + diff --git a/src/BB/Types.hs b/src/BB/Types.hs new file mode 100644 --- /dev/null +++ b/src/BB/Types.hs @@ -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 + diff --git a/src/BB/Util/Vec.hs b/src/BB/Util/Vec.hs new file mode 100644 --- /dev/null +++ b/src/BB/Util/Vec.hs @@ -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 + + + + + diff --git a/src/BB/Workarounds.hs b/src/BB/Workarounds.hs new file mode 100644 --- /dev/null +++ b/src/BB/Workarounds.hs @@ -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 + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 + + diff --git a/src/Reactive/Banana/BOGRE.hs b/src/Reactive/Banana/BOGRE.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/BOGRE.hs @@ -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) + + + + + + + diff --git a/src/Reactive/Banana/BOGRE/OGRE.hs b/src/Reactive/Banana/BOGRE/OGRE.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/BOGRE/OGRE.hs @@ -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)) -} + + + + + + + + + diff --git a/src/Reactive/Banana/BOGRE/OIS.hs b/src/Reactive/Banana/BOGRE/OIS.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/BOGRE/OIS.hs @@ -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 + + + + + + diff --git a/src/Workarounds/BB/Types.hs b/src/Workarounds/BB/Types.hs new file mode 100644 --- /dev/null +++ b/src/Workarounds/BB/Types.hs @@ -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 + diff --git a/src/Workarounds/BB/Workarounds.hs b/src/Workarounds/BB/Workarounds.hs new file mode 100644 --- /dev/null +++ b/src/Workarounds/BB/Workarounds.hs @@ -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 + diff --git a/src/Workarounds/cbits/Workarounds.cpp b/src/Workarounds/cbits/Workarounds.cpp new file mode 100644 --- /dev/null +++ b/src/Workarounds/cbits/Workarounds.cpp @@ -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); +} + diff --git a/src/Workarounds/cbits/Workarounds.h b/src/Workarounds/cbits/Workarounds.h new file mode 100644 --- /dev/null +++ b/src/Workarounds/cbits/Workarounds.h @@ -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 + diff --git a/src/Workarounds/cpp/Workarounds.h b/src/Workarounds/cpp/Workarounds.h new file mode 100644 --- /dev/null +++ b/src/Workarounds/cpp/Workarounds.h @@ -0,0 +1,45 @@ +#include +#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; + }; +}; diff --git a/src/Workarounds/interface/Workarounds.gr b/src/Workarounds/interface/Workarounds.gr new file mode 100644 --- /dev/null +++ b/src/Workarounds/interface/Workarounds.gr @@ -0,0 +1,1 @@ +MyWorkaroundFunctions| diff --git a/src/Workarounds/interface/Workarounds.if b/src/Workarounds/interface/Workarounds.if new file mode 100644 --- /dev/null +++ b/src/Workarounds/interface/Workarounds.if @@ -0,0 +1,3 @@ +@exclude +new +delete diff --git a/src/Workarounds/makefile b/src/Workarounds/makefile new file mode 100644 --- /dev/null +++ b/src/Workarounds/makefile @@ -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 /#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