module Main (main)
    where

import Control.Exception (Exception(ExitException), catch, throwIO)
import Control.Monad (zipWithM_)
import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef)
import Data.List (nub)
import Data.Maybe (isJust, fromJust)
import Graphics.UI.GLUT (DisplayMode(RGBMode, DoubleBuffered),
                        getArgsAndInitialize, initialDisplayMode, initialWindowSize, mainLoop,
                        createWindow, destroyWindow, swapBuffers, Menu(..), MenuItem(MenuEntry),
                        attachMenu, Font(renderString), StrokeFont(Roman), Flavour(Wireframe),
                        Object(Tetrahedron, Teapot, Octahedron, Icosahedron, Dodecahedron),
                        renderObject, MouseButton(LeftButton,RightButton), Key(SpecialKey, Char), KeyState(..),
                        SpecialKey(KeyUp, KeyRight, KeyLeft, KeyDown), displayCallback,
                        keyboardMouseCallback, TimerCallback, addTimerCallback, MatrixComponent(..),
                        MatrixMode(Projection, Modelview), Position(..), Size(..), Vector3(..),
                        loadIdentity, matrixMode, preservingMatrix, viewport,
                        ClearBuffer(DepthBuffer, ColorBuffer), clear, HasSetter(..), lookAt,
                        perspective, Color(color), Color3(..), Vertex3(..))
import Prelude hiding (catch)
import System.Exit (ExitCode(ExitSuccess))

main :: IO ()
main = do
  keystate <- newIORef []
  cp       <- newIORef $ openingProc keystate
  initialWindowSize $= Size 1200 800
  initialDisplayMode $= [RGBMode,DoubleBuffered]
  getArgsAndInitialize
  wnd <- createWindow "Shu-thing"

  displayCallback $= dispProc cp
  keyboardMouseCallback $= Just (keyProc keystate)

  addTimerCallback 24 $ timerProc $ dispProc cp

  attachMenu LeftButton (Menu [
    MenuEntry "&Exit" exitLoop])
  attachMenu RightButton (Menu [
    MenuEntry "&Exit" exitLoop])

  initMatrix
  mainLoop
  destroyWindow wnd

  `catch` (\_ -> return ())

exitLoop :: IO a
exitLoop = throwIO $ ExitException ExitSuccess

initMatrix :: IO ()
initMatrix = do
  viewport $= (Position 0 0,Size 1200 800)
  matrixMode $= Projection
  loadIdentity
  perspective 30.0 (4/3) 600 1400
  lookAt (Vertex3 0 0 (927 :: Double)) (Vertex3 0 0 (0 :: Double)) (Vector3 0 1 (0 :: Double))

dispProc :: IORef (IO Scene) -> IO ()
dispProc cp = do
  m <- readIORef cp
  Scene next <- m
  writeIORef cp next

newtype Scene = Scene (IO Scene)

openingProc :: IORef [Key] -> IO Scene
openingProc ks = do
  keystate <- readIORef ks

  clear [ColorBuffer,DepthBuffer]
  matrixMode $= Modelview 0
  loadIdentity

  color $ Color3 (1.0 :: Double) 1.0 1.0
  preservingMatrix $ do
    translate $ Vector3 (-250 :: Double) 0 0
    scale (0.8 :: Double) 0.8 0.8
    renderString Roman "shu-thing"
  preservingMatrix $ do
    translate $ Vector3 (-180 :: Double) (-100) 0
    scale (0.4 :: Double) 0.4 0.4
    renderString Roman "Press Z key"

  swapBuffers

  if Char 'z' `elem` keystate then do
      gs <- newIORef initialGameState
      return $ Scene $ mainProc gs ks
   else return $ Scene $ openingProc ks

