Main.hs

{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}

import qualified Codec.Compression.Kosinski     as Kosinski
import           Control.Lens
import           Control.Monad.Except
import           Control.Monad.Reader
import           Control.Monad.State
import           Data.Array.Bounded
import           Data.Array.Bounded             ((!))
import           Data.Bits
import qualified Data.ByteString                as BS
import           Data.ByteString.Lens
import           Data.Halves                    (collectHalves)
import           Data.Int
import           Data.Maybe                     (fromMaybe)
import           Data.Semigroup                 ((<>))
import           Data.Time                      (diffUTCTime, getCurrentTime)
import           Data.Word
import           Foreign.C.Types                (CInt)
import           Game.Sega.Sonic.Animation
import           Game.Sega.Sonic.Blocks
import           Game.Sega.Sonic.Chunks
import           Game.Sega.Sonic.Collision
import           Game.Sega.Sonic.Error
import           Game.Sega.Sonic.Game
import           Game.Sega.Sonic.Layout
import           Game.Sega.Sonic.Offsets        as Offsets
import           Game.Sega.Sonic.Palette
import           Game.Sega.Sonic.Player
import           Game.Sega.Sonic.Sine
import           Game.Sega.Sonic.SpriteMappings
import           Game.Sega.Sonic.Sprites
import           Game.Sega.Sonic.Tiles
import           SDL
import           Sega.MegaDrive.Palette

import           Numeric
import           Debug.Trace

decompressFile :: (HasRom g, MonadReader g m, MonadError SonicError m, MonadIO m) => Offset -> m BS.ByteString
decompressFile offset = do
  maybeContent <- Kosinski.compressed <$> sliceRom offset
  content <- maybe (throwError $ SonicLoadError offset) pure maybeContent
  maybe (throwError $ SonicDecompressionError offset) pure $ Kosinski.decompress content

-- NTSC
frameRate :: Double
frameRate =
  60

class HasLevel s where
  layout :: s -> [[Word8]]
  chunkBlocks :: s -> BoundedArray Word8 (BoundedArray Word8 ChunkBlock)

data LevelData
  = LevelData AngleData [[Word8]] (BoundedArray Word8 (BoundedArray Word8 ChunkBlock))

instance HasAngleData LevelData where
  angleData (LevelData a _ _) =
    a

instance HasLevel LevelData where
  layout (LevelData _ a _) =
    a
  chunkBlocks (LevelData _ _ a) =
    a

