-- Title:    Yampa/SDL Stub
-- Author:   Gerold Meisinger
-- Homepage: http://lambdor.net
-- Date:     June 2010
-- License:  Creative Commons 3.0 BY-NC-SA

module Main where

import IdentityList

import Maybe
import Control.Monad.Loops

import FRP.Yampa              as Yampa
import FRP.Yampa.Geometry
import Graphics.UI.SDL        as SDL
import Graphics.UI.SDL.Events as SDL.Events
import Graphics.UI.SDL.Keysym as SDL.Keysym


-- types --------

type Position2 = Point2  Double
type Velocity2 = Vector2 Double

type Input = [SDL.Event]    -- non-deterministic events from input devices
type Logic = Yampa.Event () -- deterministic events from object processor

data ObjEvents = ObjEvents
    { oeInput :: Input
    , oeLogic :: Logic
    } deriving (Show)

data State = Rectangle Position2 SDL.Rect SDL.Pixel | Debug String
     deriving (Show)

data ObjOutput = ObjOutput
    { ooState         :: State
    , ooKillRequest   :: Yampa.Event ()       -- NoEvent|Event ()
    , ooSpawnRequests :: Yampa.Event [Object]
    }

defaultObjOutput = ObjOutput
    { ooState         = undefined
    , ooKillRequest   = Yampa.NoEvent
    , ooSpawnRequests = Yampa.NoEvent
    }

type Object = SF ObjEvents ObjOutput


-- utility ---------

instance (Show a) => Show (Yampa.Event a) where
    show (Yampa.Event a) = "LogicEvent: " ++ (show a)
    show Yampa.NoEvent   = "NoEvent"

instance Show (SF a b) where
    show sf = "SF"


-- main ---------

main :: IO ()
main = do
    -- Uncomment 'mainSteps' or 'mainLoop'!
    --mainLoop  -- Runs the complete reactimate loop.
    --mainSteps -- Tests each reactimate step individually.
  where
    mainLoop :: IO ()
    mainLoop = do
        reactimate initialize input output (process objs)
        SDL.quit
       where
         playerObj   = playerObject (Point2 16 16)
                                    (SDL.Rect (-8) (-8) 8 8)
                                    (SDL.Pixel 0x00000000)
         obstacleObj = staticObject (Point2 48 48)
                                    (SDL.Rect (-8) (-8) 8 8)
                                    (SDL.Pixel 0x000000FF)
         objs = (listToIL [playerObj, obstacleObj])

    mainSteps :: IO ()
    mainSteps = do
        -- initialize :: IO Input
        -- Poll first 'SDL.Event's (should only be 'LostFocus').
        events <- initialize

        -- input :: IO (DTime, Maybe Input)
        -- Poll 'SDL.Event's at each step (probably []).
        events <- input False

        -- hits :: [(ILKey, State)] -> [ILKey]
        -- Testing player over obstalce => collision event.
        putStrLn $ "hits 1: " ++ (show $ hits $ assocsIL $ fmap ooState oos1)

        -- Testing player over enemy => no event.
        putStrLn $ "hits 2: " ++ (show $ hits $ assocsIL $ fmap ooState oos2)

        -- route :: (Input, IL ObjOutput) -> IL sf -> IL (ObjEvents, sf)
        -- Routes 'key' SDL.Event to all 'Object's and
        -- previous object 'State's, if there are any.

        -- First routing step.
        -- No collision events are checked as there are no 'State's yet.
        putStrLn "first route: "
        --mapM putStrLn $ showILObjEvents $ route ([key], emptyIL) objs
        putStrLn $ show $ assocsIL $ route ([key], emptyIL) objs

        -- Intermediate routing step.
        -- Assuming player over obstacle object => create collision event.
        putStrLn "route step: "
        putStrLn $ show $ assocsIL $ route ([key], oos1) objs

        -- killAndSpawn :: (Input, IL ObjOutput)
        --              -> (Yampa.Event (IL Object -> IL Object))
        -- Kill and spawn new objects corresponding to 'ObjOutput' requests.
        putStr "objs before kill&Spawn: "
        putStrLn $ show $ keysIL objs
        putStr "objs after kill&Spawn: "
        putStrLn $ show $ keysIL $
            case (killAndSpawn (([], emptyIL), oos1)) of
                (Event d) -> d objs
                _         -> objs

        -- output :: IL ObjOutput -> IO Bool
        -- Just render the 'State's or quit if there is none.
        o1 <- output False oos1
        putStrLn $ show o1
        o2 <- output False oos2
        putStrLn $ show o2
        o3 <- output False emptyIL
        putStrLn $ show o3

        SDL.quit
      where
        key = KeyDown (Keysym
            { symKey = SDL.SDLK_RIGHT
            , symModifiers = []
            , symUnicode = '\0'
            })
        playerObj   = playerObject (Point2 16 16)
                                   (SDL.Rect (-8) (-8) 8 8)
                                   (SDL.Pixel 0x00000000)
        obstacleObj = staticObject (Point2 48 48)
                                   (SDL.Rect (-8) (-8) 8 8)
                                   (SDL.Pixel 0x000000FF)
        objs = (listToIL [playerObj, obstacleObj])

        enemyObj = staticObject (Point2 80 80)
                                (SDL.Rect (-8) (-8) 8 8)
                                (SDL.Pixel 0x00FF0000)
        ooPlayer = defaultObjOutput
            { ooState = Rectangle (Point2 48 48)
                                  (SDL.Rect (-8) (-8) 8 8)
                                  (SDL.Pixel 0x00000000)
            }
        ooObstacle = defaultObjOutput
            { ooState = Rectangle (Point2 48 48)
                                  (SDL.Rect (-8) (-8) 8 8)
                                  (SDL.Pixel 0x000000FF)
            , ooKillRequest   = Event ()
            , ooSpawnRequests = Event [enemyObj]
            }
        ooEnemy = defaultObjOutput
            { ooState = Rectangle (Point2 80 80)
                                  (SDL.Rect (-8) (-8) 8 8)
                                  (SDL.Pixel 0x00FF0000)
            }
        oos1 = listToIL [ooPlayer, ooObstacle]
        oos2 = listToIL [ooPlayer, ooEnemy]