endingProc :: IORef [Key] -> IORef Double -> IO Scene
endingProc ks ctr= do
  keystate <- readIORef ks
  counter <- readIORef ctr
  modifyIORef ctr $ min 2420 . (+1.5)
  clear [ColorBuffer,DepthBuffer]
  matrixMode $= Modelview 0
  loadIdentity

  color $ Color3 (1.0 :: Double) 1.0 1.0
  zipWithM_ (\str pos -> preservingMatrix $ do
    translate $ Vector3 ((-180) :: Double) (-240 + counter - pos) 0
    scale (0.3 :: Double) 0.3 0.3
    renderString Roman str)
    stuffRoll [0,60..]

  swapBuffers

  if Char 'x' `elem` keystate then do
      return $ Scene $ openingProc ks
   else return $ Scene $ endingProc ks ctr

  where
    stuffRoll = [
     "",
     "Game Design",
     "     T. Muranushi",
     "",
     "Main Programmer",
     "     H. Tanaka",
     "",
     "Enemy Algorithm",
     "     M. Takayuki",
     "",
     "Graphics Designer",
     "     Euclid",
     "",
     "Monad Designer",
     "     tanakh",
     "",
     "Lazy Evaluator",
     "     GHC 6.8",
     "",
     "Cast",
     "  Player Dodecahedron",
     "  Bullet Tetrahedron",
     "  Enemy  Octahedron",
     "  Boss   Teapot",
     "",
     "Special thanks to",
     "     Simon Marlow",
     "     Haskell B. Curry",
     "",
     "Presented by",
     "     team combat",
     "",
     "WE LOVE HASKELL!",
     "",
     "    press x key"]

mainProc :: IORef GameState -> IORef [Key] -> IO Scene
mainProc gs ks = do
  keystate <- readIORef ks
  modifyIORef gs $ updateGameState keystate
  gamestate <- readIORef gs

  clear [ColorBuffer,DepthBuffer]
  matrixMode $= Modelview 0
  loadIdentity
  renderGameState gamestate
  swapBuffers
  if isGameover gamestate then return $ Scene $ openingProc ks else
   if isClear gamestate then do
      counter <- newIORef (0.0 :: Double)
      return $ Scene $ endingProc ks counter else
    return $ Scene $ mainProc gs ks

timerProc :: IO a -> TimerCallback
timerProc m = m >> addTimerCallback 16 (timerProc m)

keyProc :: IORef [Key] -> Key -> KeyState -> t -> t1 -> IO ()
keyProc keystate key ks _ _ =
  case (key,ks) of
    (Char 'q',_) -> exitLoop
    (Char 'c',_) -> exitLoop
    (_,Down) -> modifyIORef keystate $ nub . (++[key])
    (_,Up) -> modifyIORef keystate $ filter (/=key)

bosstime, bosstime2 :: Int
bosstime = 6600
bosstime2 = 7200

data GameObject = Player {position :: Point,shotEnergy :: Double,hp :: Double}|
                  Bullet {position :: Point} |
                  EnemyMaker {timer :: Int,deathtimer :: Int}|
                  Enemy {position :: Point,hp :: Double,anime :: Int,enemySpec :: EnemySpec} |
                  Explosion {position :: Point,hp :: Double,size :: Double}|
                  EnemyBullet {position :: Point,velocity :: Point} |
                  GameoverSignal |
                  ClearSignal
                  deriving (Eq)

data EnemySpec = EnemySpec {ways :: Int,spread :: Double,speed :: Double,freq :: Int,endurance :: Double,boss :: Bool}
                 deriving (Eq)

updateObject :: GameState -> [Key] -> GameObject -> [GameObject]
updateObject _ ks (Player{position=pos,shotEnergy=sen,hp=oldhp})
 = Player{position=newPos,shotEnergy=nsen,hp=newhp} : shots
 where
  newPos :: Point
  newPos = if oldhp > 0 then (nx,ny) +++ v
           else (nx,ny)
  newhp = oldhp
  (x,y) = pos
  nx = if x < (-310) then -310 else if x > 310 then 310 else x
  ny = if y < (-230) then -230 else if y > 200 then 200 else y
  v = (vx,vy) *++ (5.0 :: Double)
  shots = replicate shotn $ Bullet pos
  nsen = if shotn /= 0 then -1.0 else
    if shotmode == 1 && shotn == 0 then sen + 0.25 else
    if shotmode == 0 then 0.0 else sen
  vx :: Double
  vx =
   if SpecialKey KeyLeft `elem` ks then -1 else 0 +
   if SpecialKey KeyRight `elem` ks then 1 else 0
  vy =
   if SpecialKey KeyUp `elem` ks then 1 else 0 +
   if SpecialKey KeyDown `elem` ks then -1 else 0
  shotmode :: Int
  shotmode = if Char 'z' `elem` ks then 1 else 0
  shotn :: Int
  shotn = if oldhp <= 0 || shotmode == 0 then 0 else
    if sen >= 0 then 1 else 0
