haskell-games/snake/app/Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE LambdaCase #-}

module Main where

import Data.Text qualified as T
import Data.Text (Text)
import Snake
import SDL.Video qualified as SDL
import SDL.Video.Renderer qualified as SDL
import SDL.Input.Keyboard qualified as SDL
import SDL.Init qualified as SDL
import SDL.Vect qualified as SDL
import SDL.Event qualified as SDL
import Control.Exception
import Control.Monad
import Control.Monad.Extra (whileM, whenM)
import Data.IORef
import Effectful
import Effectful.State.Static.Local
import SDL (($=))
import SDL.Image qualified as SDLI
import Control.Lens hiding ((.=), (%=))
import Foreign.C
import Effectful.Reader.Static
import Data.Vector.Storable qualified as SV
import System.Random

data Point = Point Int Int
  deriving (Show, Eq)
data Square = Square Point Point
  deriving (Show, Eq)

scalePoint :: Int -> Point -> Point
scalePoint scale (Point x y) = Point (x * scale) (y * scale)

addPoint :: Point -> Point -> Point
addPoint (Point x1 y1) (Point x2 y2) = Point (x1 + x2) (y1 + y2)

directionOpposite :: Direction -> Direction
directionOpposite direction = case direction of
  East -> West
  West -> East
  North -> South
  South -> North

directionToPoint :: Direction -> Point
directionToPoint direction =
  case direction of
    East -> Point 1 0
    West -> Point (-1) 0
    North -> Point 0 (-1)
    South -> Point 0 1

clampPoint :: (Int, Int) -> Point -> Point
clampPoint (width, height) (Point x y) = Point x' y'
  where
    x' = clamp x width
    y' = clamp y height
    clamp coord size =
      case coord of
        coord | coord < 0 -> size + coord
        coord -> coord `rem` size

pointToSquare :: Int -> Point -> Square
pointToSquare scale point@(Point x y) = Square (scalePoint scale point) (Point scale scale)

pointToV2 :: Integral i => Point -> SDL.V2 i
pointToV2 (Point x y) = SDL.V2 (fromIntegral x) (fromIntegral y)

squareToRectangle :: Integral i => Square -> SDL.Rectangle i
squareToRectangle (Square (Point x y) (Point width height)) = SDL.Rectangle (SDL.P (SDL.V2 (fromIntegral x) (fromIntegral y))) (SDL.V2 (fromIntegral width) (fromIntegral height))

data Direction
  = East
  | West
  | North
  | South
  deriving (Eq, Show)

data Snake
  = Snake
  { head :: Point
  , body :: [Point]
  , direction :: Direction
  , growth :: Int
  }
  deriving Show
makeLensesFor
  [ ("head", "head")
  , ("body", "body")
  , ("growth", "growth")
  , ("direction", "direction")
  ] ''Snake

data WorldState
  = WorldState
  { snake :: Snake
  , apple :: Maybe Point
  , gameOver :: Bool
  }
  deriving Show
makeLensesFor
  [ ("snake", "snake")
  , ("apple", "apple")
  , ("gameOver", "gameOver")
  ] ''WorldState

data GameState
  = GameState
  { run :: Bool
  , pastWorldStates :: [WorldState]
  , worldState :: WorldState
  , frameNumber :: Int
  , reverseTime :: Bool
  }
  deriving Show
makeLensesFor
  [ ("run", "run")
  , ("pastWorldStates", "pastWorldStates")
  , ("frameNumber", "frameNumber")
  , ("worldState", "worldState")
  , ("reverseTime", "reverseTime")
  ] ''GameState

initialWorldState :: WorldState
initialWorldState
  = WorldState
  { snake
  = Snake
    { head = Point 2 0
    , body = [ Point 1 0, Point 0 0 ]
    , growth = 0
    , direction = East
    }
  , apple = Nothing
  , gameOver = False
  }

initialGameState :: GameState
initialGameState
  = GameState
  { run = True
  , pastWorldStates = []
  , worldState = initialWorldState
  , frameNumber = 0
  , reverseTime = False
  }

data GameConfig
  = GameConfig
  { gridDimensions :: (Int, Int)
  , updatesPerSecond :: Int
  }
  deriving Show
makeLensesFor
  [ ("gridDimensions", "gridDimensions")
  , ("updatesPerSecond", "updatesPerSecond")
  ] ''GameConfig

