module Main where
	
import Irrlicht
import Data.Time
import Data.Time.Clock.POSIX
import Memo1
import Control.Concurrent.Chan

--import SOE hiding (Region, Event)
--import qualified SOE as G (Region, Event)
import Animation (picToGraphic)
import Shape
import Picture

import Draw (xWin,yWin,intToFloat)

infixr 1 =>>, ->>
infixr 1 `untilB`, `switch`, `stepAccum`, `step`
infixr 4 <*, >*
infixl 0 .|.
infixr 3 &&*
infixr 2 ||*

type Caption = String
type Counter = Int

caption1, caption2, caption3, caption4 :: Behavior Caption
caption1    = constB "Initial Caption"
caption2	= constB "Any Key Pressed"
caption3    = constB "a Key Pressed"
caption4    = constB "b Key Pressed"

counter1 :: Behavior Counter
counter1    = constB 999

capt1 :: Behavior Caption
capt1 = caption1 `untilB` key ->> caption2

capt2 :: Behavior Caption
capt2 = caption1 `switch` (key =>> \c ->
           case c of 'a' -> caption3
                     'b' -> caption4
                     _   -> caption1  )


countBeh :: Behavior Counter
countBeh = (0 `stepAccum` key ->> (+1)) `untilB` when (time >* 10) ->> counter1

type Time = POSIXTime

data EventStruct = Key {
               char :: Char
             }
  deriving Show

type UserAction = EventStruct

data GameChan = GameChan {
  eventsChan :: Chan UserAction
}

initGameChan :: IO GameChan
initGameChan = do 
            eventsChan <- newChan
            return GameChan {eventsChan = eventsChan }

newtype Behavior a = Behavior (([Maybe UserAction],[Time]) -> [a])

newtype Event a = Event (([Maybe UserAction],[Time]) -> [Maybe a])

time :: Behavior Time
time = Behavior (\(_,ts) -> ts)

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

pairB :: Behavior a -> Behavior b -> Behavior (a,b)
pairB = lift2 (,)

fstB :: Behavior (a,b) -> Behavior a
fstB  = lift1 fst
sndB :: Behavior (a,b) -> Behavior b
sndB  = lift1 snd

shape :: Behavior Shape -> Behavior Region
shape   = lift1 Shape

ell, rec :: Behavior Float -> Behavior Float -> Behavior Region
ell x y = shape (lift2 Ellipse   x y) 
rec x y = shape (lift2 Rectangle x y)

translate :: (Behavior Float, Behavior Float) -> Behavior Region -> Behavior Region
translate (Behavior fx, Behavior fy) (Behavior fp) = Behavior (\uts -> zipWith3 aux (fx uts) (fy uts) (fp uts))
         where aux x y p = Translate (x,y) p

(>*),(<*) :: Ord a => Behavior a -> Behavior a -> Behavior Bool
(>*) = lift2 (>)
(<*) = lift2 (<)

(&&*),(||*) :: Behavior Bool -> Behavior Bool -> Behavior Bool
(&&*) = lift2 (&&)
(||*) = lift2 (||)

over :: Behavior Picture -> Behavior Picture -> Behavior Picture
over = lift2 Over

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

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

key :: Event Char
key = Event (\(uas,_) -> map getkey uas)
      where getkey (Just (Key ch)) = Just ch
            getkey _               = Nothing

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

zipWith' f ~(x:xs) ~(y:ys) = f x y : zipWith' f xs ys

snapshot_ :: Event a -> Behavior b -> Event b
snapshot_ e b = e `snapshot` b =>> snd

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 ($))

reactimate :: GameChan -> Behavior Caption -> IO ()
reactimate gameCh franProg = do 
        (user,addEvents) <- windowUser gameCh
        addEvents
        let drawPic (Just p) = do
                running <- deviceRun
                videoBeginScene True True 255 200 200 200
                sceneDrawAll
                guiDrawAll
                deviceSetWindowCaption (show p)
                ch <- getCharEvent
                writeChan (eventsChan gameCh) (Key { char = ch })
                videoEndScene
                addEvents
            drawPic Nothing  = return ()
        mapM_ drawPic (runEvent (sample `snapshot_` franProg) user)
           
runEvent (Event fe) u = fe u           

sample :: Event ()
sample = Event (\(us,_) -> map aux us)
  where aux Nothing  = Just ()
        aux (Just _) = Nothing

    
-- have to create an instance of channel, globally accessible or something like that, replace Window type
maybeGetWindowEvent :: GameChan -> IO (Maybe UserAction)
maybeGetWindowEvent gameCh = do
    --print "maybeGetWindowEvent"
    noEvents <- isEmptyChan (eventsChan gameCh)
    if noEvents       
        then return Nothing
        else do
            event <- readChan (eventsChan gameCh)
            if ((char event) == ' ')
                then return Nothing
                else return (Just event)

-- adapt windowUser
windowUser :: GameChan -> IO (([Maybe UserAction], [POSIXTime]), IO ())
windowUser gameCh = do 
    (evs, addEv) <- makeStream
    t0 <- getPOSIXTime    
    let loop rt = do
        mev <- maybeGetWindowEvent gameCh
        --print mev
        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)	                

gameLoop t0 gameCh= 
	do
		running <- deviceRun
		videoBeginScene True True 255 200 200 200
		sceneDrawAll
		guiDrawAll

		ch <- getCharEvent
		
		writeChan (eventsChan gameCh) (Key { char = ch })		
		
		videoEndScene
		if (running > 0)
			then gameLoop t0 gameCh
			else return ()

main = do
	irrCreateDevice EDT_OPENGL 640 480 False False False
	fileSystemAddZipFileArchive "/home/maciek/media/map-20kdm2.pk3"
	mesh <- sceneGetMesh "20kdm2.bsp"
	node <- sceneAddOctTreeSceneNode(mesh)
	sceneNodeSetPosition ((-1300), (-144), (-1249)) node
	sceneAddCameraSceneNodeFPS
	deviceSetEventReceiver 1
	
	gameCh <- initGameChan
	
	t0 <- getPOSIXTime
	--gameLoop t0 gameCh
	reactimate gameCh capt2
	deviceDrop