updateObject _ _ (Bullet{position=pos}) = replicate n (Bullet newpos) where
  newpos = pos +++ (0.0,15.0)
  n = if (\(_,y) -> y > 250) pos then 0 else 1
updateObject gs _ (EnemyMaker{timer=t,deathtimer=dtime}) =
 [EnemyMaker{timer=t+1,deathtimer=newdtime}] ++ enemies ++ deatheffects where
  enemies = replicate n $ Enemy{position = (320*sin(dt*dt),240),hp=1.0,anime=0,enemySpec = spec}
  dt :: Double
  dt = fromIntegral t
  newdtime = dtime + if hp p<=0 || (bossExist&&hp b<=0) then 1 else 0
  n = if (t`mod`120==0 && t<=bosstime) || t==bosstime2 then 1 else 0
  deatheffects = if dtime==0 then [] else
    if dtime==120 || dtime==130 || dtime==140 then [Explosion{position=position deadone,hp=1.0,size=3.0*deathradius}] else
    if dtime==240 then [if hp p<=0 then GameoverSignal else ClearSignal] else
    if dtime>120 || dtime`mod`15/=0 then [] else
    [Explosion{position=position deadone +++ ((sin dt,cos dt)*++ (16*deathradius)),hp=1.0,size=0.3*deathradius}]
  p = findplayer gs
  b = fromJust mayb
  deadone :: GameObject
  deadone = if hp p<=0 then p else b
  deathradius = if hp p<=0 then 1 else 3
  bossExist = isJust mayb
  mayb = findBoss gs
  spec = if t==bosstime2 then EnemySpec{ways=0,spread=0.1,speed=3.0,freq=10,endurance=300.0,boss=True}
    else speclist !! (t `div` 600)
  speclist = [EnemySpec {ways=0,spread=0.1,speed=3.0,freq=30,endurance=2.0,boss=False},
     EnemySpec {ways=1,spread=0.3,speed=5.0,freq=60,endurance=4.0,boss=False},
     EnemySpec {ways=3,spread=0.7,speed=0.2,freq=90,endurance=8.0,boss=False},
     EnemySpec {ways=45,spread=0.069,speed=8.0,freq=450,endurance=1.0,boss=False},
     EnemySpec {ways=0,spread=0.1,speed=1.0,freq=10,endurance=10.0,boss=False},
     EnemySpec {ways=0,spread=0.1,speed=1.0,freq=10,endurance=10.0,boss=False},
     EnemySpec {ways=3,spread=0.1,speed=3.0,freq=60,endurance=6.0,boss=False},
     EnemySpec {ways=1,spread=0.5,speed=7.0,freq=45,endurance=3.0,boss=False},
     EnemySpec {ways=10,spread=0.3,speed=15.0,freq=115,endurance=5.0,boss=False}
    ] ++
     map (\o -> EnemySpec {ways=o,spread=0.1,speed=4.0,freq=20,endurance=3.0,boss=False}) [0,1 ..]