(.=) :: State s :> es => ASetter s s a b -> b -> Eff es ()
l .= b = modify (l .~ b)
{-# INLINE (.=) #-}

(%=) :: State s :> es => ASetter s s a b -> (a -> b) -> Eff es ()
l %= f = modify (l %~ f)
{-# INLINE (%=) #-}

(%.=) :: State s :> es => Lens s s a b -> (s -> b) -> Eff es ()
l %.= f = modify (\s -> l %~ const (f s) $ s)
{-# INLINE (%.=) #-}

renderHead
  :: Snake
  -> Eff es (Point, SDL.Rectangle CInt)
renderHead snake = do
  let scale = 20
  let texture = case snake.direction of
        East -> Point 0 0
        West -> Point 1 1
        South -> Point 0 2
        North -> Point 1 2

  pure $ ((texture,) . squareToRectangle . pointToSquare scale) snake.head

renderSnake
  :: (Reader GameConfig :> es)
  => Snake
  -> Eff es [(Point, SDL.Rectangle CInt)]
renderSnake snake = do
  let scale = 20
  pure $ map ((Point 1 0,) . squareToRectangle . pointToSquare scale) snake.body

renderApple
  :: ()
  => Point
  -> Eff es (Point, SDL.Rectangle CInt)
renderApple apple = do
  let scale = 20
  pure $ ((Point 0 1,) . squareToRectangle . pointToSquare scale) apple

moveSnake
  :: (Reader GameConfig :> es, State Snake :> es)
  => Direction
  -> Eff es ()
moveSnake direction = do
  dims <- asks @GameConfig (\s -> s.gridDimensions)
  newLength <- gets @Snake \snake ->
    if snake.growth > 0 then
      length snake.body
    else
      length snake.body - 1

  body %.= \snake -> snake.head : take newLength snake.body
  Main.head %= (clampPoint dims . addPoint (directionToPoint direction))
  growth %= \growth ->
    if growth > 0 then
      growth - 1
    else
      growth

  pure ()

changeDirection
  :: (State GameState :> es)
  => Direction
  -> Eff es ()
changeDirection dir = do
  lastDirection <- gets @GameState (\s -> (Prelude.head s.pastWorldStates).snake.direction)
  when (dir /= directionOpposite lastDirection) $ (worldState . snake . direction) .= dir

setReversed
  :: (State GameState :> es)
  => Bool
  -> Eff es ()
setReversed r = do
  reverseTime .= r

promoteWorldState
  :: (State GameState :> es)
  => Eff es ()
promoteWorldState =
  pastWorldStates %.= (\state -> state.worldState : state.pastWorldStates)

eatApple
  :: (State GameState :> es, Reader GameConfig :> es, State StdGen :> es)
  => Eff es ()
eatApple = do
  (worldState . apple) .= Nothing
  (worldState . snake . growth) %= (+) 3
  genApple

isGameOver
  :: (State GameState :> es)
  => Eff es Bool
isGameOver = do
  gets @GameState (\s -> s.worldState.snake.head `elem` s.worldState.snake.body)

step
  :: (State GameState :> es, Reader GameConfig :> es, State StdGen :> es, IOE :> es)
  => Eff es ()
step =
  gets @GameState (\s -> s.reverseTime) >>=
  \case
    True -> do
      gets @GameState (\s -> s.pastWorldStates) >>= \case
        [] -> pure ()
        [a] -> pure ()
        _ -> do
          worldState %.= \s -> Prelude.head . tail $ s.pastWorldStates
          pastWorldStates %= \s -> tail s
    False ->
      gets @GameState (\s -> s.worldState.gameOver) >>= \case
        False -> do
          get @GameState >>= \state -> execState state.worldState.snake (moveSnake state.worldState.snake.direction) >>= (.=) (worldState . snake)

          snakeHead <- gets @GameState (\s -> s.worldState.snake.head)
          gets @GameState (\s -> s.worldState.apple) >>= \case
            Just apple | apple == snakeHead -> eatApple
            Nothing -> genApple
            _ -> pure ()

          whenM isGameOver $ do
            (worldState . gameOver) .= True
            liftIO . putStrLn $ "Game Over"

          promoteWorldState
        True -> pure ()

renderSprite
  :: (IOE :> es)
  => SDL.Renderer
  -> SDL.Texture
  -> (Point, SDL.Rectangle CInt)
  -> Eff es ()
renderSprite renderer texture (textureRect, rect) = SDL.copy renderer texture (Just (SDL.Rectangle (SDL.P (scalePoint 512 textureRect & pointToV2)) (SDL.V2 512 512))) (Just rect)

render
  :: (State GameState :> es, IOE :> es, Reader GameConfig :> es)
  => SDL.Renderer
  -> SDL.Texture
  -> Eff es ()
render renderer texture = do
  SDL.rendererDrawColor renderer $= SDL.V4 255 255 255 0
  SDL.clear renderer

  snake <- gets @GameState (\s -> s.worldState.snake)
  snakeSprites <- renderSnake snake
  mapM_ (renderSprite renderer texture) snakeSprites

  gets @GameState (\s -> s.worldState.apple) >>= \case
    Just apple -> renderApple apple >>= renderSprite renderer texture
    Nothing -> pure ()

  renderHead snake >>= renderSprite renderer texture

  whenM (gets @GameState (\s -> s.worldState.gameOver)) $ pure () -- show text, but sdl_ttf sucks

  SDL.present renderer

randomRange
  :: (State StdGen :> es)
  => (Int, Int)
  -> Eff es Int
randomRange range =
  get @StdGen <&> uniformR range >>= \(a, g) -> put g >> pure a

getFreeSpaces
  :: (State GameState :> es, Reader GameConfig :> es)
  => Eff es [Point]
getFreeSpaces = do
  snakeBody <- gets @GameState (\s -> s.worldState.snake.body)
  snakeHead <- gets @GameState (\s -> s.worldState.snake.head)
  (width, height) <- asks @GameConfig (\s -> s.gridDimensions)

  [0..(width * height)] & map (\i -> Point (i `rem` width) (i `div` width)) & filter (\point -> snakeHead /= point && point `notElem` snakeBody) & pure

genApple
  :: (State GameState :> es, Reader GameConfig :> es, State StdGen :> es)
  => Eff es ()
genApple = do
  freeSpaces <- getFreeSpaces
  appleIndex <- randomRange (0, length freeSpaces - 1)

  (worldState . apple) .= Just (freeSpaces !! appleIndex)

  pure ()

main :: IO ()
main =
  let
    rendererConfig
      = SDL.defaultRenderer
      { SDL.rendererType = SDL.AcceleratedVSyncRenderer
      }
    windowConfig
      = SDL.defaultWindow
      { SDL.windowInitialSize = SDL.V2 400 400
      }
    gameConfig
      = GameConfig
      { gridDimensions = (20, 20)
      , updatesPerSecond = 1
      }
  in
    bracket (SDL.initialize [ SDL.InitEvents, SDL.InitVideo ]) (const SDL.quit) $ \_ ->
    bracket (SDL.createWindow "Snake" windowConfig) SDL.destroyWindow $ \window ->
    bracket (SDL.createRenderer window (-1) rendererConfig) SDL.destroyRenderer $ \renderer ->
    initStdGen >>= \rng ->
    SDLI.loadTexture renderer "textures/atlas.png" >>= \texture ->

    runEff . runReader gameConfig . evalState initialGameState . evalState rng $ genApple >> promoteWorldState >> whileM do
      SDL.rendererScale renderer $= SDL.V2 1.0 1.0
      -- SDL.rendererViewport renderer $= Just (SDL.Rectangle 640 480)
      events <- SDL.pollEvents

      forM_ events \(SDL.Event _ payload) -> case payload of
        SDL.KeyboardEvent (SDL.KeyboardEventData _ motion repeat (SDL.Keysym _ code modifier)) ->
          case code of
            SDL.KeycodeQ | motion == SDL.Pressed -> modify (run .~ False)
            SDL.KeycodeEscape | motion == SDL.Pressed -> modify (run .~ False)
            SDL.KeycodePeriod | motion == SDL.Pressed -> changeDirection North
            SDL.KeycodeA | motion == SDL.Pressed -> changeDirection South
            SDL.KeycodeH | motion == SDL.Pressed -> changeDirection West
            SDL.KeycodeE | motion == SDL.Pressed -> changeDirection East
            SDL.KeycodeComma -> setReversed (motion == SDL.Pressed)
            _ -> pure ()
        SDL.QuitEvent -> modify (run .~ False)
        _ -> pure ()


      frameNumber %= (+) 1

      whenM (gets @GameState (\s -> s.frameNumber `rem` 60 == 0)) step

      -- getFreeSpaces >>= liftIO . print

      render renderer texture

      gets @GameState (\s -> s.run)