findTile :: (HasLevel s, MonadReader s m) => V2 CInt -> m Word16
findTile p = do
  layout' <- asks layout
  let
    p' =
      p ^. pixels
    V2 layoutX layoutY =
      (`div` 0x80) <$> p'
    chunkIndex =
      layout' !! fromIntegral layoutY !! fromIntegral layoutX
    blockIndex =
      fromIntegral chunkIndex * (0x80 :: Word16)
        + fromIntegral (p' ^. _y .&. 0x70)
        + fromIntegral (p' ^. _x .&. 0xE)
  pure blockIndex

data WallDist
  = WallDist Word16 CInt Word8
  deriving (Eq, Ord, Show)

-- Scans horizontally for up to 2 16x16 blocks to find solid walls.
-- d2 = y_pos
-- d3 = x_pos
-- d5 = ($c,$d) or ($e,$f) - solidity type bit (L/R/B or top)
-- d6 = $0000 for no flip, $0400 for horizontal flip
-- a3 = delta-x for next location to check if current one is empty
-- a4 = pointer to angle buffer
-- returns relevant block ID in (a1)
-- returns distance to left/right in d1
-- returns angle in (a4)
findWall :: (HasLevel s, MonadReader s m) => V2 CInt -> CInt -> m WallDist
findWall p delta = do
  blockIndex <- findTile p
  if blockIndex .&. 0x3FF == 0
  then do
    WallDist a1 d1 a4 <- findWall2 (p & _x +~ delta)
    -- dist & distance +~ 0x10
    pure $ WallDist a1 (d1 + 0x10) a4
  else do
    let
      d1 =
        0
      a4 =
        0
    pure $ WallDist blockIndex d1 a4

findWall2 :: (HasLevel s, MonadReader s m) => V2 CInt -> m WallDist
findWall2 p = do
  blockIndex <- (.&. 0x3FF) <$> findTile p
  if blockIndex == 0
  then do
    let
      d1 =
        0xF - (p ^. _x .&. 0xF)
    pure $ WallDist blockIndex d1 0
  else do
    let
      d1 =
        0
      a4 =
        0
    pure $ WallDist blockIndex d1 a4

findFloor :: (HasLevel s, MonadReader s m) => V2 CInt -> CInt -> m WallDist
findFloor p delta = do
  blockIndex <- (.&. 0x3FF) <$> findTile p
  let d5 = 0xC
  if blockIndex == 0 || not (testBit blockIndex d5)
  then do
    WallDist a1 d1 a4 <- findFloor2 (p & _y +~ delta)
    -- dist & distance +~ 0x10
    pure $ WallDist a1 (d1 + 0x10) a4
  else do
    let
      d1 =
        0
      a4 =
        0
    pure $ WallDist blockIndex d1 a4

findFloor2 :: (HasLevel s, MonadReader s m) => V2 CInt -> m WallDist
findFloor2 p = do
  blockIndex <- (.&. 0x3FF) <$> findTile p
  let d5 = 0xC
  if blockIndex == 0 || not (testBit blockIndex d5)
  then do
    let
      d1 =
        0xF - (p ^. _y .&. 0xF)
    pure $ WallDist blockIndex d1 0
  else do
    let
      d1 =
        0
      a4 =
        0
    pure $ WallDist blockIndex d1 a4

-- Checks a 16x16 block to find solid walls. May check an additional
-- 16x16 block up for walls.
-- d5 = ($c,$d) or ($e,$f) - solidity type bit (L/R/B or top)
-- returns relevant block ID in (a1)
-- returns distance in d1
-- returns angle in d3, or zero if angle was odd
checkLeftWallDist :: (HasLevel r, MonadReader r m, HasPlayer s, MonadState s m) => m WallDist
checkLeftWallDist = do
  p <- use (player . position)
  findWall p (-0x10)

checkRightWallDist :: (HasLevel r, MonadReader r m, HasPlayer s, MonadState s m) => m WallDist
checkRightWallDist = do
  p <- use (player . position)
  findWall p (0x10)

checkCeiling :: (HasLevel r, MonadReader r m, HasPlayer s, MonadState s m) => m WallDist
checkCeiling = do
  p <- use (player . position)
  findFloor p (-0x10)

checkFloor :: (HasLevel r, MonadReader r m, HasPlayer s, MonadState s m) => m WallDist
checkFloor = do
  p <- use (player . position)
  findFloor p 0x10

hitLeftWall :: (HasLevel r, MonadReader r m, HasPlayer s, MonadState s m) => m ()
hitLeftWall = do
  WallDist _ d1 _ <- checkLeftWallDist
  traceShow ("hitLeftWall", d1) $ pure ()
  if d1 >= 0
  then hitCeiling
  else do
    player . position . _x -= d1
    player . playerVelocity . _x .= 0
    y_vel <- use (player . playerVelocity . _y)
    player . playerInertia .= y_vel

hitCeiling :: (HasLevel g, MonadReader g m, HasPlayer s, MonadState s m) => m ()
hitCeiling = do
  WallDist _ d1 _ <- checkCeiling
  traceShow ("hitCeiling", d1) $ pure ()
  if d1 >= 0
  then hitFloor
  else do
    player . position . _y -= d1
    y_vel <- use (player . playerVelocity . _y)
    when (y_vel < 0) $
      player . playerVelocity . _y .= 0

hitFloor :: (HasLevel g, MonadReader g m, HasPlayer s, MonadState s m) => m ()
hitFloor = do
  y_vel <- use (player . playerVelocity . _y)
  unless (y_vel < 0) $ do
    WallDist _ d1 d3 <- checkFloor
    traceShow ("hitFloor", d1) $ pure ()
    when (d1 < 0) $ do
      player . position . _y += d1
      player . playerAngle .= d3
      resetOnFloor
      player . playerVelocity . _y .= 0
      x_vel <- use (player . playerVelocity . _x)
      player . playerInertia .= x_vel

hitCeilingAndWalls :: (HasLevel g, MonadReader g m, HasPlayer s, MonadState s m) => m ()
hitCeilingAndWalls = do
  WallDist _ d1 _ <- checkLeftWallDist
  when (d1 < 0) $ do
    player . position . _x -= d1
    player . playerVelocity . _x .= 0

  WallDist _ d1' _ <- checkRightWallDist
  when (d1' < 0) $ do
    player . position . _x += d1
    player . playerVelocity . _x .= 0

  WallDist _ d1'' d3 <- checkCeiling
  when (d1'' < 0) $ do
    player . position . _y -= d1''
    let d0 = (d3 + 0x20) .&. 0x40
    if (d0 /= 0)
    then do
      player . playerAngle .= d3
      resetOnFloor
      y_vel <- use (player . playerVelocity . _y)
      player . playerInertia .= y_vel
      inertia <- use (player . playerInertia)
      unless (d3 < 0) $
        player . playerInertia .= (-inertia)
    else player . playerVelocity . _y .= 0;

hitRightWall :: (HasLevel g, MonadReader g m, HasPlayer s, MonadState s m) => m ()
hitRightWall = do
  WallDist _ d1 _ <- checkRightWallDist
  traceShow ("hitRightWall", d1) $ pure ()
  if d1 >= 0
  then hitCeiling
  else do
    player . position . _x += d1
    player . playerVelocity . _x .= 0
    y_vel <- use (player . playerVelocity . _y)
    player . playerInertia .= y_vel

doLevelCollision :: (HasAngleData g, HasLevel g, MonadReader g m, HasPlayer s, MonadState s m) => m ()
doLevelCollision = do
  -- TODO: Check left/right/bottom solid bit
  v <- use (player . playerVelocity)
  a <- calcAngle v
  traceShow ("doLevelCollision", (a - 0x20) .&. 0xC0) $ pure ()
  case (a - 0x20) .&. 0xC0 of
    0x40 -> hitLeftWall
    0x80 -> hitCeilingAndWalls
    0xC0 -> hitRightWall
    _    -> do
      WallDist _ d1 _ <- checkLeftWallDist
      when (d1 < 0) $ do
        -- p->x_pos -= d1;
        -- p->x_vel = 0;
        traceShow "TODO" $ pure ()

      WallDist _ d1' _ <- checkLeftWallDist
      when (d1' < 0) $ do
        -- p->x_pos += d1;
        -- p->x_vel = 0;
        traceShow "TODO" $ pure ()

      WallDist _ d1'' d3 <- checkFloor
      unless (d1'' < 0) $ do
        v <- use (player . playerVelocity)
        -- let d2 = negate ((v ^. _y `shiftR` 8) + 8)
        player . position . _y += d1''
        player . playerAngle .= d3
        resetOnFloor
        -- d0 = (d3 + 0x10) & 0x20;
        -- if((char)d0 == 0)
        -- 	goto loc_1AF5A;
        -- if(p->y_vel < 0){	// p->y_vel /= 2; -- DONE THIS WAY FOR ACCURACY
        -- 	p->y_vel >>= 1;
        -- 	p->y_vel |= 0x80000000;
        -- }
        -- else
        -- 	p->y_vel >>= 1;
        -- goto loc_1AF7C;

-- Subroutine to change Sonic's angle as he walks along the floor
sonicAngle :: (Applicative m) => Word8 -> m ()
sonicAngle _ =
  pure ()

anglePos :: (HasLevel g, HasAngleData g, MonadReader g m, HasPlayer s, MonadState s m) => m ()
anglePos = do
  -- unless onobject
  a <- use (player . playerAngle)
  let
    a' =
      if a + 0x20 >= 0
      then (if a < 0 then a + 1 else a) + 0x1F
      else error "angle pos 1"

  case (a' + 0x20) .&. 0xC0 of
    0x40 -> pure ()
    0x80 -> pure ()
    0xC0 -> pure ()
    _    -> do
      p <- use (player . position)
      r <- use (player . playerRadius)
      WallDist _ d1 a4 <- findFloor (p + r) 0x10
      sonicAngle a4
      unless (d1 == 0) $ do
        if d1 >= 0
        then do
          v <- use (player . playerVelocity)
          let d0 = min 0xE (abs (v ^. _x `shiftR` 8) + 4)
          if d1 > fromIntegral d0
          then player . statuses . mdAir .= MdAirOn
            -- player . status &= 0xDF
            -- pure ()
          else player . position . _y += d1
        else
          unless (d1 < (-0xE)) $
            player . position . _y += d1

x :: (HasLevel g, MonadReader g m) => V2 CInt -> m WallDist
x p = do
  l <- asks layout
  c <- asks chunkBlocks
  let
    reindexedCollisionBlocks =
      undefined
    reindexedCurves =
      undefined

    V2 layoutX layoutY =
      (`div` 0x80) <$> p
    chunkIndex =
      l !! fromIntegral layoutY !! fromIntegral layoutX
    V2 blockX blockY =
      ((`div` 0x10) . (`rem` 0x80)) <$> p
    ChunkBlock blockIndex flipX flipY =
      (c ! chunkIndex) ! fromIntegral ((blockY * 8) + blockX)
    V2 pixelX pixelY =
      (`rem` 0x10) <$> p
    CollisionBlock heights =
      reindexedCollisionBlocks ! blockIndex
    angle' =
      (if flipX then negate else id) $ reindexedCurves ! blockIndex
    flip' flag n =
      if flag then 0xF - n else n
    height =
      fromMaybe 0 (heights ! fromIntegral (flip' flipX pixelX))
    heightDifference =
      (0x10 - flip' flipY pixelY) - (fromIntegral height + 2)
  pure $ WallDist blockIndex heightDifference angle'

loadAndRun :: (MonadReader Game m, MonadError SonicError m, MonadIO m) => m ()
loadAndRun = do
  sonicMappings <- loadSpriteMappings sonicOffsets
  tailsMappings <- loadSpriteMappings tailsOffsets

  curves <- listArrayFill 0 . BS.unpack <$> sliceRom curveAndResistanceMapping

  sonicAnimationScript <- loadAnimation . BS.unpack <$> sliceRom animationSonicWait
  tailsAnimationScript <- loadAnimation . BS.unpack <$> sliceRom animationTailsWait

  let offsets = ehz1
  maybeSonicPalette <- readPalette <$> sliceRom paletteSonic
  maybePalette <- readPalette <$> sliceRom (levelPaletteOffset offsets)
  palette <- maybe (throwError . SonicPaletteError $ levelPaletteOffset offsets) (pure . loadPalette) (maybeSonicPalette <> maybePalette)
  tileContent <- decompressFile $ levelArtOffset offsets
  tileSurfaces <- loadTiles tileContent
  blockContent <- decompressFile $ levelBlocksOffset offsets
  blockTextures <- loadBlocks palette tileSurfaces blockContent
  chunkContent <- decompressFile $ levelChunksOffset offsets
  let chunkBlocks = loadChunks chunkContent
  chunkTextures <- traverse (loadChunkTexture blockTextures) chunkBlocks
  layoutContent <- decompressFile $ levelLayoutOffset offsets
  let
    layout =
      loadLayout layoutContent
    layoutChunkTextures =
      mapChunkTextures chunkTextures layout

  collisionIndexContent <- decompressFile $ levelCollisionOffset offsets
  collisionIndex <- loadCollisionIndex collisionIndexContent

  collisionContent <- sliceRom collisionArray1
  let collisionBlocks = loadCollisionBlocks collisionContent
  collisionBlockTextures <- traverse loadCollisionTexture collisionBlocks

  let reindexedCollisionTextures = (collisionBlockTextures !) <$> collisionIndex
      reindexedCollisionBlocks = (collisionBlocks !) <$> collisionIndex
      reindexedCurves = (curves !) <$> collisionIndex

  now <- liftIO getCurrentTime
  chunksContent <- decompressFile $ levelChunksOffset offsets
  liftIO $ putStrLn "Loading chunks..."
  let chunksBlocks = loadChunks chunksContent
  chunksTextures <- traverse (loadChunkTexture reindexedCollisionTextures) chunksBlocks
  now' <- liftIO getCurrentTime
  liftIO . putStrLn $ "Chunks loaded in " <> show (diffUTCTime now' now)

  sineData' <- SineData . listArrayFill 0 . fmap fromIntegral . view (unpackedBytes . collectHalves) <$> sliceRom Offsets.sineData
  angleData' <- AngleData . listArrayFill 0 . fmap fromIntegral . view (unpackedBytes . collectHalves) <$> sliceRom Offsets.angleData

  let
    collisionTextures = mapChunkTextures chunksTextures layout
    levelData = LevelData angleData' layout chunkBlocks

  startPos <- sliceRom $ levelStartPos ehz1
  let
    playerStart =
      case (startPos ^. unpackedBytes . collectHalves) of
        [x, y] ->
          V2 (fromIntegral x) (fromIntegral y)
        _ ->
          V2 0 0

  r <- view renderer
  rendererRenderTarget r $= Nothing

  let
    playerSprite =
      Sprite sonicMappings (V2 0 0) sonicAnimationScript emptyAnimationState
    render textures (V2 o p) =
      ifor_ textures $ \y row ->
        ifor_ row $ \x texture ->
          let
            rectangle =
              Rectangle (P (V2 ((fromIntegral x * 0x80) - o) ((fromIntegral y * 0x80) - p))) 0x80
          in copy r texture Nothing (Just rectangle)
    appLoop playerSprite' game = do
      -- startTicks <- ticks
      events <- pollEvents
      let
        eventIsPress keycode event =
          case eventPayload event of
            KeyboardEvent keyboardEvent ->
              keyboardEventKeyMotion keyboardEvent == Pressed &&
              keysymKeycode (keyboardEventKeysym keyboardEvent) == keycode
            _ ->
              False
        isPressed keycode =
          any (eventIsPress keycode) events
        qPressed =
          isPressed KeycodeQ
        jumpPressed =
          isPressed KeycodeA || isPressed KeycodeS || isPressed KeycodeD
        leftPressed =
          isPressed KeycodeLeft
        rightPressed =
          isPressed KeycodeRight
        -- downPressed =
        --   isPressed KeycodeDown
        -- upPressed =
        --   isPressed KeycodeUp
        playerSprite'' =
          playerSprite' & position .~ (fromIntegral <$> (game ^. player . position . pixels))
        updateGame = do
          zoom player $ do
            s <- use statuses
            traceShow (playerRoutine s) $ pure ()
            case playerRoutine s of
              MdNormal -> do
                if jumpPressed
                then runReaderT jump sineData'
                else do
                  if rightPressed
                  then moveRight
                  else when leftPressed moveLeft
                  when (not rightPressed && not leftPressed) settle
                  objectMove
                  traction
                  runReaderT anglePos levelData
              MdAir -> do
                objectMoveAndFall
                runReaderT doLevelCollision levelData
              MdRoll ->
                pure ()
              MdJump -> do
                objectMoveAndFall
                runReaderT doLevelCollision levelData
          p' <- use (player . position . pixels)
          camera .= (fromIntegral <$> p') - V2 160 128 -- V2 o' p'
        game' =
          execState updateGame game

      rendererDrawColor r $= V4 0 0 0 0xFF
      clear r
      render layoutChunkTextures (game' ^. camera)
      runReaderT (renderSprite playerSprite'') game'
      present r
      delay 16
      unless qPressed (appLoop (stepSprite playerSprite'') game')
  game <- ask
  appLoop playerSprite (game & player . position . pixels .~ playerStart)

main :: IO ()
main = do
  rom' <- BS.readFile "sonic2.md"

  window <- createWindow "Sonic 2" defaultWindow { windowInitialSize = V2 320 224 }
  renderer' <- createRenderer window (-1) defaultRenderer
  rendererLogicalSize renderer' $= Just (V2 320 224)

  e <- runReaderT (runExceptT loadAndRun) (Game renderer' 0 rom' $ Player (V2 0 0) (V2 0 0) (V2 0 0x13) normalTopSpeed normalAcceleration normalDeceleration 0 0 initialStatuses)
  either print pure e