{-# LANGUAGE DeriveGeneric #-}

import Network.WebSockets hiding (Message)
import Network.Socket (withSocketsDo)
import Graphics.Gloss.Interface.IO.Game
import Data.Bifunctor
import Data.Biapplicative
import Data.Monoid
import Data.Maybe (catMaybes)
import Data.List (partition)
import Control.Concurrent.Chan
import Control.Concurrent.MVar
import Control.Concurrent
import Control.Monad (forever)
import GHC.Generics
import Data.Serialize (Serialize, encodeLazy, decodeLazy)
import Control.Monad
import System.Environment
import System.Exit


type Time = Float
type Hp = Float
type Position = (Float, Float)
type Velocity = (Float, Float)
type BSize = Float
type OtherLost = Bool

data Bullet = Bullet BSize Position Velocity deriving (Show, Read, Generic)

data GameState = Playing | Won | Lost | Even deriving (Show, Eq, Read, Generic)

data Ammo = Ammo { availAmmo :: Float
                 , charging :: Bool
                 , charged :: Float }
                 deriving (Show, Read, Generic)

data World = World { pos :: Position
                   , hp :: Hp
                   , ammo :: Ammo
                   , velocity :: Velocity
                   , gameState :: GameState
                   , ownBullets :: [Bullet]
                   , othBullets :: [Bullet] }
                   deriving (Show, Read, Generic)

data Role = Server Int | Client String Int deriving (Show, Read)

data Message = ILost | IShot Bullet deriving (Show, Read, Generic)

instance Serialize Bullet
instance Serialize GameState
instance Serialize Ammo
instance Serialize World
instance Serialize Message

fromRight (Right a) = a --FIXME ignore, report or something
fromRight _ = error "deserialization error. sorry :("

instance WebSocketsData Message where
  fromLazyByteString = fromRight . decodeLazy
  toLazyByteString = encodeLazy
  fromDataMessage (Binary bs) = fromLazyByteString bs
  fromDataMessage _ = error "Invalid websocket message"

instance WebSocketsData Bullet where
  fromLazyByteString = fromRight . decodeLazy
  toLazyByteString = encodeLazy
  fromDataMessage (Binary bs) = fromLazyByteString bs
  fromDataMessage _ = error "Invalid websocket message"

maxAmmo = 6
chargingSpeed = 2
rechargingSpeed = 2
minCharge = 1.0
addedBulletVelocity = 2
bulletVelocity = 200
playerVelocity = 200
maxHp = 100
damageMultiplier = 10
playerHitBox = (playerWidth/2, playerHeight/2) -- half the size of the hitbox side
playerWidth = 80
playerHeight = 80

screenW = 800
screenH = 600

ownColor = magenta
othColor = yellow
lifeColor = green
ammoColor = red

fps = 60

main :: IO ()
main = do
  args <- getArgs
  role <- case args of ip:port:[] -> return $ Client ip (read port)
                       port:[] -> return $ Server $ read port
                       _ -> do
                               putStrLn "Invalid arguments."
                               putStrLn "Usage:"
                               putStrLn "  dual address port      - connects to an existing server"
                               putStrLn "  dual port              - creates a server"
                               exitFailure
  sendChan <- newChan
  recvMVar <- newMVar []
  otherLostMVar <- newMVar False
  _ <- forkIO $ case role of
    Server port -> do
      runServer "0.0.0.0" port $ ws otherLostMVar recvMVar sendChan <=< acceptRequest
    Client ip port -> do
      withSocketsDo $ runClient ip port "/" $ ws otherLostMVar recvMVar sendChan
  playIO (InWindow "DUAL" (screenW, screenH) (0, 0))
    black
    fps
    defaultWorld
    render
    handleInput
    (step otherLostMVar recvMVar sendChan)
  --TODO clean up the socket properly

ws :: MVar OtherLost -> MVar [Bullet] -> Chan Message -> Connection -> IO ()
ws gameStateM rM sC conn = do
  _ <- forkIO $ recvData conn gameStateM rM
  sendData conn sC

sendData :: Connection -> Chan Message -> IO ()
sendData conn ch = do
  forever $ do
    m <- readChan ch
    sendBinaryData conn m
  --hClose hdl

recvData :: Connection -> MVar OtherLost -> MVar [Bullet] -> IO ()
recvData conn gsMV bMV = do
  forever $ do
    msg <- receiveData conn
    case msg of IShot b -> modifyMVar_ bMV  (\bs -> return (b:bs))
                ILost   -> modifyMVar_ gsMV (return . const True)
  --hClose hdl

defaultAmmo :: Ammo
defaultAmmo = Ammo { availAmmo = maxAmmo
                   , charging = False
                   , charged = 0 }

defaultWorld :: World
defaultWorld = World { pos = (0,0)
                     , hp = maxHp
                     , ammo = defaultAmmo
                     , velocity = (0,0) 
                     , gameState = Playing
                     , ownBullets = []
                     , othBullets = [] }

render :: Monad m => World -> m Picture
render world = return $ renderBullets world
                      <> statePicture (gameState world)
                      <> borders
                      <> translate x y (color ownColor $ rectangleSolid playerWidth playerHeight)
                      <> translate x (y - playerHeight / 2 - 5) (color ammoColor $ rectangleSolid (10* availAmmo (ammo world)) 5)
                      <> if hp world > 0
                           then translate x (y - playerHeight / 2 - 13) $ color lifeColor $ rectangleSolid (1* hp world) 5
                           else Blank
  where x = fst $ pos world
        y = snd $ pos world

statePicture :: GameState -> Picture
statePicture Won  = Translate (-350) 0 $ Color red $ Graphics.Gloss.Interface.IO.Game.Text "YOU WON"
statePicture Lost = Translate (-350) 0 $ Color red $ Graphics.Gloss.Interface.IO.Game.Text "YOU LOST"
statePicture Even = Translate (-350) 0 $ Color red $ Graphics.Gloss.Interface.IO.Game.Text "EVEN"
statePicture Playing = Blank

borders :: Picture
borders = color white $ rectangleWire (fromIntegral screenW - 2) (fromIntegral screenH - 2)

renderBullets :: World -> Picture
renderBullets world = Pictures (fmap (renderBullet ownColor) (ownBullets world) ++ fmap (renderBullet othColor) (othBullets world))

renderBullet :: Color -> Bullet -> Picture
renderBullet c (Bullet size (x,y) _) = translate x y $ color c $ rectangleSolid (10*size) (10*size)

handleInput :: Monad m => Event -> World -> m World
handleInput (EventKey (SpecialKey KeyDown)  Down _ _) world = return world { velocity = second (const (-1)) $ velocity world }
handleInput (EventKey (SpecialKey KeyDown)  Up   _ _) world = return world { velocity = second (const    0) $ velocity world }
handleInput (EventKey (SpecialKey KeyUp)    Down _ _) world = return world { velocity = second (const    1) $ velocity world }
handleInput (EventKey (SpecialKey KeyUp)    Up   _ _) world = return world { velocity = second (const    0) $ velocity world }
handleInput (EventKey (SpecialKey KeyLeft)  Down _ _) world = return world { velocity = first  (const (-1)) $ velocity world }
handleInput (EventKey (SpecialKey KeyLeft)  Up   _ _) world = return world { velocity = first  (const    0) $ velocity world }
handleInput (EventKey (SpecialKey KeyRight) Down _ _) world = return world { velocity = first  (const    1) $ velocity world }
handleInput (EventKey (SpecialKey KeyRight) Up   _ _) world = return world { velocity = first  (const    0) $ velocity world }
handleInput (EventKey (SpecialKey KeySpace) Down _ _) world = return world { ammo = (ammo world) { charging = True } }
handleInput (EventKey (SpecialKey KeySpace) Up   _ _) world = return world { ammo = (ammo world) { charging = False } }
handleInput _ world = return world

-- Just a bottom-to-top chain of world modifications.
-- The effectful ones are marked with =<<, which is nice.
step :: MVar OtherLost -> MVar [Bullet] -> Chan Message -> Time -> World -> IO World
step stateMVar rCh sCh dt world =
  lose sCh =<<
  sendBullets sCh =<<
  ((destroyOthBullets .
  getHit .
  moveBullets dt .
  movePlayer dt .
  shoot .
  charge dt .
  recharge dt) <$>
  (receiveBullets rCh =<<
  receiveVictory stateMVar world))

receiveBullets :: MVar [Bullet] -> World -> IO World
receiveBullets mv world = do
  bs <- swapMVar mv [] --XXX FIXME not atomic. -> STM/synchronous-channels?
  let bs' = flipVelocity <$> bs
  return world { othBullets = othBullets world ++ bs' }

receiveVictory :: MVar OtherLost -> World -> IO World
receiveVictory otherLostMVar world = do
  won' <- tryReadMVar otherLostMVar --TODO avoid if already won? or laziness already does it?
  let won = case won' of Just a -> a
                         Nothing -> error "Logic error: the game state MVar should always be full!" --TODO replace False with emptyness? use a lock?
  return $ if not won then world
           else world { gameState = f $ gameState world }
             where f Playing = Won
                   f Lost = Even
                   f Even = Even
                   f Won = Won

flipVelocity :: Bullet -> Bullet
flipVelocity (Bullet s p (vx, vy)) = Bullet s p (vx, -vy)

sendBullets :: Chan Message -> World -> IO World
sendBullets ch world = do
  let (onScreen, offScreen) = partition (\(Bullet _ (_, y) _) -> y<=fromIntegral screenH/2) $ ownBullets world
  let reallyOnScreen = filter (\(Bullet _ (x, _) _) -> x<=fromIntegral screenW/2 && x>=fromIntegral screenW/(-2)) onScreen
  writeList2Chan ch $ fmap IShot offScreen
  return world { ownBullets = reallyOnScreen }

lose :: Chan Message -> World -> IO World
lose ch world | gameState world /= Playing = return world
              | hp world <= 0 = do
                                   writeChan ch ILost
                                   return $ world { gameState = Lost }
              | otherwise = return world

getHit :: World -> World
getHit world = world'
  where world' = world { hp = hp' }
        bs = othBullets world
        hp' = hp world - sum (catMaybes $ bulletDamage world <$> bs)

bulletDamage :: World -> Bullet -> Maybe Hp
bulletDamage world (Bullet s p _) = if inHitBox playerHitBox (pos world) p
                                      then Just (s*damageMultiplier)
                                      else Nothing

-- | if the two positions are within the given range
inHitBox :: (Float, Float) -> Position -> Position -> Bool
inHitBox (hx, hy) (ax, ay) (bx, by) = x && y
  where x = abs (ax-bx) < hx
        y = abs (ay-by) < hy

destroyOthBullets :: World -> World
destroyOthBullets world = world { othBullets = filter (\(Bullet _ p _) -> not (hit p || outside p)) $ othBullets world }
  where hit p = inHitBox playerHitBox p $ pos world
        outside (x,y) = x >  (fromIntegral screenW)/2
                     || x < -(fromIntegral screenW)/2
                     || y < -(fromIntegral screenH)/2
--TODO add 'life' property to Bullet
--TODO or delete off-screen

movePlayer :: Time -> World -> World
movePlayer dt world = world { pos = checkBounds $ bimap (+) (+) (bimap (*(playerVelocity*dt)) (*(playerVelocity*dt)) $ velocity world) <<*>> pos world }

checkBounds :: Position -> Position
checkBounds (x,y) = (max (-halfW) $ min halfW x, max (-halfH) $ min halfH y)
  where halfW = fromIntegral screenW / 2
        halfH = fromIntegral screenH / 2

recharge :: Time -> World -> World
recharge dt world = world { ammo = a' }
  where a' = if charging a
               then a
               else a { availAmmo = min maxAmmo (availAmmo a + dt*rechargingSpeed) }
        a = ammo world

charge :: Time -> World -> World
charge dt world = world { ammo = a' }
  where a = ammo world
        a' = a { availAmmo = availAmmo', charged = charged' }
        availAmmo' = if charging a
                       then max 0 $ availAmmo a - chargeAmount
                       else availAmmo a
        charged' = if charging a && availAmmo a - chargeAmount > 0
                     then min maxAmmo $ charged a + chargeAmount
                     else charged a
        chargeAmount = if charged a > 0
                         then dt*chargingSpeed
                         else minCharge

shoot :: World -> World
shoot world = world { ammo = a', ownBullets = bs' }
  where a = ammo world
        bs = ownBullets world
        a' = if shooting then a { charged = 0 } else a
        bs' = if shooting then b:bs else bs
        b = mkBullet world
        shooting = not (charging a) && charged a > 0 && hp world > 0

mkBullet :: World -> Bullet
mkBullet world = Bullet s p v
  where s = charged $ ammo world
        p = pos world
        v = second (+addedBulletVelocity* sqrt s) $ velocity world

moveBullets :: Time -> World -> World
moveBullets dt world = world { ownBullets = moveBullet dt <$> ownBullets world
                             , othBullets = moveBullet dt <$> othBullets world }

moveBullet :: Time -> Bullet -> Bullet
moveBullet dt (Bullet s p v) = Bullet s (bimap (+) (+) (bimap (*(bulletVelocity*dt)) (*(bulletVelocity*dt)) v) <<*>> p) v