Hate-0.1.4.2: samples/sample_asteroids.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-}

import Hate
import Hate.Graphics
import Vec2Lens (x,y)

import Control.Applicative
import Control.Lens
import System.Random

-- sample 4

data EntityState = EntityState {
    _pos :: Vec2,
    _vel :: Vec2,
    _rot :: Float,
    _rotVel :: Float
}
makeLenses ''EntityState

data Asteroid = Asteroid {
    _asteroidEntity :: EntityState,
    _size :: Int
}
makeLenses ''Asteroid
makeFields ''Asteroid

data Player = Player {
    _playerEntity :: EntityState
}
makeLenses ''Player
makeFields ''Player

data SampleState = SampleState {
    _playerSprite :: Sprite,
    _smallAsteroidSprite :: Sprite,
    _mediumAsteroidSprite :: Sprite,
    _bigAsteroidSprite :: Sprite,
    _asteroids :: [Asteroid],
    _player :: Player
}
makeLenses ''SampleState

data VisualRepresentation = SmallAsteroidSprite | MediumAsteroidSprite | BigAsteroidSprite | PlayerSprite
class ToVisual a where
    toVisual :: a -> VisualRepresentation

instance ToVisual Player where
    toVisual (Player _) = PlayerSprite

instance ToVisual Asteroid where
    toVisual (Asteroid _ sz) | sz < 2 = SmallAsteroidSprite
                             | sz < 4 = MediumAsteroidSprite
                             | otherwise = BigAsteroidSprite

randomAsteroids :: Int -> IO [Asteroid] 
randomAsteroids n = replicateM n randomAsteroid

randomAsteroid :: IO Asteroid
randomAsteroid = do
    px <- getStdRandom $ randomR (0,800)
    py <- getStdRandom $ randomR (0,800)
    vx <- getStdRandom $ randomR (-2, 2)
    vy <- getStdRandom $ randomR (-2, 2)
    vr <- getStdRandom $ randomR (-0.1, 0.1)
    sz <- getStdRandom $ randomR (1, 5)

    let e = EntityState (Vec2 px py) (Vec2 vx vy) 0 vr
    return $ Asteroid e sz

initialPlayer :: Player
initialPlayer = Player $ EntityState (Vec2 200 200) (Vec2 0 0) 0 0

sampleLoad :: LoadFn SampleState
sampleLoad = SampleState <$> loadSprite "samples/asteroids/ship.png" 
                         <*> loadSprite "samples/asteroids/asteroid_small.png" 
                         <*> loadSprite "samples/asteroids/asteroid_medium.png" 
                         <*> loadSprite "samples/asteroids/asteroid_big.png" 
                         <*> randomAsteroids 10
                         <*> pure initialPlayer

sampleDraw :: DrawFn SampleState
sampleDraw s = (map draw (s ^. asteroids)) ++ [draw (s ^. player)]
    where
        draw :: (HasEntity a EntityState, ToVisual a) => a -> DrawRequest
        draw a = (entityToTransform a) . sprite Middle . visualToSprite . toVisual $ a

        visualToSprite SmallAsteroidSprite = s ^. smallAsteroidSprite
        visualToSprite MediumAsteroidSprite = s ^. mediumAsteroidSprite
        visualToSprite BigAsteroidSprite = s ^. bigAsteroidSprite
        visualToSprite PlayerSprite = s ^. playerSprite

        entityToTransform :: HasEntity a EntityState => a -> DrawRequest -> DrawRequest
        entityToTransform a = let e = a ^. entity in ((rotated (e ^. rot)) . (translate (e ^. pos)))

sampleUpdate :: UpdateFn SampleState
sampleUpdate _ = do
    asteroids . traversed %= updateEntity
    player %= updateEntity
    steerShip
    where
        updateEntity :: HasEntity a EntityState => a -> a
        updateEntity a = a & (entity . pos +~ a ^. entity . vel)
                           & (entity . rot +~ a ^. entity . rotVel)
                           -- damping:
                           & (entity . vel *~ 0.99)
                           & (entity . rotVel *~ 0.99)
                           & screenWarp

        screenWarp a = a & (if a ^. entity . pos . x > 1024 then entity . pos . x -~ 1024 else id)
                         & (if a ^. entity . pos . y > 768  then entity . pos . y -~ 768 else id)
                         & (if a ^. entity . pos . x < 0 then entity . pos . x +~ 1024 else id)
                         & (if a ^. entity . pos . y < 0 then entity . pos . y +~ 768 else id)


        steerShip = do
            r <- use $ player . entity . rot
            whenKeyPressed Key'Up $ player . entity . vel += (rotateVec r (Vec2 0 (negate 1)))
            whenKeyPressed Key'Left $ player . entity . rotVel -= 0.01
            whenKeyPressed Key'Right $ player . entity . rotVel += 0.01

config :: Config
config = 
    Config
        { windowTitle = "Sample - Asteroids"
        , windowSize  = (1024, 768)
        }

main :: IO ()
main = runApp config sampleLoad sampleUpdate sampleDraw