content: {-# LANGUAGE Arrows #-}
  {-# LANGUAGE NoMonomorphismRestriction #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE StandaloneDeriving #-}
  module Main where
  
  import qualified Sounds
  
  import Prelude hiding ((.), id, mapM_, any, concatMap, concat)
  import qualified Prelude
  import Control.Monad (replicateM, void)
  import Data.Bits
  import Data.Word (Word8)
  import Control.Lens hiding (at, perform, wrapped)
  import Control.Wire hiding (until)
  import Data.Foldable
  import Data.Monoid
  import Paths_asteroids (getDataFileName)
  import Linear hiding ((*!))
  import qualified Data.Set as Set
  import qualified Graphics.UI.SDL as SDL
  import qualified Graphics.UI.SDL.Mixer as SDL
  import qualified Graphics.UI.SDL.Framerate as Framerate
  import qualified Graphics.UI.SDL.Primitives as SDL
  import qualified Graphics.UI.SDL.TTF as SDLTTF
  
  --------------------------------------------------------------------------------
  deriving instance Ord SDL.Keysym
  
  --------------------------------------------------------------------------------
  class Physical p where
    bounds :: p -> Bounds
  
  data Bounds = Circle (V2 Double) Double | Point (V2 Double)
  
  intersecting :: Bounds -> Bounds -> Bool
  intersecting (Circle x i) (Circle y j)  = norm (x - y) < (i + j)
  intersecting c@(Circle _ _) (Point p)   = intersecting c (Circle p 0)
  intersecting p@(Point _) c@(Circle _ _) = intersecting c p
  intersecting (Point _) (Point _)        = False
  
  colliding :: (Physical a, Physical b) => [a] -> b -> Bool
  colliding others this = intersectingAny (map bounds others) (bounds this)
  
  intersectingAny :: [Bounds] -> Bounds -> Bool
  intersectingAny others this = any (intersecting this) others
  
  --------------------------------------------------------------------------------
  data Asteroid = Asteroid { astPos :: V2 Double
                           , astGeneration :: Int
                           , astSize :: Double
                           , astVelocity :: V2 Double
                           , astSpikes :: [V2 Double]
                           }
  
  instance Physical Asteroid where
    bounds Asteroid{..} = Circle astPos astSize
  
  class Positioned p where
    position :: Functor f => (V2 Double -> f (V2 Double)) -> p -> f p
  
  instance Positioned Asteroid where
    position f x =  f (astPos x) <&> \b -> x { astPos = b }
  
  --------------------------------------------------------------------------------
  data Bullet = Bullet { bulletPos :: V2 Double }
  
  instance Physical Bullet where
    bounds Bullet{..} = Point bulletPos
  
  instance Positioned Bullet where
    position f x =  f (bulletPos x) <&> \b -> x { bulletPos = b }
  
  --------------------------------------------------------------------------------
  data Ship = Ship { shipPos :: V2 Double, shipRotation :: M22 Double }
  
  shipRadius :: Double
  shipRadius = 10
  
  instance Physical Ship where
    bounds Ship{..} = Circle shipPos shipRadius
  
  instance Positioned Ship where
    position f x =  f (shipPos x) <&> \b -> x { shipPos = b }
  
  --------------------------------------------------------------------------------
  data Frame = Frame { fShip :: Either [V2 Double] Ship
                     , fAsteroids :: [Asteroid]
                     , fBullets :: [Bullet]
                     , fScore :: Int
                     , fParticles :: [V2 Double]
                     , fUfo :: [UFO]
                     }
  
  data UFO = UFO { ufoPos :: V2 Double, ufoSize :: UFOSize }
  
  data UFOSize = Small | Large
  
  instance Positioned UFO where
    position f x =  f (ufoPos x) <&> \b -> x { ufoPos = b }
  
  instance Physical UFO where
    bounds UFO{..} = Circle ufoPos $ case ufoSize of
                                       Small -> 10
                                       Large -> 30
  
  --------------------------------------------------------------------------------
  render :: SDL.Surface -> SDLTTF.Font -> Frame -> IO ()
  render screen font Frame{..} = do
    void $ SDL.mapRGB (SDL.surfaceGetPixelFormat screen) 0 0 0 >>=
      SDL.fillRect screen Nothing
  
    mapM_ renderAsteroid fAsteroids
    mapM_ (renderBounds . bounds) fBullets
    mapM_ renderPoint fParticles
    mapM_ renderUfo fUfo
    renderShip fShip
  
    scoreS <-
      SDLTTF.renderTextSolid font ("SCORE: " ++ show fScore)
        (SDL.Color 255 255 255)
  
    SDL.blitSurface scoreS Nothing screen (Just $ SDL.Rect 20 20 100 50)
  
    SDL.flip screen
  
   where
  
    renderBounds (Circle (V2 x y) r) =
      SDL.circle screen (round x) (round y) (round r) white
  
    renderBounds (Point p) = renderPoint p
  
    renderPoint (V2 x y) =
      SDL.pixel screen (round x) (round y) white
  
    renderLine (V2 x y) (V2 x' y') =
      SDL.line screen (round x) (round y) (round x') (round y') white
  
    renderAsteroid Asteroid{..} = renderPolygon $ map (+ astPos) astSpikes
  
    renderPolygon points =
      mapM_ (uncurry renderLine) (zip points (tail points ++ points))
  
    renderShip (Left particles) = mapM_ renderPoint particles
  
    renderShip (Right Ship{..}) =
      let v1 = V2 (-0.5) 1
          v2 = V2 0 0.5
          v3 = V2 0.5 1
          v4 = V2 0 (-1)
      in renderPolygon $
        map ((+ shipPos) . (shipRotation !*). (^* shipRadius)) [v1, v2, v3, v4]
  
    renderUfo = renderBounds . bounds
  
    white = rgbColor 255 255 255
  
  rgbColor :: Word8 -> Word8 -> Word8 -> SDL.Pixel
  rgbColor r g b = SDL.Pixel (shiftL (fi r) 24 .|.
                              shiftL (fi g) 16 .|.
                              shiftL (fi b) 8  .|.
                              255)
    where fi = fromIntegral
  
  --------------------------------------------------------------------------------
  main :: IO ()
  main = SDL.withInit [SDL.InitEverything] $ do
    screen <- SDL.setVideoMode 800 600 0 [SDL.SWSurface]--, SDL.Fullscreen]
  
    SDLTTF.init
    ttfFilePath <- getDataFileName "fonts/beams-font/Beams.ttf"
    ka1 <- SDLTTF.openFont ttfFilePath 10
    frameRate <- Framerate.new
    Framerate.init frameRate
    Framerate.set frameRate 120
  
    let audioSampleRate = 22050
    [explosionChunk, pew, deathSound, ufoSound] <-
      mapM (Sounds.render audioSampleRate)
        [Sounds.explosion, Sounds.pew, Sounds.death, Sounds.ufo]
    SDL.openAudio audioSampleRate SDL.AudioU8 2 512
  
    go screen ka1 Set.empty clockSession
      (playForever explosionChunk pew deathSound ufoSound)
      frameRate
  
   where
  
    playForever c d e f = game 4 0
      where
        game n score =
          let progress (LevelOver Cleared finalScore) =
                game (min 12 $ succ n) finalScore
  
              progress (LevelOver Crashed _) = game 4 0
  
          in switchBy progress (asteroidsRound n c d e f score)
  
    go screen font keysDown s w frameRate = do
      keysDown' <- parseEvents keysDown
      (r, w', s') <- stepSession w s keysDown'
  
      case r of
        Right frame -> do
          render screen font frame
          Framerate.delay frameRate
  
          go screen font keysDown' s' w' frameRate
  
        Left _ -> return ()
  
  
    parseEvents keysDown = do
      e <- SDL.pollEvent
      case e of
        SDL.NoEvent -> return keysDown
        SDL.KeyDown k ->
          let keyset = Set.insert k keysDown
          in if keyDown SDL.SDLK_q keyset then undefined
               else parseEvents keyset
        SDL.KeyUp k -> parseEvents (Set.delete k keysDown)
        _ -> parseEvents keysDown
  
  --------------------------------------------------------------------------------
  keyDown :: Foldable f => SDL.SDLKey -> f SDL.Keysym -> Bool
  keyDown = elemOf (folded . to SDL.symKey)
  
  --------------------------------------------------------------------------------
  data EndReason = Cleared | Crashed
  
  data LevelOver = LevelOver EndReason Int
  
  instance Monoid LevelOver where
    mempty = LevelOver Crashed 0
    mappend (LevelOver Crashed n) (LevelOver Crashed m) = LevelOver Crashed (max n m)
    mappend (LevelOver _ n) (LevelOver _ m) = LevelOver Cleared (max n m)
  
  asteroidsRound
    :: Int
    -> SDL.Chunk -> SDL.Chunk -> SDL.Chunk -> SDL.Chunk
    -> Int
    -> Wire LevelOver IO (Set.Set SDL.Keysym) Frame
  asteroidsRound nAsteroids c d e f initialScore = proc keysDown -> do
    -- Ship, asteroids, bullets
    rec
      -- Step all remaining bullets, ufos and asteroids
      bulletAutos <- stepWires . delay [] -< activeBullets
      ufoAutos <- stepWires . delay [] -< activeUfos
      asteroidAutos <- stepWires . initialAsteroids -< activeAsteroids
  
      -- Smash it all together!
      (remainingBullets, remainingAsteroids, remainingUfos, removedAsteroids, removedUfos) <-
        collide -< (bulletAutos, asteroidAutos, ufoAutos)
  
      -- Split asteroids that have collided with anything
      newAsteroids <- splitAsteroids -< map fst removedAsteroids
  
      -- Move the player
      (p, newBulletWires) <- player e -<
        (keysDown, map (bounds . fst) remainingAsteroids ++
                   map (bounds . fst . fst) remainingUfos ++
                   map (bounds . fst) remainingBullets)
  
      -- Randomly spawn a UFO
      newUfoWires <- pure [ largeUfo ] . ufoSpawned <|> pure [] -< ()
  
      -- Finally bind the remaining/new entities to be used in the next frame
      activeBullets <- returnA -< newBulletWires ++ map snd remainingBullets
                                   ++ concatMap (snd . fst) ufoAutos
      activeAsteroids <- returnA -< newAsteroids ++ map snd remainingAsteroids
      activeUfos <- returnA -< newUfoWires ++ map snd remainingUfos
  
    -- Points/explosions
    let asteroidExplosions = removedAsteroids ^.. folded . _1 . position
    let ufoExplosions = removedUfos ^.. folded . _1 . _1 . position
    particles <- particleSystems -< asteroidExplosions ++ ufoExplosions
    points <- countFrom initialScore -< sumOf (folded._1.to score) removedAsteroids
  
    -- Sound effects
    playForList c 0 False -< asteroidExplosions ++ ufoExplosions
    playForList d 1 False -< newBulletWires
    playForList f 3 True -< newUfoWires
    exhibit (stopChannel 3 . edge (== 0)) -< length activeUfos
  
    -- End game semantics
    first (unless (== 0)) --> for 2 --> second clearLevel -<
      (length activeAsteroids, points)
  
    returnA -< Frame { fShip = p
                     , fAsteroids = map fst asteroidAutos
                     , fBullets = map fst bulletAutos
                     , fScore = points
                     , fParticles = particles
                     , fUfo = ufoAutos ^.. traverse . _1 . _1
                     }
  
   where
  
    stopChannel n = mkGen $ \_ a -> do
      SDL.haltChannel n
      return (Right a, stopChannel n)
  
    playForList chunk channel loopChunk =
      exhibit (once . playChunk channel chunk loopChunk . edge (not . null))
  
    clearLevel = mkFix $ \_ points -> Left $ LevelOver Cleared points
  
    score Asteroid{..}
      | astGeneration == 1 = 10
      | astGeneration == 2 = 50
      | astGeneration == 3 = 100
      | otherwise          = 0
  
    initialAsteroids = mkGen $ \dt a -> do
      wires <- replicateM nAsteroids $
        asteroid 1
          <$> getRandomR (20, 40)
          <*> (V2 <$> getRandomR (0, 800) <*> getRandomR (0, 600))
          <*> randomVelocity (10, 20)
      stepWire (delay wires) dt a
  
    splitAsteroids = mkFixM $ \_ asteroids ->
      (Right . concat) <$> mapM splitAsteroid asteroids
  
    splitAsteroid Asteroid{..}
      | astGeneration < 3 = do
          let mkAsteroid vel =
                asteroid (succ astGeneration) (astSize / 2) astPos (vel ^* 3)
              mag = ( fromIntegral $ astGeneration * 20
                    , fromIntegral $ (astGeneration + 1) * 20)
          replicateM 2 (mkAsteroid <$> randomVelocity mag)
      | otherwise         = return []
  
    ufoSpawned = (once --> ufoSpawned) . wackelkontaktM (1 / 1000) . after 30
  
    collide = mkFix $ \_ (bullets, asteroids, ufos) ->
      let activeBullets = filter (not . ((||) <$> colliding (map fst asteroids) <*> colliding (map (fst . fst) ufos)) . fst) bullets
          activeAsteroids = filter (not . colliding (map fst bullets) . fst) asteroids
          destroyedAsteroids = filter (colliding (map fst bullets) . fst) asteroids
          activeUfos =
            filter ( not . ((||) <$> colliding (map fst asteroids) <*> colliding (map fst bullets)) . fst . fst) ufos
          destroyedUfos =
            filter ( ((||) <$> colliding (map fst asteroids) <*> colliding (map fst bullets)) . fst . fst) ufos
      in Right (activeBullets, activeAsteroids, activeUfos, destroyedAsteroids, destroyedUfos)
  
  --------------------------------------------------------------------------------
  randomVelocity
    :: (Applicative m, MonadRandom m) => (Double, Double) -> m (V2 Double)
  randomVelocity magRange = do
    v <- V2 <$> getRandomR (-1, 1) <*> getRandomR (-1, 1)
    mag <- getRandomR magRange
    return (normalize v ^* mag)
  
  --------------------------------------------------------------------------------
  particleSystems
    :: (Applicative m, MonadRandom m) => Wire e m [V2 Double] [V2 Double]
  particleSystems = go []
   where
    go systems = mkGen $ \dt newSystemLocations -> do
      stepped <- mapM (\w -> stepWire w dt ()) systems
  
      let alive = [ (r, w) | (Right r, w) <- stepped ]
      spawned <- concat <$> mapM spawnParticles newSystemLocations
  
      return (Right (map fst alive), go $ map snd alive ++ spawned)
  
    spawnParticles at = do
      n <- getRandomR (4, 8)
      replicateM n $ do
        velocity <- randomVelocity (5, 10)
        life <- getRandomR (1, 3)
        return ((for life <!> ()). integrateVector at . pure velocity)
  
  --------------------------------------------------------------------------------
  player
    :: (Monoid e, Monad m)
    => SDL.Chunk
    -> Wire LevelOver IO
         (Set.Set SDL.Keysym, [Bounds])
         (Either [V2 Double] Ship, [Wire e m () Bullet])
  player deathSound = proc (keysDown, activeAsteroids) -> do
    ship <- fly -< keysDown
    arr snd . (notColliding *** aliveShip) --> arr fst . first explode
      -< ((ship, activeAsteroids), (ship, keysDown))
  
   where
    fly = proc keysDown -> do
      rotation <- rotationMatrix <$> (integral_ 0 . inputRotation) -< keysDown
      thrust <- inputAcceleration -< keysDown
  
      pos <- wrapped .
             integrateVector (V2 (800 / 2) (600 / 2)) .
             integrateVectorUpTo 0 100 -< rotation !* thrust
  
      returnA -< Ship pos rotation
  
    notColliding = mkFix $ \_ a@(ship, asteroids) ->
      if intersectingAny asteroids (bounds ship)
          then Left mempty
          else Right a
  
    explode = proc (ship, _) -> do
      exhibit (playChunk 2 deathSound False . once) -< ()
      particles <- particleSystems . (once --> pure []) -< [ship ^. position]
      for 3 . returnA -< (Left particles, [])
  
    aliveShip = proc (ship, keysDown) -> do
      newBulletWires <- fire -< (ship, keysDown)
      returnA -< (Right ship, newBulletWires)
  
    inputAcceleration  =  pure (V2 0 (-75)) . when (keyDown SDL.SDLK_UP)
                      <|> 0
  
    inputRotation  =  negate pi . when (keyDown SDL.SDLK_LEFT)
                  <|> pi . when (keyDown SDL.SDLK_RIGHT)
                  <|> pure (0 :: Double)
  
    bulletWire ship =
      let velocity = shipRotation ship !* V2 0 (-300)
      in bullet (shipPos ship + (normalize velocity ^* (shipRadius * 1.1))) velocity
  
    fire = let tryShoot = proc (p, keysDown) -> do
                 isShooting -< keysDown
                 returnA -< [ bulletWire p ]
           in tryShoot <|> pure []
  
  --------------------------------------------------------------------------------
  bullet :: (Monad m, Monoid e) => V2 Double -> V2 Double -> Wire e m a Bullet
  bullet initialPosition bulletVelocity = for 1.5 . aBullet
    where
      aBullet = Bullet <$> wrapped . integrateVector initialPosition .
                           pure bulletVelocity
  
  --------------------------------------------------------------------------------
  playChunk :: SDL.Channel -> SDL.Chunk -> Bool -> Wire e IO a a
  playChunk channel chunk loopChunk = mkFixM $ \_ a -> do
    SDL.haltChannel channel
    SDL.playChannel channel chunk (if loopChunk then (-1) else 0)
    return (Right a)
  
  --------------------------------------------------------------------------------
  integrateVector
    :: (Functor f, Num (f Time), Metric f)
    => f Double -> Wire e m (f Double) (f Double)
  integrateVector = accumT step where step dt a b = a + dt *^ b
  
  --------------------------------------------------------------------------------
  integrateVectorUpTo
    :: (Functor f, Num (f Time), Metric f)
    => f Double -> Double -> Wire e m (f Double) (f Double)
  integrateVectorUpTo c m = accumT step c
    where step dt a b = let v' = a + dt *^ b
                            n = norm v'
                        in if n > m then normalize v' ^* m else v'
  
  --------------------------------------------------------------------------------
  rotationMatrix :: Floating a => a -> M22 a
  rotationMatrix r = V2 (V2 (cos r) (-(sin r)))
                        (V2 (sin r) (  cos r) )
  
  --------------------------------------------------------------------------------
  asteroid
    :: (Monad m, MonadRandom m)
    => Int -> Double -> V2 Double -> V2 Double -> Wire e m a Asteroid
  asteroid generation size initialPosition velocity = proc _ -> do
    spikes <- randomSpikes -< size
    pos <- wrapped . integrateVector initialPosition . pure velocity -< ()
    returnA -< Asteroid pos generation size velocity spikes
  
   where
  
    randomSpikes = mkGen $ \_ _ -> do
      let mkSpike i = do
            mag <- getRandomR (size / 2, size)
            theta <- getRandomR (i * (2 * pi) / 7, (i + 1) * (2 * pi) / 7)
            return $ rotationMatrix theta !* V2 0 mag
      spikes <- mapM mkSpike [0..6]
      return (Right spikes, pure spikes)
  
  --------------------------------------------------------------------------------
  wrapped :: Wire e m (V2 Double) (V2 Double)
  wrapped = mkFix $ \_ (V2 x y) ->
    let x' = until (>= 0) (+ 800) $ until (<= 800) (subtract 800) x
        y' = until (>= 0) (+ 600) $ until (<= 600) (subtract 600) y
    in Right (V2 x' y')
  
  --------------------------------------------------------------------------------
  isShooting :: (Foldable f, Monad m, Monoid e) => Event e m (f SDL.Keysym)
  isShooting =
    asSoonAs (keyDown SDL.SDLK_SPACE) >>> (once --> coolDown >>> isShooting)
  
   where
  
    coolDown =
      arr head . multicast [ after 0.05, asSoonAs (not . keyDown SDL.SDLK_SPACE) ]
  
  --------------------------------------------------------------------------------
  stepWires :: Monad m => Wire e m [Wire e m () b] [(b, Wire e m () b)]
  stepWires = mkFixM $ \dt objects -> do
    stepped <- mapM (\o -> stepWire o dt ()) objects
    return $ Right [ (o, w') | (Right o, w') <- stepped ]
  
  --------------------------------------------------------------------------------
  largeUfo
    :: (Monad m, MonadRandom m, Monoid e)
    => Wire e m a (UFO, [Wire e m a Bullet])
  largeUfo = proc _ -> do
    pos <- require onScreen . ufoPos -< ()
    shotsFired <- shoot <|> pure [] -< pos
  
    returnA -< (UFO pos Small, shotsFired)
  
   where
  
    shoot = proc currentPos -> do
      periodically 1 -< ()
      velocity <- (!* V2 0 300) . rotationMatrix <$> noiseRM . pure (0, 2 * pi) -< ()
      returnA -< [bullet (currentPos + (normalize velocity ^* 30)) velocity]
  
    ufoPos = let x = integrateVector (V2 0 0) . pure (V2 80 0)
                 y = V2 0 <$> randomConstant (0, 600) + 5 * (arr sin . (time * 10))
          in (+) <$> x <*> y
  
    onScreen (V2 x _) = x >= 0 && x < 800
  
    randomConstant range = mkGen $ \_ _ -> do
      x <- getRandomR range
      return (Right x, pure x)
  