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