{- Most of the FRP code come from Paul Hudak's book The Haskell School of Expression and has been modified by Maciej Baranski to fit the project purpose -}
module IrrHaskell (
Behavior, Event, Time,
Position, Visible, Display, Model, Rotation, BehaviorValues(Beh,position,rotation,visibility),
undefinedBehavior, behRecord,
undefinedModel,
time, randomB,
untilB, switch,
(=>>), (->>),
when, threshold, while,
(.|.), (.&.),
eventOr, eventAnd,
key, lbp, sample, collision,
step, stepAccum,
constB, lift0, lift1, lift2, lift3, lift4, lift5,
minimumB, maximumB,
fstTriple, sndTriple, trdTriple,
pairB, tripleB, quadB, pentB,
fstB, sndB,
(>*), (<*), (==*), (>=*), (<=*), (&&*), (||*),
snapshot, snapshot_,
distanceBetweenBeh,
createExtrudedMesh,
loadFPSCamera, loadStandardCamera,
loadAmbientLight,
loadCharacters, loadMeshes,
nodePosition, nodeVisibility,
setUp, reactimate
) where
import Irrlicht
import Prelude hiding ( catch )
import Data.Time
import Data.Time.Clock.POSIX
import Data.Time.Clock
import Data.List
import Data.Char
import Memo1
import Control.Concurrent.Chan
import Control.Exception
import System.IO
import System.IO.Unsafe
import System.Random
infixr 1 =>>, ->>
infixr 1 `untilB`, `switch`, `stepAccum`, `step`
infixr 4 <*, >*, ==*, >=*, <=*
infixl 0 .|., .&.
infixr 3 &&*
infixr 2 ||*
type Position = (Int,Int,Int)
type Rotation = (Int,Int,Int)
type Offset = (Float, Float, Float)
type Caption = String
type Counter = Int
type Visible = Bool
type Lives = Int
type Collectables = Int
type Display = (String, String, Bool)
undefinedBehavior = constB undefined
data BehaviorValues = Beh { position :: Behavior Position, rotation :: Behavior Rotation, visibility :: Behavior Visible }
behRecord = Beh { position = undefinedBehavior, rotation = undefinedBehavior, visibility = undefinedBehavior }
type Model = (String, String, Position, BehaviorValues)
undefinedModel = (undefined, undefined, (undefined,undefined,undefined), undefined)
-- FAL FUNCTIONS ----------
type Time = POSIXTime
data EventStruct = EventS { char :: Char, isDown :: Bool, leftButtonDown :: Int }
deriving Show
type UserAction = EventStruct
newtype Behavior a = Behavior (( [Maybe UserAction], [Time] ) -> [a] )
newtype Event a = Event (( [Maybe UserAction], [Time] ) -> [Maybe a] )
time :: Behavior Time
time = Behavior ( \(_,ts) -> ts )
instance Fractional a => Fractional (Behavior a) where
(/) = lift2 (/)
fromRational = lift0 . fromRational
instance Num a => Num (Behavior a) where
(+) = lift2 (+)
(*) = lift2 (*)
negate = lift1 negate
abs = lift1 abs
signum = lift1 signum
fromInteger = lift0 . fromInteger
instance Show (Behavior a) where
showsPrec n a s = "<< Behavior >>"
instance Eq (Behavior a) where
a1 == a2 = error "Can't compare behaviors."
Behavior fb `untilB` Event fe =
memoB $ Behavior (\uts@(us,ts) -> loop us ts (fe uts) (fb uts))
where loop (_:us) (_:ts) ~(e:es) (b:bs) =
b : case e of
Nothing -> loop us ts es bs
Just (Behavior fb') -> fb' (us,ts)
memoB :: Behavior a -> Behavior a
memoB (Behavior fb) = Behavior (memo1 fb)
Behavior fb `switch` Event fe =
memoB $ Behavior (\uts@(us,ts) -> loop us ts (fe uts) (fb uts))
where loop (_:us) (_:ts) ~(e:es) ~(b:bs) =
b : case e of
Nothing -> loop us ts es bs
Just (Behavior fb') -> loop us ts es (fb' (us,ts))
(=>>) :: Event a -> (a->b) -> Event b
Event fe =>> f = Event (map (fmap f) . fe)
e ->> v = e =>> \_ -> v
unique :: (Show a, Eq a) => Event a -> Event a
unique (Event fe) =
Event (\uts -> aux (fe uts))
where aux xs = zipWith remdup (Nothing:xs) xs
remdup x y | x==y = Nothing
| otherwise = y
when :: Behavior Bool -> Event ()
when = unique . while
while :: Behavior Bool -> Event ()
while (Behavior fb)
= Event (\uts -> map aux (fb uts))
where aux True = Just ()
aux False = Nothing
noEvent :: Event () -> Event ()
noEvent (Event e) = Event (\uts -> map aux (e uts))
where aux (Just ()) = Nothing
aux Nothing = Just ()
withElem :: Event a -> [b] -> Event (a,b)
withElem (Event fe) bs = Event (\uts -> loop (fe uts) bs)
where loop (Just a : evs) (b:bs) = Just (a,b) : loop evs bs
loop (Nothing : evs) bs = Nothing : loop evs bs
withElem_ :: Event a -> [b] -> Event b
withElem_ e bs = e `withElem` bs =>> snd
(.|.) :: Event a -> Event a -> Event a
Event fe1 .|. Event fe2
= Event (\uts -> zipWith aux (fe1 uts) (fe2 uts))
where aux Nothing Nothing = Nothing
aux (Just x) _ = Just x
aux _ (Just y) = Just y
(.&.) :: Event () -> Event () -> Event ()
Event fe1 .&. Event fe2
= Event (\uts -> zipWith aux (fe1 uts) (fe2 uts))
where aux (Just()) (Just()) = Just ()
aux _ _ = Nothing
eventOr :: [ Event a ] -> Event a
eventOr evs = foldr (.|.) (Event (\(uas,t) -> (repeat Nothing))) evs
eventAnd :: [ Event () ] -> Event ()
eventAnd evs = foldr (.&.) (Event(\(uas,t) -> (repeat (Just ())))) evs
key :: Event Char
key = unique( Event (\(uas,_) -> map getkey uas) )
where getkey (Just (EventS {char = ch, isDown = tf})) = Just ch
getkey _ = Nothing
lbp :: Event ()
lbp = unique( Event (\(uas,_) -> map getlbp uas) )
where getlbp (Just (EventS { leftButtonDown = 1 })) = Just ()
getlbp _ = Nothing
step :: a -> Event a -> Behavior a
a `step` e = constB a `switch` e =>> constB
stepAccum :: a -> Event (a->a) -> Behavior a
a `stepAccum` e = b
where b = a `step` (e `snapshot` b =>> uncurry ($))
---------------------------
-- LIFTING FUNCTIONS ------
constB :: a -> Behavior a
constB x = Behavior ( \_ -> repeat x )
($*) :: Behavior ( a -> b ) -> Behavior a -> Behavior b
Behavior ff $* Behavior fb = Behavior ( \uts -> zipWith ($) ( ff uts ) ( fb uts ))
lift0 :: a -> Behavior a
lift0 = constB
lift1 :: ( a -> b ) -> ( Behavior a -> Behavior b )
lift1 f b1 = lift0 f $* b1
lift2 :: ( a -> b -> c ) -> ( Behavior a -> Behavior b -> Behavior c )
lift2 f b1 b2 = lift1 f b1 $* b2
lift3 :: (a -> b -> c -> d) -> (Behavior a -> Behavior b -> Behavior c -> Behavior d)
lift3 f b1 b2 b3 = lift2 f b1 b2 $* b3
lift4 :: (a -> b -> c -> d -> e) -> (Behavior a -> Behavior b -> Behavior c -> Behavior d -> Behavior e)
lift4 f b1 b2 b3 b4 = lift3 f b1 b2 b3 $* b4
lift5 :: (a -> b -> c -> d -> e -> f) -> (Behavior a -> Behavior b -> Behavior c -> Behavior d -> Behavior e -> Behavior f)
lift5 f b1 b2 b3 b4 b5 = lift4 f b1 b2 b3 b4 $* b5
---------------------------
-- BEHAVIOR MANIPULATION --
minimumB :: [Behavior Int] -> Int -> Behavior Int
minimumB [] m = constB m
minimumB (b:behs) m = constB 9999 `switch` (sample `snapshot_` b) =>> \x -> if x < m then (minimumB behs x) else (minimumB behs m)
maximumB :: [Behavior Int] -> Int -> Behavior Int
maximumB [] m = constB m
maximumB (b:behs) m = constB 9999 `switch` (sample `snapshot_` b) =>> \x -> if x > m then (maximumB behs x) else (maximumB behs m)
fstTriple :: (a,b,c) -> a
fstTriple (x,_,_) = x
sndTriple :: (a,b,c) -> b
sndTriple (_,y,_) = y
trdTriple :: (a,b,c) -> c
trdTriple (_,_,z) = z
pairB :: Behavior a -> Behavior b -> Behavior (a,b)
pairB = lift2 (,)
tripleB :: Behavior a -> Behavior b -> Behavior c -> Behavior (a,b,c)
tripleB = lift3 (,,)
quadB :: Behavior a -> Behavior b -> Behavior c -> Behavior d -> Behavior (a,b,c,d)
quadB = lift4 (,,,)
pentB :: Behavior a -> Behavior b -> Behavior c -> Behavior d -> Behavior e -> Behavior (a,b,c,d,e)
pentB = lift5 (,,,,)
fstB :: Behavior (a,b) -> Behavior a
fstB = lift1 fst
sndB :: Behavior (a,b) -> Behavior b
sndB = lift1 snd
(>*),(<*), (==*) :: Ord a => Behavior a -> Behavior a -> Behavior Bool
(>*) = lift2 (>)
(<*) = lift2 (<)
(==*) = lift2 (==)
(>=*) = lift2 (>=)
(<=*) = lift2 (<=)
(&&*),(||*) :: Behavior Bool -> Behavior Bool -> Behavior Bool
(&&*) = lift2 (&&)
(||*) = lift2 (||)
---------------------------
-- SNAPSHOT FUNCTIONS -----
snapshot :: Event a -> Behavior b -> Event (a,b)
Event fe `snapshot` Behavior fb
= Event (\uts -> zipWith' aux (fe uts) (fb uts))
where aux (Just x) y = Just (x, y)
aux Nothing _ = Nothing
snapshot_ :: Event a -> Behavior b -> Event b
snapshot_ e b = e `snapshot` b =>> snd
zipWith' f ~(x:xs) ~(y:ys) = f x y : zipWith' f xs ys
---------------------------
-- CUSTOM FUNCTIONS -------
distanceBetweenPoints :: (Integral t, Floating a) => (t, t, t) -> (t, t, t) -> a
distanceBetweenPoints (x,y,z) (a,b,c) = sqrt ( fromInteger ( toInteger ( ( x - a )^2 + ( y - b )^2 + ( z - c )^2 ) ) )
distanceBetweenBeh :: Behavior Position -> Behavior Position -> Behavior Float
distanceBetweenBeh objBeh camBeh = constB 9999.0 `switch` (sample `snapshot_` (pairB objBeh camBeh) =>> \(o,c) -> constB (distanceBetweenPoints o c))
---------------------------
-- IRRLICHT FUNCTIONS -----
data GameChan = GameChan {
eventsChan :: Chan UserAction
}
initGameChan :: IO GameChan
initGameChan = do
eventsChan <- newChan
return GameChan { eventsChan = eventsChan }
runEvent (Event fe) u = fe u
sample :: Event ()
sample = Event (\(us,_) -> map aux us)
where aux Nothing = Just ()
aux (Just _) = Nothing
maybeGetWindowEvent :: GameChan -> IO (Maybe UserAction)
maybeGetWindowEvent gameCh = do
noEvents <- isEmptyChan (eventsChan gameCh)
if noEvents
then return Nothing
else do
event <- readChan (eventsChan gameCh)
if ((char event) == ' ') && ((leftButtonDown event) == 0)
then return Nothing
else return (Just event)
windowUser :: GameChan -> IO (([Maybe UserAction], [POSIXTime]), IO ())
windowUser gameCh = do
(evs, addEv) <- makeStream
t0 <- getPOSIXTime
let loop rt = do
mev <- maybeGetWindowEvent gameCh
case mev of
Nothing -> return ()
Just e -> do addEv (Just e, rt)
loop rt
let addEvents = do
t <- getPOSIXTime
let rt = t - t0
loop rt
addEv (Nothing, rt)
return ((map fst evs, map snd evs), addEvents)
makeStream :: IO ([a], a -> IO ())
makeStream = do
ch <- newChan
contents <- getChanContents ch
return (contents, writeChan ch)
---------------------------
-- EVENT STREAM CREATION --
threshold :: Behavior Bool -> Event ()
threshold beh = unique ( when beh )
collision :: Behavior Float -> [ NodePtr ] -> [ NodePtr ] -> Event ()
collision thresh xnodes ynodes = eventOr [ threshold ( ( distanceBetweenBeh (nodePosition x) (nodePosition y) ) <=* thresh ) | x <- xnodes, y <- ynodes, sceneNodeIsVisible x == 1, sceneNodeIsVisible y == 1 ]
randomB :: Behavior Int
randomB = Behavior (\(uas,_) -> map (\t -> (unsafePerformIO (getStdRandom(randomR (1,1000))) ) ) uas )
---------------------------
-- HASKELL ENGINE FUNC. ---
createExtrudedMesh :: [ (Int,Position) ] -> Position -> IO MeshPtr
createExtrudedMesh vertices (ex,ey,ez) = do
buffer <- sceneCreateMeshBuffer
buffer2 <- pushBackVerticesOne buffer (length vertices) vertices (ex,ey,ez)
buffer3 <- pushBackVerticesTwo buffer (length vertices) vertices (ex,ey,ez)
mesh <- sceneGetMeshFromBuffer buffer3
return mesh
pushBackVerticesOne :: SMeshBufferPtr -> Int -> [ (Int,Position) ] -> Position -> IO SMeshBufferPtr
pushBackVerticesOne buffer num ((i,(vx,vy,vz)):xs) (ex,ey,ez) = if (i == num) then do
newBuffer <- scenePushBackVerticesOne buffer num i vx vy vz ex ey ez
return newBuffer
else do
newBuffer <- scenePushBackVerticesOne buffer num i vx vy vz ex ey ez
pushBackVerticesOne newBuffer num xs (ex,ey,ez)
pushBackVerticesTwo :: SMeshBufferPtr -> Int -> [ (Int,Position) ] -> Position -> IO SMeshBufferPtr
pushBackVerticesTwo buffer num ((i,(vx,vy,vz)):xs) (ex,ey,ez) = if (i == num) then do
newBuffer <- scenePushBackVerticesTwo buffer num i vx vy vz ex ey ez
return newBuffer
else do
newBuffer <- scenePushBackVerticesTwo buffer num i vx vy vz ex ey ez
pushBackVerticesTwo newBuffer num xs (ex,ey,ez)
loadMap :: Model -> IO (NodePtr,MeshPtr)
loadMap (m, mapMesh, (x,y,z), _) = do
catch (fileSystemAddZipFileArchive m) (\e -> do
let err = e :: SomeException
return () )
mesh <- catch (sceneGetMesh mapMesh) (\e -> do
let err = e :: SomeException
return undefined )
node <- catch (sceneAddOctTreeSceneNode mesh) (\e -> do
let err = e :: SomeException
return undefined )
catch (sceneNodeSetPosition (x,y,z) node) (\e -> do
let err = e:: SomeException
return undefined )
return (node,mesh)
loadFPSCamera :: Position -> Position -> IO NodePtr
loadFPSCamera start target = do
camera <- sceneAddCameraSceneNodeFPS
sceneNodeSetPosition start camera
sceneNodeSetTarget target camera
return camera
loadStandardCamera :: Position -> Position -> IO NodePtr
loadStandardCamera start target = do
camera <- sceneAddCameraSceneNode start target
return camera
loadAmbientLight :: (Int,Int,Int,Int) -> IO ()
loadAmbientLight(r,g,b,a) = do
sceneAddAmbientLight(r,g,b,a)
return ()
createCollisionResponse :: (MeshPtr, NodePtr) -> NodePtr -> Position -> Position -> Position -> IO ()
createCollisionResponse (mapMesh, mapNode) camera radius gravity translation = do
-- Selector
selector <- sceneCreateOctreeTriangleSelector mapMesh mapNode 128
sceneNodeSetTriangleSelector selector mapNode
-- Collision Response
anim <- sceneCreateCollisionResponseAnimator selector camera radius gravity translation
sceneNodeAddAnimator camera anim
sceneNodeAnimatorDrop anim
return ()
loadFont :: String -> IO IGUIFontPtr
loadFont path = do
font <- guiGetFont path
return font
setTextWindow :: String -> IGUIFontPtr -> IO ()--IGUIStaticTextPtr
setTextWindow text font = do
textWindow <- guiAddStaticText text 10 10 320 65
guiSetDrawBackground True textWindow
guiSetDrawBorder False textWindow
guiSetBackgroundColor (255, 255, 255, 255) textWindow
guiSetOverrideFont font textWindow
return ()
loadCharacter :: Model -> IO NodePtr
loadCharacter (charMesh, textPath, (x,y,z), _) =
if (charMesh == "sphere")
then do
node <- sceneAddSphereSceneNode 10 (x,y,z)
texture <- videoGetTexture textPath
nodeSetMaterialTexture node texture
return node
else if (charMesh == "cube")
then do
node <- sceneAddCubeSceneNode
texture <- videoGetTexture textPath
nodeSetMaterialTexture node texture
sceneNodeSetPosition (x,y,z) node
sceneNodeSetScale 2 node
return node
else do
mesh <- sceneGetMesh charMesh
node <- sceneAddAnimatedMeshSceneNode mesh
nodeSetMaterialFlag node EMF_LIGHTING False
texture <- videoGetTexture textPath
nodeSetMaterialTexture node texture
sceneNodeSetPosition (x,y,z) node
return node
loadCharacters :: [ Model ] -> IO [ NodePtr ]
loadCharacters characters = sequence [ loadCharacter model | model <- characters ]
loadMesh :: (MeshPtr, String, Position, BehaviorValues) -> IO NodePtr
loadMesh (mesh, text, (x,y,z), beh ) = do
node <- sceneAddMeshSceneNode mesh
sceneNodeSetPosition (x,y,z) node
return node
loadMeshes :: [ (MeshPtr, String, Position, BehaviorValues) ] -> IO [ NodePtr ]
loadMeshes characters = sequence [ loadMesh model | model <- characters ]
sceneNodeGetPosition :: NodePtr -> IO Position
sceneNodeGetPosition node = do
x <- sceneNodeGetPositionX node
y <- sceneNodeGetPositionY node
z <- sceneNodeGetPositionZ node
return (x,y,z)
getNodePositions :: [ NodePtr ] -> [ Position ]
getNodePositions nodes = [ unsafePerformIO (sceneNodeGetPosition n) | n <- nodes ]
getPosition :: NodePtr -> Position
getPosition node = unsafePerformIO (sceneNodeGetPosition node)
---------------------------
-- RENDERING FUNCTIONS ----
renderPosition :: Position -> NodePtr -> IO ()
renderPosition position node = catch (sceneNodeSetPosition position node) (\e -> do
let err = e :: SomeException
return () )
renderRotation :: Rotation -> NodePtr -> IO ()
renderRotation rotation node = catch (sceneNodeSetRotation rotation node) (\e -> do
let err = e :: SomeException
return () )
renderVisibility :: Visible -> NodePtr -> IO ()
renderVisibility visibility node = catch ( sceneNodeSetVisible node visibility ) ( \e -> do
let err = e :: SomeException
return () )
getFont :: String -> IO IGUIFontPtr
getFont path = catch (do
font <- guiGetFont path
return font) (\e -> do
let err = e :: SomeException
return undefined )
setFont :: IGUIFontPtr -> IGUIStaticTextPtr -> IO ()
setFont font window = catch (do
guiSetOverrideFont font window
return () ) (\e -> do
let err = e :: SomeException
return () )
renderText :: String -> IGUIStaticTextPtr -> String -> Bool -> IO ()
renderText text window fontPath disp = if disp == True then catch (do
font <- getFont fontPath
oldText <- guiGetText window
guiSetDrawBackground disp window
if not (text == oldText) then do
guiSetText text window
setFont font window
return ()
else do
return ()
return () ) (\e -> do
let err = e :: SomeException
return () )
else do
guiSetDrawBackground disp window
return ()
createTextDisplay :: IO IGUIStaticTextPtr
createTextDisplay = do
textWindow <- guiAddStaticText "" 10 10 320 65
guiSetDrawBorder False textWindow
return textWindow
---------------------------
nodePosition :: NodePtr -> Behavior Position
nodePosition node = Behavior (\(uas,_) -> map (\t -> unsafePerformIO (sceneNodeGetPosition node)) uas)
nodeVisibility :: NodePtr -> Behavior Int
nodeVisibility node = Behavior (\(uas,_) -> map (\t -> (sceneNodeIsVisible node)) uas)
-- SETUP FUNCTIONS
setUp :: String -> Model -> IO NodePtr -> IO () -> IO NodePtr
setUp title (m, mapMesh, (x,y,z), beh) camNode light = do
device <- irrCreateDevice EDT_OPENGL 800 600 False False False
-- Map
(node,mesh) <- loadMap (m, mapMesh, (x,y,z), beh)
-- Camera
camera <- camNode
-- Selector and Collision Response
catch (createCollisionResponse (mesh,node) camera (30,50,30) (0,-10,0) (0,30,0)) (\e -> do
let err = e :: SomeException
return () )
-- Misc.
deviceSetCursorVisibility False
deviceSetWindowCaption title
return camera
-- REACTIMATE -------------
reactimate :: Behavior Position -> Behavior Display -> [ (NodePtr, BehaviorValues) ] -> IO ()
reactimate camera disp nodeBehs = do
deviceSetEventReceiver 1
gameCh <- initGameChan
window <- createTextDisplay
do
(user,addEvents) <- windowUser gameCh
addEvents
let render (node, Just (cameraPosition, (guiText,font,v), position, rotation, visible) ) = do
renderPosition position node
renderRotation rotation node
renderText guiText window font v
renderVisibility visible node
render (_,Nothing) = return ()
let mapMulti f ~(l:ls) = do
running <- deviceRun
videoBeginScene True True 100 100 100 255
sceneDrawAll
guiDrawAll
mapM_ f l
ch <- getCharEvent
left <- getLeftDown
writeChan (eventsChan gameCh) (EventS {char = ch, isDown = True, leftButtonDown = left })
addEvents
videoEndScene
mapMulti f ls
mapMulti render (transpose [ zip (cycle [node]) (runEvent (sample `snapshot_` (pentB camera disp p r v)) user) | (node, Beh {position = p, rotation = r, visibility = v}) <- nodeBehs] )
deviceDrop