-- reactimation IO ----------

initialize :: IO Input
initialize = do
    SDL.init [SDL.InitVideo]
    screen <- SDL.setVideoMode windowWidth windowHeight
                               windowDepth [SDL.HWSurface]
    SDL.setCaption windowCaption []

    SDL.fillRect screen Nothing (SDL.Pixel 0x006495ED) -- 0x00RRGGBB
    SDL.flip screen
    events <- unfoldWhileM (/= SDL.NoEvent) SDL.pollEvent

    putStrLn $ "initialize (sense): " ++ show events
    return events
  where
    windowWidth   = 96
    windowHeight  = 96
    windowDepth   = 32
    windowCaption = "Yampa/SDL Stub"

input :: Bool -> IO (DTime, Maybe Input)
input _ = do
    events <- unfoldWhileM (/= SDL.NoEvent) SDL.pollEvent
    putStrLn $ "input (sense): " ++ show events
    return (1.0, Just events)

output :: Bool -> IL ObjOutput -> IO Bool
output _ oos = do
    putStrLn $ "output (actuate) + " ++ (show delayMs) ++ "ms delay: "

    screen <- SDL.getVideoSurface
    SDL.fillRect screen Nothing (SDL.Pixel 0x006495ED) -- Pixel 0x--RRGGBB

    mapM_ (\oo -> render (ooState oo) screen) (elemsIL oos) -- render 'State'!

    SDL.flip screen
    SDL.delay delayMs

    return $ null $ keysIL oos
  where
    delayMs = 500

    render :: State -> SDL.Surface -> IO ()
    render (Rectangle pos rect color) screen = do
        SDL.fillRect screen gRect color
        return ()
      where
        -- center rectangle around position
        x0 = round (point2X pos) + (rectX rect)
        y0 = round (point2Y pos) + (rectY rect)
        x1 = round (point2X pos) + (rectW rect)
        y1 = round (point2Y pos) + (rectH rect)
        gRect = Just (SDL.Rect x0 y0 (x1 - x0) (y1 - y0))
    render (Debug s) screen = putStrLn s


-- reactimate process ----------