updateObject gs _ oldenemy@(Enemy{position=pos,hp=oldhp,anime=oldanime,enemySpec=spec})  =
  replicate n (oldenemy{position=newpos,hp=newhp,anime=newanime,enemySpec=newspec})
   ++ shots ++ explosions where
    newpos = if isBoss then (200 * sin(danime/100),200 + 40 * cos(danime/80))
      else pos +++ (0.0,-1.0)
    newhp = oldhp
    newanime = oldanime + 1
    newspec
        | (not isBoss) = spec
        | (oldhp > 0.75) = EnemySpec{ways=0,spread=0.1,speed=5.0,freq=10,endurance=300.0,boss=True}
        | (oldhp > 0.50) = EnemySpec{ways=8,spread=0.15,speed=3.0,freq=30,endurance=300.0,boss=True}
        | (oldhp > 0.25) = EnemySpec{ways=2,spread=1.2,speed=15.0,freq=10,endurance=300.0,boss=True}
        | (oldhp > 0.05) = EnemySpec{ways=40,spread=0.075,speed=3.0,freq=60,endurance=400.0,boss=True}
        | (oldhp > 0.00) = EnemySpec{ways=15,spread=0.2,speed=16.0,freq=20,endurance=900.0,boss=True}
        | otherwise = EnemySpec{ways=(-1),spread=0.1,speed=3.0,freq=10,endurance=300.0,boss=True}
    danime :: Double
    danime = fromIntegral oldanime
    explosions =   [Explosion{position = pos, hp = 1.0, size = 1.0} |
                    (oldhp <= 0 && not isBoss)]
    shots = if oldanime`mod` frq /=(frq-1) then [] else
      map (\v -> EnemyBullet{position=pos,velocity=v}) vs
    vs = (take (wa+1) $ iterate (vdistr***) centerv) ++
         (take wa $ tail $ iterate (vdistrc***) centerv)
    centerv = (pp -+- pos) *++ (spd / distance pp pos)
    vdistr :: Point
    vdistr = (cos sprd, sin sprd)
    vdistrc :: Point
    vdistrc = (cos sprd, -sin sprd)
    pp = playerpos gs
    n = if (\(_,y) -> y<(-250)) pos || (not isBoss && oldhp<=0) then 0 else 1
    wa = ways spec
    spd= speed spec
    frq = freq spec
    sprd= spread spec
    isBoss = boss spec
updateObject _ _ e@(Explosion{}) = [(e{hp = hp e - (2.4e-2 / size e)}) | (hp e > 0)]
updateObject _ _ eb@(EnemyBullet{}) = if outofmap (position eb) then [] else
  [eb{position=position eb +++ velocity eb}]
updateObject _ _ go = [go]

watcher :: [GameObject] -> [GameObject]
watcher os = np ++ ne ++ nb ++ neb ++ others
    where
      ne  = foldr ($) enemies $ map enemyDamager bullets
      np  = foldr ($) players $ map playerDamager ebullets
      nb  = foldr ($) bullets $ map bulletEraser enemies
      neb = foldr ($) ebullets $ map ebEraser players
      bulletEraser :: GameObject -> [GameObject] -> [GameObject]
      bulletEraser e = filter (\b -> distance2 (position b) (position e) > hitr e)
      enemyDamager :: GameObject -> [GameObject] -> [GameObject]
      enemyDamager b = map (\e  -> if distance2 (position b) (position e) > hitr e
                            then e
                            else (\d ->  d{hp=hp d-(1.0 / endurance (enemySpec d))}) e)
      hitr e = if boss $ enemySpec e then sq 100 else sq 32
      playerDamager :: GameObject -> [GameObject] -> [GameObject]
      playerDamager eb = map (\p  -> if distance2 (position p) (position eb) > 70
                              then p
                              else (\q -> q{hp=hp q-0.3}) p)
      ebEraser p = filter (\eb -> distance2 (position eb) (position p) > 70)
      (enemies,bullets,ebullets,players,others) = foldl f ([],[],[],[],[]) os
      f (e,b,eb,p,x) o = case o of
                           Enemy{}       -> (o:e,b,eb,p,x)
                           Bullet{}      -> (e,o:b,eb,p,x)
                           EnemyBullet{} -> (e,b,o:eb,p,x)
                           Player{}      -> (e,b,eb,o:p,x)
                           _             -> (e,b,eb,p,o:x)

renderGameObject :: GameObject -> IO ()
renderGameObject Player{position=pos,hp=h} = preservingMatrix $ do
  let (x,y) = pos
  color (Color3 (1.0 :: Double) h h)
  translate (Vector3 x y 0)
  scale (10 :: Double) 10 10
  rotate x (Vector3 0 1 0)
  rotate (30 :: Double) (Vector3 0 0 1)
  renderObject Wireframe Dodecahedron
renderGameObject Bullet{position=pos} = preservingMatrix $ do
  let (x,y) = pos
  color (Color3 (0.6 :: Double) 0.6 1.0)
  translate (Vector3 x y 0)
  scale (4 :: Double) 18 8
  rotate (45 :: Double) (Vector3 0 1 0)
  rotate (90 :: Double) (Vector3 1 0 0)
  renderObject Wireframe Tetrahedron
