{- 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