process :: IL Object -> SF Input (IL ObjOutput)
process objs0 = proc input -> do
    rec
        -- 'process' stores the 'State's (note: rec) and
        -- passes them over to core
        oos <- core objs0 -< (input, oos)
    returnA -< oos

core :: IL Object -> SF (Input, IL ObjOutput) (IL ObjOutput)
core objs = dpSwitch route
                     objs
                     (arr killAndSpawn >>> notYet)
                     (\sfs' f -> core (f sfs'))

-- 1. process previous object 'State's (if any) and
--    generate logical events
-- 2. distribute input and logical events to the corresponding objects
route :: (Input, IL ObjOutput) -> IL sf -> IL (ObjEvents, sf)
route (input, oos) objs = mapIL routeAux objs
  where
    hs = hits (assocsIL (fmap ooState oos)) -- process all object 'State's
    routeAux (k, obj) = (ObjEvents
        { oeInput = input
        -- hit events are only routed to the objects they belong to (routing)
        , oeLogic = if k `elem` hs then Event () else Yampa.NoEvent
        }, obj)

hits :: [(ILKey, State)] -> [ILKey]
hits kooss = concat (hitsAux kooss)
  where
    hitsAux [] = []
    -- Check each object 'State' against each other
    hitsAux ((k,oos):kooss) =
        [ [k, k'] | (k', oos') <- kooss, oos `hit` oos' ]
        ++ hitsAux kooss

    hit :: State -> State -> Bool
    (Rectangle p1 _ _) `hit` (Rectangle p2 _ _) = p1 == p2
    _ `hit` _ = False

killAndSpawn :: ((Input, IL ObjOutput), IL ObjOutput)
             -> Yampa.Event (IL Object -> IL Object)
killAndSpawn ((input, _), oos) =
    if any checkEscKey input
        then Event (\_ -> emptyIL) -- kill all 'State' on [Esc] => quit
        else foldl (mergeBy (.)) noEvent events
  where
    events :: [Yampa.Event (IL Object -> IL Object)]
    events = [ mergeBy (.)
                      (ooKillRequest oo `tag` (deleteIL k))
                      (fmap  (foldl (.) id . map insertIL_)
                             (ooSpawnRequests oo))
             | (k, oo) <- assocsIL oos ]
    checkEscKey (SDL.KeyDown (SDL.Keysym SDL.SDLK_ESCAPE  _ _)) = True
    checkEscKey _ = False


-- objects ----------

playerObject :: Position2 -> SDL.Rect -> SDL.Pixel -> Object
playerObject p0 rect color = proc objEvents -> do
    -- .+^ is Point-Vector-addition
    -- ^+^ is Vector-Vector addition
    -- here we sum up all vectors based on the possibly multiple
    -- user inputs, thus allowing diagonal moves
    p <- (p0 .+^) ^<< integral -<
        foldl (^+^) (vector2 0 0) $ mapMaybe checkKey (oeInput objEvents)
    returnA -< defaultObjOutput { ooState = Rectangle p rect color }
    where
        checkKey (SDL.KeyUp (SDL.Keysym SDL.SDLK_UP    _ _)) =
            Just $ vector2    0 (-32)
        checkKey (SDL.KeyUp (SDL.Keysym SDL.SDLK_LEFT  _ _)) =
            Just $ vector2 (-32)   0
        checkKey (SDL.KeyUp (SDL.Keysym SDL.SDLK_DOWN  _ _)) =
            Just $ vector2    0   32
        checkKey (SDL.KeyUp (SDL.Keysym SDL.SDLK_RIGHT _ _)) =
            Just $ vector2   32    0
        checkKey _ = Nothing

staticObject :: Position2 -> SDL.Rect -> SDL.Pixel -> Object
staticObject p0 rect color = proc objEvents -> do
    returnA -< defaultObjOutput { ooState         = Rectangle p0 rect color
                                , ooKillRequest   = (oeLogic objEvents)
                                , ooSpawnRequests = (debugIfKilled objEvents)
                                }
  where
    debugIfKilled objEvents =
        case (oeLogic objEvents) of
            Yampa.Event () -> Event [debugObject "hit"]
            _              -> Event []

debugObject :: String -> Object
debugObject s = proc objEvents -> do
    returnA -< defaultObjOutput { ooState       = Debug s
                                , ooKillRequest = Event ()
                                }