renderGameObject Enemy{position=pos,anime=a,hp=h,enemySpec=EnemySpec{boss=False}} = preservingMatrix $ do
  let (x,y) = pos
  color (Color3 (cos rho) (sin rho) (0.0 :: Double))
  translate (Vector3 x y 0)
  rotate (2*(theta :: Double)) (Vector3 0 1.0 0)
  scale (32 :: Double) 32 8
  renderObject Wireframe Octahedron where
    theta = fromIntegral a
    rho = h * 3.14 / 2
renderGameObject Enemy{position=pos,anime=a,hp=h,enemySpec=EnemySpec{boss=True}} = preservingMatrix $ do
  let (x,y) = pos
  color (Color3 (cos rho) (sin rho) (0.0 :: Double))
  translate (Vector3 x y 0)
  rotate (2*(theta :: Double)) (Vector3 0 1.0 0)
  scale (120 :: Double) 120 120
  renderObject Wireframe (Teapot 1.0) where
    theta = fromIntegral a
    rho = h * 3.14 / 2
renderGameObject Explosion{position=pos,hp=h,size=s}= preservingMatrix $ do
  let (x,y) = pos
  color (Color3 h 0.0 0.0)
  translate (Vector3 x y 0)
  rotate (720*h) (Vector3 0 1.0 0)
  rotate (540*h) (Vector3 1.0 0 0)
  scale r r r
  renderObject Wireframe Icosahedron where
    r = s*(100 - h*h*80)
renderGameObject EnemyBullet{position=pos} = preservingMatrix $ do
  let (x,y) = pos
  color (Color3 (1.0 :: Double) 1.0 1.0)
  translate (Vector3 x y 0)
  scale (5 :: Double) 5 5
  rotate (45 :: Double) (Vector3 0 0 (1.0 :: Double))
  renderObject Wireframe  Tetrahedron
renderGameObject _ = return ()

data GameState = GameState {objects :: [GameObject]}

initialGameState :: GameState
initialGameState = GameState{objects=
  [Player{position=(0.0,0.0),shotEnergy=0.0,hp=1.0},EnemyMaker{timer=0,deathtimer=0}]
                            }

renderGameState :: GameState -> IO ()
renderGameState GameState{objects=os} = mapM_ renderGameObject os

updateGameState :: [Key] -> GameState -> GameState
updateGameState ks gs@(GameState { objects=os }) = newgs where
  newgs = GameState{objects = watcher $ concatMap (updateObject gs ks) os}

playerpos :: GameState -> Point
playerpos = position . findplayer
findplayer :: GameState -> GameObject
findplayer GameState{objects=os} = player where
  [player] = filter (\o -> case o of
    Player{} -> True
    _        -> False) os
findBoss :: GameState -> Maybe GameObject
findBoss GameState{objects=os} = if length bosses==0 then Nothing
                                  else Just (head bosses) where
  bosses = filter(\o -> case o of
    Enemy{} -> boss( enemySpec o)
    _        -> False) os

isGameover :: GameState -> Bool
isGameover GameState{objects=os} = (GameoverSignal `elem` os)

isClear :: GameState -> Bool
isClear GameState{objects=os} = (ClearSignal `elem` os)

type Point = (Double,Double)

(+++) :: (Double, Double) -> (Double, Double) -> (Double, Double)
(ax,ay) +++ (bx,by) = (ax+bx, ay+by)

(-+-) :: (Num t1, Num t) => (t, t1) -> (t, t1) -> (t, t1)
(ax,ay) -+- (bx,by) = (ax-bx,ay-by)

(*++) ::  (Num t) => (t, t) -> t -> (t, t)
(ax,ay) *++ (s) = (ax*s,ay*s)

(***) :: (Num t) => (t, t) -> (t, t) -> (t, t)
(ax,ay) *** (bx,by) = (ax * bx - ay * by, ay * bx + ax *by)

sq :: Double -> Double
sq x = x*x

distance, distance2 :: Point -> Point -> Double
distance a = sqrt . distance2 a
distance2 (ax,ay) (bx,by) = sq(ax-bx) + sq(ay-by)

outofmap :: Point -> Bool
outofmap (x,y) = (not $ abs x < 320) || (not $ abs y < 240)