├── Setup.hs ├── musashi ├── Setup.hs ├── default.nix ├── musashi.cabal ├── Main.hs ├── LICENSE ├── libmusashi.nix └── Musashi.hs ├── src └── Game │ └── Sega │ └── Sonic │ ├── Types.hs │ ├── Error.hs │ ├── Layout.hs │ ├── Musashi.hs │ ├── Palette.hs │ ├── Animation.hs │ ├── Sine.hs │ ├── Blocks.hs │ ├── Tiles.hs │ ├── Chunks.hs │ ├── SpriteMappings.hs │ ├── Game.hs │ ├── Collision.hs │ ├── Offsets.hs │ ├── Sprites.hs │ └── Player.hs ├── .gitignore ├── halves.nix ├── bounded-array.nix ├── megadrive-palette.nix ├── default.nix ├── kosinski.nix ├── test └── Main.hs ├── LICENSE ├── sonic2.cabal └── Main.hs /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /musashi/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /src/Game/Sega/Sonic/Types.hs: -------------------------------------------------------------------------------- 1 | module Game.Sega.Sonic.Types ( 2 | HasPosition(..) 3 | ) where 4 | 5 | import Control.Lens (Lens') 6 | import Foreign.C.Types (CInt) 7 | import SDL (V2) 8 | 9 | class HasPosition a where 10 | position :: Lens' a (V2 CInt) 11 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | cabal.project.local~ 21 | .HTF/ 22 | .ghc.environment.* 23 | /sonic2.md 24 | -------------------------------------------------------------------------------- /musashi/default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, bytestring, musashi, stdenv }: 2 | mkDerivation { 3 | pname = "musashi"; 4 | version = "0.1.0.0"; 5 | src = ./.; 6 | libraryHaskellDepends = [ base bytestring ]; 7 | libraryPkgconfigDepends = [ musashi ]; 8 | description = "Musashi m68k emulator bindings"; 9 | license = stdenv.lib.licenses.mit; 10 | } 11 | -------------------------------------------------------------------------------- /src/Game/Sega/Sonic/Error.hs: -------------------------------------------------------------------------------- 1 | module Game.Sega.Sonic.Error ( 2 | SonicError(..) 3 | ) where 4 | 5 | import Game.Sega.Sonic.Offsets (Offset) 6 | 7 | data SonicError 8 | = SonicLoadError Offset 9 | | SonicDecompressionError Offset 10 | | SonicPaletteError Offset 11 | | SonicEmptyChunksError 12 | | SonicEmptyCollisionIndexError 13 | deriving (Eq, Ord, Show) 14 | -------------------------------------------------------------------------------- /halves.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, hedgehog, lens, stdenv }: 2 | mkDerivation { 3 | pname = "halves"; 4 | version = "0.1.0.1"; 5 | sha256 = "aaf29ccf077afd3dff7ad68acb4bae002e358db9306aaa9b5765a282d5895d56"; 6 | libraryHaskellDepends = [ base lens ]; 7 | testHaskellDepends = [ base hedgehog lens ]; 8 | description = "Split or combine data structures to and from halves, quarters, eighths"; 9 | license = stdenv.lib.licenses.bsd3; 10 | } 11 | -------------------------------------------------------------------------------- /bounded-array.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, array, base, fetchgit, stdenv }: 2 | mkDerivation { 3 | pname = "bounded-array"; 4 | version = "0.1.0.0"; 5 | src = fetchgit { 6 | url = "https://github.com/puffnfresh/bounded-array.git"; 7 | sha256 = "09v47c3v5ncvln2asq8ijlrb4f4agh0ibdaypmls8pnwhmh32p6g"; 8 | rev = "58990b068e8146ce29e177db0cd2cde85a0c125a"; 9 | }; 10 | libraryHaskellDepends = [ array base ]; 11 | description = "Arrays with a value for every index"; 12 | license = stdenv.lib.licenses.bsd3; 13 | } 14 | -------------------------------------------------------------------------------- /megadrive-palette.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, bytestring, fetchgit, stdenv }: 2 | mkDerivation { 3 | pname = "megadrive-palette"; 4 | version = "0.1.0.0"; 5 | src = fetchgit { 6 | url = "https://github.com/puffnfresh/megadrive-palette.git"; 7 | sha256 = "0fca8rra4ybksz3gfrlx2aiw1cfnppiccbzdfb3j2ma5gl1z5zxa"; 8 | rev = "add1de034ba466c6976241c0af8588735c206635"; 9 | }; 10 | libraryHaskellDepends = [ base bytestring ]; 11 | description = "Palettes for Sega Mega Drive (and Genesis)"; 12 | license = stdenv.lib.licenses.bsd3; 13 | } 14 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | with import { }; 2 | 3 | haskellPackages.developPackage { 4 | root = ./.; 5 | overrides = self: super: { 6 | bounded-array = self.callPackage ./bounded-array.nix { }; 7 | halves = self.callPackage ./halves.nix { }; 8 | kosinski = self.callPackage ./kosinski.nix { }; 9 | megadrive-palette = self.callPackage ./megadrive-palette.nix { }; 10 | sdl2 = haskell.lib.dontCheck super.sdl2; 11 | musashi = haskell.lib.appendConfigureFlag (self.callPackage ./musashi { 12 | musashi = callPackage ./musashi/libmusashi.nix { }; 13 | }) "--gcc-option=-shared"; 14 | }; 15 | } 16 | -------------------------------------------------------------------------------- /musashi/musashi.cabal: -------------------------------------------------------------------------------- 1 | name: musashi 2 | version: 0.1.0.0 3 | synopsis: Musashi m68k emulator bindings 4 | -- description: 5 | license: MIT 6 | license-file: LICENSE 7 | author: Brian McKenna 8 | maintainer: brian@brianmckenna.org 9 | -- copyright: 10 | category: Game 11 | build-type: Simple 12 | cabal-version: >=1.10 13 | 14 | library 15 | exposed-modules: Musashi 16 | build-depends: base >=4.10 && <4.12 17 | , bytestring >=0.10 && <0.11 18 | pkgconfig-depends: musashi 19 | default-language: Haskell2010 20 | -------------------------------------------------------------------------------- /kosinski.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, bytestring, deepseq, fetchgit, filepath, lens 2 | , mtl, stdenv, tasty, tasty-hunit, time 3 | }: 4 | mkDerivation { 5 | pname = "kosinski"; 6 | version = "0.1.0.0"; 7 | src = fetchgit { 8 | url = "https://github.com/puffnfresh/kosinski.git"; 9 | sha256 = "1xfz4jh90kn6mzi1y6qvm7d7s1prhb8fis8m3b7xv1bzqpczlzml"; 10 | rev = "96e63c1f5fc2fd4f0fc780336c8a200bd06bf069"; 11 | }; 12 | libraryHaskellDepends = [ base bytestring lens mtl ]; 13 | testHaskellDepends = [ base bytestring tasty tasty-hunit ]; 14 | benchmarkHaskellDepends = [ 15 | base bytestring deepseq filepath time 16 | ]; 17 | description = "Compression used in Sonic the Hedgehog"; 18 | license = stdenv.lib.licenses.bsd3; 19 | } 20 | -------------------------------------------------------------------------------- /src/Game/Sega/Sonic/Layout.hs: -------------------------------------------------------------------------------- 1 | module Game.Sega.Sonic.Layout ( 2 | loadLayout 3 | , mapChunkTextures 4 | ) where 5 | 6 | import Control.Lens (folded, ifiltered, toListOf) 7 | import Data.Array.Bounded (BoundedArray, (!)) 8 | import qualified Data.ByteString as BS 9 | import Data.List.Split (chunksOf) 10 | import Data.Word (Word8) 11 | import SDL (Texture) 12 | 13 | ifilter :: Foldable f => (Int -> a -> Bool) -> f a -> [a] 14 | ifilter f = 15 | toListOf (folded . ifiltered f) 16 | 17 | type ChunkIndex 18 | = Word8 19 | 20 | loadLayout :: BS.ByteString -> [[ChunkIndex]] 21 | loadLayout = 22 | ifilter (const . even) . chunksOf 0x80 . BS.unpack 23 | 24 | mapChunkTextures :: BoundedArray Word8 Texture -> [[ChunkIndex]] -> [[Texture]] 25 | mapChunkTextures chunkTextures = 26 | (fmap . fmap) ((chunkTextures !) . fromIntegral) 27 | -------------------------------------------------------------------------------- /src/Game/Sega/Sonic/Musashi.hs: -------------------------------------------------------------------------------- 1 | module Game.Sega.Sonic.Musashi where 2 | 3 | import Control.Monad ((>=>)) 4 | import qualified Data.ByteString as BS 5 | import Data.Foldable (traverse_) 6 | import Data.Int (Int16) 7 | import Data.IORef (writeIORef) 8 | import Data.Word (Word32, Word8) 9 | import Foreign.C.Types (CUInt) 10 | import Foreign.Marshal.Alloc (allocaBytes) 11 | import Foreign.Marshal.Array (copyArray) 12 | import Foreign.Ptr (nullPtr) 13 | import Musashi 14 | 15 | calcSineOffset :: Word32 16 | calcSineOffset = 17 | 0x33B6 18 | 19 | calcSine :: Word8 -> IO (Int16, Int16) 20 | calcSine n = do 21 | musashiSetSubroutine calcSineOffset 22 | m68k_set_reg m68k_REG_D0 (fromIntegral n) 23 | musashiRun 24 | d0 <- m68k_get_reg nullPtr m68k_REG_D0 25 | d1 <- m68k_get_reg nullPtr m68k_REG_D1 26 | pure (fromIntegral d0, fromIntegral d1) 27 | -------------------------------------------------------------------------------- /src/Game/Sega/Sonic/Palette.hs: -------------------------------------------------------------------------------- 1 | module Game.Sega.Sonic.Palette ( 2 | loadPalette 3 | ) where 4 | 5 | import Control.Lens (over, _head) 6 | import Data.Array.Bounded (BoundedArray, accumArrayBounded) 7 | import Data.List.Split (chunksOf) 8 | import Data.Vector.Storable (Vector, fromList) 9 | import Data.Word (Word8) 10 | import SDL (V4 (..)) 11 | import Sega.MegaDrive.Palette (BGR (..), ColorNibble (..), 12 | nibbleToByte) 13 | 14 | fromBGR :: BGR ColorNibble -> V4 Word8 15 | fromBGR (BGR b g r) = 16 | V4 (nibbleToByte r) (nibbleToByte g) (nibbleToByte b) 0xFF 17 | 18 | makeTransparent :: V4 Word8 -> V4 Word8 19 | makeTransparent (V4 b g r _) = 20 | V4 b g r 0 21 | 22 | loadPalette :: [BGR ColorNibble] -> BoundedArray Word8 (Vector (V4 Word8)) 23 | loadPalette = 24 | accumArrayBounded (flip const) mempty . zip [0..3] . fmap (fromList . over _head makeTransparent) . chunksOf 0x10 . fmap fromBGR 25 | -------------------------------------------------------------------------------- /musashi/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad ((>=>)) 4 | import qualified Data.ByteString as BS 5 | import Data.Foldable (traverse_) 6 | import Data.IORef (writeIORef) 7 | import Data.Word (Word32, Word8) 8 | import Foreign.C.Types (CUInt) 9 | import Foreign.Marshal.Alloc (allocaBytes) 10 | import Foreign.Marshal.Array (copyArray) 11 | import Foreign.Ptr (nullPtr) 12 | import Musashi 13 | 14 | calcSineOffset :: Word32 15 | calcSineOffset = 16 | 0x33B6 17 | 18 | calcSine :: CUInt -> IO CUInt 19 | calcSine n = do 20 | musashiSetSubroutine calcSineOffset 21 | m68k_set_reg m68k_REG_D0 n 22 | musashiRun 23 | m68k_get_reg nullPtr m68k_REG_D0 24 | 25 | main :: IO () 26 | main = do 27 | bs <- BS.readFile "../sonic2.md" 28 | allocaBytes 0xffffff $ \p -> do 29 | musashiSetRom p 30 | BS.useAsCStringLen bs (uncurry (copyArray p)) 31 | musashiInit 32 | traverse_ (calcSine >=> print) [0..128] 33 | -------------------------------------------------------------------------------- /musashi/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018 Brian McKenna 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /musashi/libmusashi.nix: -------------------------------------------------------------------------------- 1 | { stdenv, fetchFromGitHub }: 2 | 3 | let 4 | rev = "fe93f3a823604534cf6583dfc5d57557036af5bc"; 5 | in 6 | stdenv.mkDerivation rec { 7 | name = "musashi-${version}"; 8 | version = stdenv.lib.strings.substring 0 7 rev; 9 | src = fetchFromGitHub { 10 | owner = "kstenerud"; 11 | repo = "Musashi"; 12 | inherit rev; 13 | sha256 = "192mkxplxa67h2xiid137xmf15wg083zz8kn9j7bl8dcr921dqmr"; 14 | }; 15 | patchPhase = '' 16 | # The MAME headers are not packaged, so exclude by default 17 | sed -i 's/M68K_COMPILE_FOR_MAME OPT_ON/M68K_COMPILE_FOR_MAME OPT_OFF/' m68kconf.h 18 | ''; 19 | buildPhase = '' 20 | $CC -o m68kmake m68kmake.c 21 | mkdir src 22 | ./m68kmake src 23 | cp {m68k.h,m68kconf.h,m68kcpu.*} src 24 | 25 | $CC -shared -o libmusashi.so src/*.c 26 | ''; 27 | installPhase = '' 28 | mkdir -p $out/lib/pkgconfig 29 | cat < $out/lib/pkgconfig/musashi.pc 30 | Name: musashi 31 | Description: A portable Motorola M680x0 processor emulation engine 32 | Version: 1.0.0-${version} 33 | Libs: -L$out/lib -lmusashi 34 | EOF 35 | mv libmusashi.so $out/lib 36 | mv src $out 37 | ''; 38 | } 39 | -------------------------------------------------------------------------------- /src/Game/Sega/Sonic/Animation.hs: -------------------------------------------------------------------------------- 1 | module Game.Sega.Sonic.Animation ( 2 | AnimationScript(..) 3 | , AnimationStep(..) 4 | , loadAnimation 5 | ) where 6 | 7 | import Data.Array.Bounded 8 | import Data.Word (Word8) 9 | 10 | data AnimationScript 11 | = AnimationScript Word8 (BoundedArray Word8 AnimationStep) 12 | deriving (Eq, Ord, Show) 13 | 14 | data AnimationStep 15 | = AnimationFrame Word8 16 | | AnimationReset 17 | | AnimationJumpBack Word8 18 | | AnimationNext Word8 19 | | AnimationIncrementRoutine 20 | | AnimationResetSubRoutine 21 | | AnimationIncrementSubRoutine 22 | deriving (Eq, Ord, Show) 23 | 24 | loadAnimationSteps :: [Word8] -> [AnimationStep] 25 | loadAnimationSteps (0xFF:bs) = 26 | AnimationReset : loadAnimationSteps bs 27 | loadAnimationSteps (0xFE:b:bs) = 28 | AnimationJumpBack b : loadAnimationSteps bs 29 | loadAnimationSteps (0xFD:b:bs) = 30 | AnimationNext b : loadAnimationSteps bs 31 | loadAnimationSteps (0xFC:bs) = 32 | AnimationIncrementRoutine : loadAnimationSteps bs 33 | loadAnimationSteps (0xFB:bs) = 34 | AnimationResetSubRoutine : loadAnimationSteps bs 35 | loadAnimationSteps (0xFA:bs) = 36 | AnimationIncrementSubRoutine : loadAnimationSteps bs 37 | loadAnimationSteps (b:bs) = 38 | AnimationFrame b : loadAnimationSteps bs 39 | loadAnimationSteps [] = 40 | [] 41 | 42 | loadAnimation :: [Word8] -> AnimationScript 43 | loadAnimation (b:bs) = 44 | AnimationScript b . listArrayFill AnimationReset $ loadAnimationSteps bs 45 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Control.Lens (lens) 6 | import Control.Monad (unless) 7 | import Control.Monad.IO.Class (liftIO) 8 | import Control.Monad.Reader 9 | import qualified Data.ByteString as BS 10 | import Foreign.Marshal.Alloc (allocaBytes) 11 | import Foreign.Marshal.Array (copyArray) 12 | import Game.Sega.Sonic.Game (HasRom (..), loadSineData) 13 | import qualified Game.Sega.Sonic.Musashi as Musashi 14 | import Game.Sega.Sonic.Sine 15 | import Hedgehog 16 | import qualified Hedgehog.Gen as Gen 17 | import qualified Hedgehog.Range as Range 18 | import Musashi 19 | import System.Exit (exitFailure) 20 | 21 | prop_calcSine :: SineData -> Property 22 | prop_calcSine sineData = 23 | property $ do 24 | n <- forAll $ Gen.word8 Range.linearBounded 25 | let a = runReader (calcSine n) sineData 26 | b <- liftIO $ Musashi.calcSine n 27 | a === b 28 | 29 | main :: IO () 30 | main = do 31 | bs <- BS.readFile "sonic2.md" 32 | allocaBytes 0xffffff $ \p -> do 33 | musashiSetRom p 34 | BS.useAsCStringLen bs (uncurry (copyArray p)) 35 | musashiInit 36 | let sineData = runReader loadSineData bs 37 | 38 | result <- checkParallel $ Group "Test.Musashi" [ 39 | ("prop_calcSine", prop_calcSine sineData) 40 | ] 41 | 42 | unless result exitFailure 43 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, Brian McKenna 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Brian McKenna nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /src/Game/Sega/Sonic/Sine.hs: -------------------------------------------------------------------------------- 1 | module Game.Sega.Sonic.Sine ( 2 | SineData(..) 3 | , HasSineData(..) 4 | , calcSine 5 | , AngleData(..) 6 | , HasAngleData(..) 7 | , calcAngle 8 | ) where 9 | 10 | import Control.Monad.Reader (MonadReader, asks) 11 | import Data.Array.Bounded 12 | import Data.Bits (shiftL) 13 | import Data.Int 14 | import Data.Word 15 | import Linear.V2 (V2(..)) 16 | 17 | data SineData 18 | = SineData (BoundedArray Word16 Int16) 19 | deriving (Eq, Ord, Show) 20 | 21 | class HasSineData a where 22 | sineData :: a -> SineData 23 | 24 | instance HasSineData SineData where 25 | sineData = 26 | id 27 | 28 | calcSine :: (HasSineData g, MonadReader g m) => Word8 -> m (Int16, Int16) 29 | calcSine w = 30 | f <$> asks sineData 31 | where 32 | f (SineData a) = 33 | (a ! fromIntegral w, a ! fromIntegral (w + 0x40)) 34 | 35 | data AngleData 36 | = AngleData (BoundedArray Word8 Int8) 37 | deriving (Eq, Ord, Show) 38 | 39 | class HasAngleData a where 40 | angleData :: a -> AngleData 41 | 42 | instance HasAngleData AngleData where 43 | angleData = 44 | id 45 | 46 | -- arctangent of y/x 47 | calcAngle :: (HasAngleData g, MonadReader g m) => V2 Int16 -> m Int16 48 | calcAngle (V2 x y) = 49 | h . g . f <$> asks angleData 50 | where 51 | x' = 52 | abs x 53 | y' = 54 | abs y 55 | f (AngleData angles) = 56 | if x == 0 && y == 0 57 | then 0x40 58 | else 59 | if y' < x' 60 | then fromIntegral (angles ! i (fromIntegral x') y') 61 | else 0x40 - fromIntegral (angles ! i (fromIntegral y') x') 62 | g = 63 | if x < 0 64 | then \r -> -r + 0x80 65 | else id 66 | h = 67 | if y < 0 68 | then \r -> -r + 0x100 69 | else id 70 | i a b = 71 | if a == 0 72 | then 0 73 | else fromIntegral (b `shiftL` 8) `div` a 74 | -------------------------------------------------------------------------------- /src/Game/Sega/Sonic/Blocks.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | 3 | module Game.Sega.Sonic.Blocks ( 4 | loadBlocks 5 | ) where 6 | 7 | import Control.Lens (view) 8 | import Control.Monad.IO.Class (MonadIO (..)) 9 | import Control.Monad.Reader (MonadReader) 10 | import Data.Array.Bounded (BoundedArray, listArrayFill) 11 | import Data.Bits 12 | import qualified Data.ByteString as BS 13 | import Data.List.Split (chunksOf) 14 | import Data.Vector.Storable (Vector) 15 | import Data.Word (Word16, Word8) 16 | import Game.Sega.Sonic.Game (HasRenderer (..)) 17 | import Game.Sega.Sonic.Sprites (copySpriteTile) 18 | import SDL hiding (Vector) 19 | 20 | word16s :: [Word8] -> [Word16] 21 | word16s (a:b:cs) = 22 | (shiftL (fromIntegral a) 8 .|. fromIntegral b) : word16s cs 23 | word16s _ = 24 | [] 25 | 26 | loadBlock :: (HasRenderer g, MonadReader g m, MonadIO m) => BoundedArray Word8 (Vector (V4 Word8)) -> BoundedArray Word16 Surface -> [Word16] -> m Texture 27 | loadBlock palette tiles c = do 28 | r <- view renderer 29 | texture <- createTexture r ABGR8888 TextureAccessTarget $ V2 0x10 0x10 30 | rendererRenderTarget r $= Just texture 31 | copySpriteTile palette tiles (c !! 0) $ V2 0 0 32 | copySpriteTile palette tiles (c !! 1) $ V2 8 0 33 | copySpriteTile palette tiles (c !! 2) $ V2 0 8 34 | copySpriteTile palette tiles (c !! 3) $ V2 8 8 35 | pure texture 36 | 37 | emptyTexture :: (HasRenderer g, MonadReader g m, MonadIO m) => m Texture 38 | emptyTexture = do 39 | surface <- createRGBSurface (V2 0x10 0x10) ABGR8888 40 | surfaceFillRect surface Nothing (V4 0xFF 0xFF 0x00 0xFF) 41 | r <- view renderer 42 | createTextureFromSurface r surface 43 | 44 | loadBlocks :: (HasRenderer g, MonadReader g m, MonadIO m) => BoundedArray Word8 (Vector (V4 Word8)) -> BoundedArray Word16 Surface -> BS.ByteString -> m (BoundedArray Word16 Texture) 45 | loadBlocks palette tiles c = do 46 | e <- emptyTexture 47 | fmap (listArrayFill e) . traverse (loadBlock palette tiles) . chunksOf 4 . word16s $ BS.unpack c 48 | -------------------------------------------------------------------------------- /src/Game/Sega/Sonic/Tiles.hs: -------------------------------------------------------------------------------- 1 | module Game.Sega.Sonic.Tiles ( 2 | loadTiles 3 | , applyDynamicPatternLoadCue 4 | ) where 5 | 6 | import Control.Monad.IO.Class (MonadIO (..)) 7 | import Data.Array.Bounded (BoundedArray, listArrayFill, 8 | (!)) 9 | import Data.Bits (shiftR, (.&.)) 10 | import qualified Data.ByteString as BS 11 | import Data.Foldable (for_) 12 | import Data.List.Split (chunksOf) 13 | import Data.Word (Word16, Word8) 14 | import Foreign.Ptr (Ptr, castPtr) 15 | import Foreign.Storable (pokeElemOff) 16 | import Game.Sega.Sonic.SpriteMappings (DynamicPatternLoadCue (..)) 17 | import SDL hiding (Vector) 18 | 19 | tileSurface :: (MonadIO m) => [[Word8]] -> m Surface 20 | tileSurface c = do 21 | surface <- createRGBSurface (V2 8 8) Index8 22 | lockSurface surface 23 | ptr <- surfacePixels surface 24 | let ptr' = castPtr ptr :: Ptr Word8 25 | for_ [0..7] $ \y -> 26 | for_ [0..7] $ \x -> 27 | liftIO $ pokeElemOff ptr' ((y * 8) + x) $ c !! y !! x 28 | unlockSurface surface 29 | return surface 30 | 31 | emptySurface :: (MonadIO m) => m Surface 32 | emptySurface = do 33 | surface <- createRGBSurface (V2 8 8) ABGR8888 34 | surfaceFillRect surface Nothing (V4 0xFF 0x00 0xFF 0xFF) 35 | pure surface 36 | 37 | splitByte :: Word8 -> [Word8] 38 | splitByte a = 39 | [a `shiftR` 4, a .&. 0xF] 40 | 41 | loadTiles :: (MonadIO m) => BS.ByteString -> m (BoundedArray Word16 Surface) 42 | loadTiles c = do 43 | e <- emptySurface 44 | fmap (listArrayFill e) . traverse (tileSurface . chunksOf 8) . chunksOf 0x40 $ splitByte =<< BS.unpack c 45 | 46 | applyDynamicPatternLoadCue :: (MonadIO m) => BoundedArray Word16 Surface -> [DynamicPatternLoadCue] -> m (BoundedArray Word16 Surface) 47 | applyDynamicPatternLoadCue tiles dplcs = do 48 | e <- emptySurface 49 | pure . listArrayFill e $ dplcs >>= fmap (tiles !) . is 50 | where 51 | is (DynamicPatternLoadCue s i) = 52 | [i..i + fromIntegral s] 53 | -------------------------------------------------------------------------------- /sonic2.cabal: -------------------------------------------------------------------------------- 1 | name: sonic2 2 | version: 0.1.0.0 3 | license: BSD3 4 | license-file: LICENSE 5 | author: Brian McKenna 6 | maintainer: brian@brianmckenna.org 7 | category: Game 8 | build-type: Simple 9 | cabal-version: >=1.10 10 | 11 | library 12 | hs-source-dirs: src 13 | exposed-modules: Game.Sega.Sonic.Animation 14 | , Game.Sega.Sonic.Blocks 15 | , Game.Sega.Sonic.Chunks 16 | , Game.Sega.Sonic.Collision 17 | , Game.Sega.Sonic.Error 18 | , Game.Sega.Sonic.Game 19 | , Game.Sega.Sonic.Layout 20 | , Game.Sega.Sonic.Musashi 21 | , Game.Sega.Sonic.Offsets 22 | , Game.Sega.Sonic.Palette 23 | , Game.Sega.Sonic.Player 24 | , Game.Sega.Sonic.Sine 25 | , Game.Sega.Sonic.SpriteMappings 26 | , Game.Sega.Sonic.Sprites 27 | , Game.Sega.Sonic.Tiles 28 | , Game.Sega.Sonic.Types 29 | build-depends: base 30 | , array 31 | , bytestring 32 | , filepath 33 | , mtl 34 | , time 35 | , vector 36 | , bounded-array 37 | , halves 38 | , kosinski 39 | , lens 40 | , linear 41 | , megadrive-palette 42 | , sdl2 43 | , split 44 | , musashi 45 | default-language: Haskell2010 46 | 47 | executable sonic2 48 | main-is: Main.hs 49 | build-depends: sonic2 50 | default-language: Haskell2010 51 | 52 | test-suite musashi-test 53 | type: exitcode-stdio-1.0 54 | build-depends: base 55 | , bytestring 56 | , musashi 57 | , sonic2 58 | , hedgehog 59 | , lens 60 | , mtl 61 | main-is: test/Main.hs 62 | -------------------------------------------------------------------------------- /src/Game/Sega/Sonic/Chunks.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | 4 | module Game.Sega.Sonic.Chunks ( 5 | loadChunkTexture 6 | , loadChunks 7 | , ChunkBlock(..) 8 | ) where 9 | 10 | import Control.Lens 11 | import Control.Monad.Except (MonadError, throwError) 12 | import Control.Monad.IO.Class (MonadIO (..)) 13 | import Control.Monad.Reader (MonadReader) 14 | import Data.Array.Bounded 15 | import Data.Bits 16 | import qualified Data.ByteString as BS 17 | import Data.Halves (collectHalves) 18 | import Data.List.NonEmpty (nonEmpty) 19 | import Data.List.Split (chunksOf) 20 | import Data.Word (Word16, Word8) 21 | import Game.Sega.Sonic.Error 22 | import Game.Sega.Sonic.Game (HasRenderer (..)) 23 | import SDL 24 | 25 | loadChunkTexture :: (HasRenderer g, MonadReader g m, MonadIO m) => BoundedArray Word16 Texture -> Chunk -> m Texture 26 | loadChunkTexture blocks chunkBlocks = do 27 | r <- view renderer 28 | texture <- createTexture r ABGR8888 TextureAccessTarget 0x80 29 | rendererRenderTarget r $= Just texture 30 | ifor_ (unboundedArray chunkBlocks) $ \i (ChunkBlock blockIndex flipX flipY) -> 31 | let 32 | (y, x) = 33 | i `divMod` 8 34 | rectangle = 35 | Rectangle (P (V2 (fromIntegral x * 0x10) (fromIntegral y * 0x10))) 0x10 36 | in copyEx r (blocks ! blockIndex) Nothing (Just rectangle) 0 Nothing (V2 flipX flipY) 37 | pure texture 38 | 39 | data ChunkBlock 40 | = ChunkBlock Word16 Bool Bool 41 | deriving (Show, Eq, Ord) 42 | 43 | emptyChunkBlock :: ChunkBlock 44 | emptyChunkBlock = 45 | ChunkBlock 0 False False 46 | 47 | type Chunk 48 | = BoundedArray Word8 ChunkBlock 49 | 50 | loadChunkBlock :: Word16 -> ChunkBlock 51 | loadChunkBlock i = 52 | ChunkBlock (i .&. 0x3FF) (testBit i 0xA) (testBit i 0xB) 53 | 54 | loadChunk :: [Word16] -> Chunk 55 | loadChunk ws = 56 | listArrayFill emptyChunkBlock $ loadChunkBlock <$> ws 57 | 58 | emptyChunk :: Chunk 59 | emptyChunk = 60 | listArrayFill emptyChunkBlock [] 61 | 62 | loadChunks :: BS.ByteString -> BoundedArray Word8 Chunk 63 | loadChunks = do 64 | listArrayFill emptyChunk . fmap loadChunk . chunksOf 0x40 . view collectHalves . BS.unpack 65 | -------------------------------------------------------------------------------- /src/Game/Sega/Sonic/SpriteMappings.hs: -------------------------------------------------------------------------------- 1 | module Game.Sega.Sonic.SpriteMappings ( 2 | PatternIndex(..) 3 | , SpriteFrame(..) 4 | , SpriteMapping(..) 5 | , DynamicPatternLoadCueFrame(..) 6 | , DynamicPatternLoadCue(..) 7 | , loadMappings 8 | , loadDynamicPatternLoadCues 9 | ) where 10 | 11 | import Control.Lens 12 | import Data.Bits (shiftR, (.&.)) 13 | import qualified Data.ByteString as BS 14 | import Data.ByteString.Lens (unpackedBytes) 15 | import Data.Halves (collectHalves) 16 | import Data.Int (Int16, Int8) 17 | import Data.List.Split (chunksOf) 18 | import Data.Word (Word16, Word8) 19 | 20 | newtype PatternIndex 21 | = PatternIndex Word16 22 | deriving (Eq, Ord, Show) 23 | 24 | data SpriteFrame 25 | = SpriteFrame [SpriteMapping PatternIndex] 26 | deriving (Eq, Ord, Show) 27 | 28 | data SpriteMapping a 29 | = SpriteMapping Int16 Int8 Word8 Word8 a 30 | deriving (Eq, Ord, Show) 31 | 32 | data DynamicPatternLoadCueFrame 33 | = DynamicPatternLoadCueFrame [DynamicPatternLoadCue] 34 | deriving (Eq, Ord, Show) 35 | 36 | data DynamicPatternLoadCue 37 | = DynamicPatternLoadCue Word8 Word16 38 | deriving (Eq, Ord, Show) 39 | 40 | loadMapping :: [Word16] -> SpriteMapping PatternIndex 41 | loadMapping (s:c:_:l:[]) = 42 | let 43 | t = 44 | fromIntegral $ s `shiftR` 8 45 | w = 46 | fromIntegral $ (s .&. 0xC) `shiftR` 2 47 | h = 48 | fromIntegral $ s .&. 0x3 49 | in SpriteMapping (fromIntegral l) t w h $ PatternIndex c 50 | loadMapping _ = 51 | SpriteMapping 0 0 0 0 $ PatternIndex 0 52 | 53 | countedWords :: (Int -> Int) -> [Word16] -> [[Word16]] 54 | countedWords f (x:xs) = 55 | let (a, b) = splitAt (f $ fromIntegral x) xs 56 | in a : countedWords f b 57 | countedWords _ [] = 58 | [] 59 | 60 | ignoreOffsets :: BS.ByteString -> [Word16] 61 | ignoreOffsets = 62 | dropWhile (/= 0) . view (unpackedBytes . collectHalves) 63 | 64 | loadMappings :: BS.ByteString -> [SpriteFrame] 65 | loadMappings = 66 | fmap (SpriteFrame . fmap loadMapping . chunksOf 4) . countedWords (* 4) . ignoreOffsets 67 | 68 | loadDynamicPatternLoadCue :: Word16 -> DynamicPatternLoadCue 69 | loadDynamicPatternLoadCue w = 70 | let 71 | count = 72 | fromIntegral (w `shiftR` 12) 73 | offset = 74 | w .&. 0xFFF 75 | in DynamicPatternLoadCue count offset 76 | 77 | loadDynamicPatternLoadCues :: BS.ByteString -> [DynamicPatternLoadCueFrame] 78 | loadDynamicPatternLoadCues = 79 | fmap (DynamicPatternLoadCueFrame . fmap loadDynamicPatternLoadCue) . countedWords id . ignoreOffsets 80 | -------------------------------------------------------------------------------- /src/Game/Sega/Sonic/Game.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | 3 | module Game.Sega.Sonic.Game ( 4 | Game(..) 5 | , HasRenderer(..) 6 | , HasCamera(..) 7 | , HasRom(..) 8 | , HasPlayer(..) 9 | , sliceRom 10 | , cameraX 11 | , cameraY 12 | , loadSineData 13 | ) where 14 | 15 | import Control.Lens 16 | import Control.Monad.Reader 17 | import Data.Array.Bounded (listArrayFill) 18 | import qualified Data.ByteString as BS 19 | import Data.ByteString.Lens (unpackedBytes) 20 | import Data.Halves (collectHalves) 21 | import Foreign.C.Types 22 | import Game.Sega.Sonic.Offsets as Offsets 23 | import Game.Sega.Sonic.Player 24 | import Game.Sega.Sonic.Sine (SineData (..)) 25 | import SDL 26 | 27 | data Game 28 | = Game Renderer (V2 CInt) BS.ByteString Player 29 | 30 | class HasRenderer a where 31 | renderer :: Lens' a Renderer 32 | 33 | instance HasRenderer Game where 34 | renderer = 35 | lens f g 36 | where 37 | f (Game a _ _ _) = 38 | a 39 | g (Game _ b c d) a = 40 | Game a b c d 41 | 42 | class HasCamera a where 43 | camera :: Lens' a (V2 CInt) 44 | 45 | instance HasCamera Game where 46 | camera = 47 | lens f g 48 | where 49 | f (Game _ a _ _) = 50 | a 51 | g (Game a _ c d) b = 52 | Game a b c d 53 | 54 | class HasRom a where 55 | rom :: Lens' a BS.ByteString 56 | 57 | instance HasRom BS.ByteString where 58 | rom = 59 | id 60 | 61 | instance HasRom Game where 62 | rom = 63 | lens f g 64 | where 65 | f (Game _ _ a _) = 66 | a 67 | g (Game a b _ d) c = 68 | Game a b c d 69 | 70 | instance HasPlayer Game where 71 | player = 72 | lens f g 73 | where 74 | f (Game _ _ _ a) = 75 | a 76 | g (Game a b c _) d = 77 | Game a b c d 78 | 79 | sliceRom :: (HasRom g, MonadReader g m) => Offset -> m BS.ByteString 80 | sliceRom offset = 81 | sliceOffset offset <$> view rom 82 | 83 | cameraX :: Lens' (V2 a) a 84 | cameraX = 85 | lens f g 86 | where 87 | f (V2 a _) = 88 | a 89 | g (V2 _ b) a = 90 | V2 a b 91 | 92 | cameraY :: Lens' (V2 a) a 93 | cameraY = 94 | lens f g 95 | where 96 | f (V2 _ a) = 97 | a 98 | g (V2 a _) b = 99 | V2 a b 100 | 101 | loadSineData :: (MonadReader g f, HasRom g) => f SineData 102 | loadSineData = 103 | SineData . listArrayFill 0 . fmap fromIntegral . view (unpackedBytes . collectHalves) <$> sliceRom Offsets.sineData 104 | -------------------------------------------------------------------------------- /src/Game/Sega/Sonic/Collision.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | 4 | module Game.Sega.Sonic.Collision ( 5 | CollisionBlock(..) 6 | , collisionHeight 7 | , collisionBitmap 8 | , loadCollisionTexture 9 | , loadCollisionBlocks 10 | , loadCollisionIndex 11 | ) where 12 | 13 | import Control.Applicative (liftA2) 14 | import Control.Lens (ix, view, (^?)) 15 | import Control.Monad.Except (MonadError, throwError) 16 | import Control.Monad.IO.Class (MonadIO) 17 | import Control.Monad.Reader (MonadReader) 18 | import Data.Array.Bounded 19 | import Data.Bits ((.&.)) 20 | 21 | import qualified Data.ByteString as BS 22 | import Data.ByteString.Builder (toLazyByteString, word32LE) 23 | import qualified Data.ByteString.Lazy as BSL 24 | import Data.List.NonEmpty (NonEmpty (..), nonEmpty) 25 | import Data.List.Split (chunksOf) 26 | import Data.Maybe (fromMaybe) 27 | import Data.Word (Word16, Word32, Word8) 28 | import Game.Sega.Sonic.Error (SonicError (..)) 29 | import Game.Sega.Sonic.Game (HasRenderer (..)) 30 | import SDL 31 | 32 | data CollisionBlock 33 | = CollisionBlock (BoundedArray Word8 (Maybe Word8)) 34 | deriving (Show, Eq, Ord) 35 | 36 | collisionHeight :: Word8 -> Maybe Word8 37 | collisionHeight n = 38 | let h = 0x1F .&. n 39 | in if h > 0 then Just (h - 1) else Nothing 40 | 41 | collisionBitmap :: CollisionBlock -> BoundedArray Word8 Bool 42 | collisionBitmap (CollisionBlock heights) = 43 | let 44 | testPixel h y = 45 | maybe False (>= fromIntegral (0xF - y)) h 46 | pixel y x = 47 | testPixel (heights ! x) y 48 | content = 49 | liftA2 pixel [0..0xF :: Word8] [0..0xF :: Word8] 50 | in listArrayFill False content 51 | 52 | -- | 53 | loadCollisionTexture :: (HasRenderer g, MonadReader g m, MonadIO m) => CollisionBlock -> m Texture 54 | loadCollisionTexture s = do 55 | r <- view renderer 56 | texture <- createTexture r ABGR8888 TextureAccessStatic 0x10 57 | let 58 | collisionPixel p = 59 | word32LE $ if p then 0xFFFFFFFF else 0xFF000000 :: Word32 60 | content = 61 | foldMap collisionPixel $ collisionBitmap s 62 | updateTexture texture Nothing (BSL.toStrict $ toLazyByteString content) (4 * 0x10) 63 | 64 | loadCollisionBlock :: [Word8] -> CollisionBlock 65 | loadCollisionBlock s = 66 | let 67 | height x = 68 | s ^? ix x >>= collisionHeight 69 | heights = 70 | listArrayCycle $ height <$> (0 :| [1..]) 71 | in CollisionBlock heights 72 | 73 | loadCollisionBlocks :: BS.ByteString -> BoundedArray Word8 CollisionBlock 74 | loadCollisionBlocks = 75 | fmap loadCollisionBlock . listArrayFill [] . chunksOf 0x10 . BS.unpack 76 | 77 | loadCollisionIndex :: (MonadError SonicError m) => BS.ByteString -> m (BoundedArray Word16 Word8) 78 | loadCollisionIndex c = do 79 | xs <- maybe (throwError SonicEmptyCollisionIndexError) pure . nonEmpty $ BS.unpack c 80 | pure $ listArrayCycle xs 81 | -------------------------------------------------------------------------------- /musashi/Musashi.hs: -------------------------------------------------------------------------------- 1 | module Musashi where 2 | 3 | import Control.Monad (when) 4 | import Data.Bits (rotate, shift, shiftR, (.&.), (.|.)) 5 | import Data.IORef (IORef, newIORef, readIORef, writeIORef) 6 | import Data.Word (Word16, Word32, Word8) 7 | import Foreign.C.Types (CInt (..), CUInt (..)) 8 | import Foreign.Ptr (Ptr, nullPtr) 9 | import Foreign.Storable (Storable, peekByteOff, pokeByteOff) 10 | import System.IO.Unsafe (unsafePerformIO) 11 | 12 | -- Global state, could be done via C instead 13 | musashiRom :: IORef (Ptr a) 14 | {-# NOINLINE musashiRom #-} 15 | musashiRom = 16 | unsafePerformIO (newIORef nullPtr) 17 | 18 | musashiPeekRom :: Storable a => Int -> IO a 19 | musashiPeekRom n = do 20 | r <- readIORef musashiRom 21 | peekByteOff r n 22 | 23 | musashiPokeRom :: Storable a => Int -> a -> IO () 24 | musashiPokeRom n x = do 25 | r <- readIORef musashiRom 26 | pokeByteOff r n x 27 | 28 | musashiSetRom :: Ptr a -> IO () 29 | musashiSetRom = 30 | writeIORef musashiRom 31 | 32 | musashiInit :: IO () 33 | musashiInit = do 34 | m68k_init 35 | m68k_set_cpu_type m68k_CPU_TYPE_68000 36 | m68k_write_memory_32 0x0 0x4e720000 37 | 38 | musashiSetSubroutine :: Word32 -> IO () 39 | musashiSetSubroutine address = do 40 | m68k_write_memory_32 0x4 address 41 | m68k_pulse_reset 42 | 43 | musashiRun :: IO () 44 | musashiRun = do 45 | m68k_execute 1 46 | c <- m68k_cycles_remaining 47 | when (c /= 0) musashiRun 48 | 49 | foreign import ccall m68k_init :: IO () 50 | 51 | foreign import ccall m68k_pulse_reset :: IO () 52 | 53 | foreign import ccall m68k_set_reg :: CUInt -> CUInt -> IO () 54 | 55 | foreign import ccall m68k_get_reg :: Ptr a -> CUInt -> IO CUInt 56 | 57 | foreign import ccall m68k_set_cpu_type :: CUInt -> IO () 58 | 59 | foreign import ccall m68k_execute :: CUInt -> IO CInt 60 | 61 | foreign import ccall m68k_cycles_remaining :: IO CInt 62 | 63 | foreign export ccall m68k_read_memory_8 :: Int -> IO Word8 64 | 65 | m68k_read_memory_8 :: Int -> IO Word8 66 | m68k_read_memory_8 = 67 | musashiPeekRom 68 | 69 | foreign export ccall m68k_write_memory_8 :: Int -> Word8 -> IO () 70 | 71 | m68k_write_memory_8 :: Int -> Word8 -> IO () 72 | m68k_write_memory_8 = 73 | musashiPokeRom 74 | 75 | foreign export ccall m68k_read_memory_16 :: Int -> IO Word16 76 | 77 | m68k_read_memory_16 :: Int -> IO Word16 78 | m68k_read_memory_16 n = 79 | flip rotate 8 <$> musashiPeekRom n 80 | 81 | foreign export ccall m68k_write_memory_16 :: Int -> Word16 -> IO () 82 | 83 | m68k_write_memory_16 :: Int -> Word16 -> IO () 84 | m68k_write_memory_16 n x = 85 | musashiPokeRom n (rotate x 8) 86 | 87 | foreign export ccall m68k_read_memory_32 :: Int -> IO Word32 88 | 89 | reverse_bytes_32 :: Word32 -> Word32 90 | reverse_bytes_32 x = 91 | shift (x .&. 0x000000FF) 24 92 | .|. shift (x .&. 0x0000FF00) 8 93 | .|. shiftR (x .&. 0x00FF0000) 8 94 | .|. shiftR (x .&. 0xFF000000) 24 95 | 96 | m68k_read_memory_32 :: Int -> IO Word32 97 | m68k_read_memory_32 n = 98 | reverse_bytes_32 <$> musashiPeekRom n 99 | 100 | foreign export ccall m68k_write_memory_32 :: Int -> Word32 -> IO () 101 | 102 | m68k_write_memory_32 :: Int -> Word32 -> IO () 103 | m68k_write_memory_32 n = 104 | musashiPokeRom n . reverse_bytes_32 105 | 106 | m68k_CPU_TYPE_68000 :: CUInt 107 | m68k_CPU_TYPE_68000 = 108 | 1 109 | 110 | m68k_REG_D0 :: CUInt 111 | m68k_REG_D0 = 112 | 0 113 | 114 | m68k_REG_D1 :: CUInt 115 | m68k_REG_D1 = 116 | 1 117 | -------------------------------------------------------------------------------- /src/Game/Sega/Sonic/Offsets.hs: -------------------------------------------------------------------------------- 1 | module Game.Sega.Sonic.Offsets where 2 | 3 | import qualified Data.ByteString as BS 4 | import Data.Word (Word32) 5 | 6 | data Offset 7 | = Offset Word32 Word32 8 | deriving (Eq, Ord, Show) 9 | 10 | sineData :: Offset 11 | sineData = 12 | Offset 0x33CE 0x364E 13 | 14 | angleData :: Offset 15 | angleData = 16 | Offset 0x36B4 0X37B6 17 | 18 | paletteSonic :: Offset 19 | paletteSonic = 20 | Offset 0x29E2 0x2A02 21 | 22 | paletteEhz :: Offset 23 | paletteEhz = 24 | Offset 0x2A22 0x2A82 25 | 26 | curveAndResistanceMapping :: Offset 27 | curveAndResistanceMapping = 28 | Offset 0x42D50 0x42E50 29 | 30 | collisionArray1 :: Offset 31 | collisionArray1 = 32 | Offset 0x42E50 0x43E50 33 | 34 | collisionEhzHtzPrimary :: Offset 35 | collisionEhzHtzPrimary = 36 | Offset 0x44E50 0x44F40 37 | 38 | layoutEhz1 :: Offset 39 | layoutEhz1 = 40 | Offset 0x45AC4 0x45C84 41 | 42 | layoutEhz2 :: Offset 43 | layoutEhz2 = 44 | Offset 0x45C84 0x45E74 45 | 46 | artSonic :: Offset 47 | artSonic = 48 | Offset 0x50000 0x64320 49 | 50 | artTails :: Offset 51 | artTails = 52 | Offset 0x64320 0x6FBE0 53 | 54 | mappingSonic :: Offset 55 | mappingSonic = 56 | Offset 0x6FBE0 0x714E0 57 | 58 | mappingTails :: Offset 59 | mappingTails = 60 | Offset 0x739E2 0x7446C 61 | 62 | animationSonicWalk :: Offset 63 | animationSonicWalk = 64 | Offset 0x1B668 0x1B672 65 | 66 | animationSonicRun :: Offset 67 | animationSonicRun = 68 | Offset 0x1B666 0x1B670 69 | 70 | animationSonicRoll :: Offset 71 | animationSonicRoll = 72 | Offset 0x1B670 0x1B67A 73 | 74 | animationSonicRoll2 :: Offset 75 | animationSonicRoll2 = 76 | Offset 0x1B67A 0x1B684 77 | 78 | animationSonicPush :: Offset 79 | animationSonicPush = 80 | Offset 0x1B684 0x1B68E 81 | 82 | animationSonicWait :: Offset 83 | animationSonicWait = 84 | Offset 0x1B68E 0x1B744 85 | 86 | animationTailsWait :: Offset 87 | animationTailsWait = 88 | Offset 0x1D0A2 0x1D0E0 89 | 90 | dplcSonic :: Offset 91 | dplcSonic = 92 | Offset 0x714E0 0x71D8E 93 | 94 | dplcTails :: Offset 95 | dplcTails = 96 | Offset 0x7446C 0x74876 97 | 98 | blockEhz :: Offset 99 | blockEhz = 100 | Offset 0x94E74 0x95C24 101 | 102 | artEhzHtz :: Offset 103 | artEhzHtz = 104 | Offset 0x95C24 0x985A4 105 | 106 | chunkEhzHtz :: Offset 107 | chunkEhzHtz = 108 | Offset 0x99D34 0x9CFD4 109 | 110 | startPosEhz1 :: Offset 111 | startPosEhz1 = 112 | Offset 0xC1D0 0xC1D4 113 | 114 | data LevelOffsets 115 | = LevelOffsets { levelLayoutOffset :: Offset 116 | , levelChunksOffset :: Offset 117 | , levelBlocksOffset :: Offset 118 | , levelCollisionOffset :: Offset 119 | , levelPaletteOffset :: Offset 120 | , levelArtOffset :: Offset 121 | , levelStartPos :: Offset 122 | } 123 | deriving (Eq, Ord, Show) 124 | 125 | ehz1 :: LevelOffsets 126 | ehz1 = 127 | LevelOffsets layoutEhz1 chunkEhzHtz blockEhz collisionEhzHtzPrimary paletteEhz artEhzHtz startPosEhz1 128 | 129 | data SpriteOffsets 130 | = SpriteOffsets { spriteArt :: Offset 131 | , spriteMapping :: Offset 132 | , spritePalette :: Offset 133 | , spriteDPLC :: Offset 134 | } 135 | deriving (Eq, Ord, Show) 136 | 137 | sonicOffsets :: SpriteOffsets 138 | sonicOffsets = 139 | SpriteOffsets artSonic mappingSonic paletteSonic dplcSonic 140 | 141 | tailsOffsets :: SpriteOffsets 142 | tailsOffsets = 143 | SpriteOffsets artTails mappingTails paletteSonic dplcTails 144 | 145 | sliceOffset :: Offset -> BS.ByteString -> BS.ByteString 146 | sliceOffset (Offset start end) = 147 | BS.take (fromIntegral count) . BS.drop (fromIntegral start) 148 | where 149 | count = 150 | end - start 151 | -------------------------------------------------------------------------------- /src/Game/Sega/Sonic/Sprites.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | 4 | module Game.Sega.Sonic.Sprites ( 5 | copySpriteTile 6 | , copySpriteMapping 7 | , AnimationState(..) 8 | , emptyAnimationState 9 | , stepAnimation 10 | , Sprite(..) 11 | , stepSprite 12 | , spriteAnimationState 13 | , renderSprite 14 | , loadSpriteMappings 15 | ) where 16 | 17 | import Control.Applicative (liftA2) 18 | import Control.Lens 19 | import Control.Monad.IO.Class (MonadIO (..)) 20 | import Control.Monad.Reader (MonadReader) 21 | import Data.Array.Bounded 22 | import Data.Bits (shiftR, testBit, (.&.)) 23 | import Data.Foldable (for_) 24 | import Data.Vector.Storable (Vector) 25 | import Data.Word (Word16, Word8) 26 | import Foreign.C.Types (CInt) 27 | import Game.Sega.Sonic.Animation (AnimationScript (..), 28 | AnimationStep (..)) 29 | import Game.Sega.Sonic.Game 30 | import Game.Sega.Sonic.Offsets 31 | import Game.Sega.Sonic.Palette (loadPalette) 32 | import Game.Sega.Sonic.SpriteMappings 33 | import Game.Sega.Sonic.Tiles (applyDynamicPatternLoadCue, 34 | loadTiles) 35 | import Game.Sega.Sonic.Types (HasPosition (..)) 36 | import SDL hiding (Vector) 37 | import Sega.MegaDrive.Palette (readPalette) 38 | 39 | data AnimationState 40 | = AnimationState Word8 Word8 Word8 41 | deriving (Eq, Ord, Show) 42 | 43 | emptyAnimationState :: AnimationState 44 | emptyAnimationState = 45 | AnimationState 0 0 0 46 | 47 | stepAnimation :: AnimationScript -> AnimationState -> AnimationState 48 | stepAnimation (AnimationScript spriteDelay steps) (AnimationState stepIndex spriteIndex spriteCount) = 49 | if spriteCount >= spriteDelay 50 | then state' 51 | else AnimationState stepIndex spriteIndex (spriteCount + 1) 52 | where 53 | state' = 54 | case steps ! stepIndex of 55 | AnimationFrame spriteIndex' -> AnimationState (stepIndex + 1) spriteIndex' 0 56 | AnimationJumpBack j -> AnimationState (stepIndex - j) spriteIndex 0 57 | _ -> AnimationState (stepIndex + 1) spriteIndex 0 58 | 59 | data Sprite 60 | = Sprite [[SpriteMapping Texture]] (V2 CInt) AnimationScript AnimationState 61 | 62 | instance HasPosition Sprite where 63 | position = 64 | lens f g 65 | where 66 | f (Sprite _ a _ _) = 67 | a 68 | g (Sprite a _ c d) b = 69 | Sprite a b c d 70 | 71 | stepSprite :: Sprite -> Sprite 72 | stepSprite sprite = 73 | sprite & spriteAnimationState %~ stepAnimation (sprite ^. spriteAnimationScript) 74 | 75 | spriteAnimationScript :: Lens' Sprite AnimationScript 76 | spriteAnimationScript = 77 | lens f g 78 | where 79 | f (Sprite _ _ a _) = 80 | a 81 | g (Sprite a b _ d) c = 82 | Sprite a b c d 83 | 84 | spriteAnimationState :: Lens' Sprite AnimationState 85 | spriteAnimationState = 86 | lens f g 87 | where 88 | f (Sprite _ _ _ a) = 89 | a 90 | g (Sprite a b c _) d = 91 | Sprite a b c d 92 | 93 | renderSprite :: (HasRenderer g, HasCamera g, MonadReader g m, MonadIO m) => Sprite -> m () 94 | renderSprite (Sprite mappings (V2 x y) _ (AnimationState _ m _)) = do 95 | r <- view renderer 96 | o <- view (camera . cameraX) 97 | p <- view (camera . cameraY) 98 | for_ (mappings !! fromIntegral m) $ \(SpriteMapping l t w h e) -> 99 | copy r e Nothing . Just $ Rectangle (P (V2 (fromIntegral l + x - o) (fromIntegral t + y - p))) (V2 (fromIntegral w) (fromIntegral h)) 100 | 101 | copySpriteTile :: (HasRenderer g, MonadReader g m, MonadIO m) => BoundedArray Word8 (Vector (V4 Word8)) -> BoundedArray Word16 Surface -> Word16 -> V2 CInt -> m () 102 | copySpriteTile palette sprite c v = do 103 | let 104 | tileSurface = 105 | sprite ! (c .&. 0x7FF) 106 | paletteIndex = 107 | fromIntegral (c `shiftR` 13 .&. 0x3) 108 | flipY = 109 | testBit c 0xC 110 | flipX = 111 | testBit c 0xB 112 | format <- surfaceFormat tileSurface 113 | maybeTilePalette <- formatPalette format 114 | for_ maybeTilePalette $ \tilePalette -> 115 | setPaletteColors tilePalette (palette ! paletteIndex) 0 116 | r <- view renderer 117 | tileTexture <- createTextureFromSurface r tileSurface 118 | copyEx r tileTexture Nothing (Just $ Rectangle (P v) 8) 0 Nothing $ V2 flipX flipY 119 | destroyTexture tileTexture 120 | 121 | copySpriteMapping :: (HasRenderer g, MonadReader g m, MonadIO m) => BoundedArray Word8 (Vector (V4 Word8)) -> BoundedArray Word16 Surface -> SpriteMapping PatternIndex -> m (SpriteMapping Texture) 122 | copySpriteMapping palette tiles (SpriteMapping top left width height (PatternIndex patternIndex)) = do 123 | let 124 | width' = 125 | 8 * (width + 1) 126 | height' = 127 | 8 * (height + 1) 128 | r <- view renderer 129 | texture <- createTexture r ABGR8888 TextureAccessTarget $ V2 (fromIntegral width') (fromIntegral height') 130 | rendererRenderTarget r $= Just texture 131 | textureBlendMode texture $= BlendAlphaBlend 132 | ifor_ (liftA2 (,) [0..width] [0..height]) $ \i (x, y) -> 133 | let 134 | patternIndex' = 135 | patternIndex + fromIntegral i 136 | position = 137 | V2 (fromIntegral x * 8) (fromIntegral y * 8) 138 | in copySpriteTile palette tiles patternIndex' position 139 | pure $ SpriteMapping top left width' height' texture 140 | 141 | loadSpriteMappings :: (HasRom g, HasRenderer g, MonadReader g m, MonadIO m) => SpriteOffsets -> m [[SpriteMapping Texture]] 142 | loadSpriteMappings offsets = do 143 | content <- sliceRom $ spriteArt offsets 144 | mappings <- loadMappings <$> sliceRom (spriteMapping offsets) 145 | maybePalette <- readPalette <$> sliceRom (spritePalette offsets) 146 | dplc <- loadDynamicPatternLoadCues <$> sliceRom (spriteDPLC offsets) 147 | surfaces <- loadTiles content 148 | let 149 | Just palette = 150 | loadPalette <$> maybePalette 151 | f (SpriteFrame s) (DynamicPatternLoadCueFrame dplcs) = do 152 | sonicSurfaces' <- applyDynamicPatternLoadCue surfaces dplcs 153 | traverse (copySpriteMapping palette sonicSurfaces') s 154 | traverse (uncurry f) $ zip mappings dplc 155 | -------------------------------------------------------------------------------- /src/Game/Sega/Sonic/Player.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | 4 | module Game.Sega.Sonic.Player ( 5 | Player(..) 6 | , HasPlayer(..) 7 | , Statuses(..) 8 | , MdAir(..) 9 | , MdRoll(..) 10 | , HasPosition(..) 11 | , PlayerRoutine(..) 12 | , mdAir 13 | , mdRoll 14 | , playerRoutine 15 | , playerVelocity 16 | , playerRadius 17 | , playerTopSpeed 18 | , playerAcceleration 19 | , playerDeceleration 20 | , playerInertia 21 | , playerAngle 22 | , initialStatuses 23 | , isJumping 24 | , statuses 25 | , resetOnFloor 26 | , jump 27 | , moveRight 28 | , moveLeft 29 | , settle 30 | , traction 31 | , normalTopSpeed 32 | , normalAcceleration 33 | , normalDeceleration 34 | , underWaterTopSpeed 35 | , underWaterAcceleration 36 | , underWaterDeceleration 37 | , pixels 38 | , objectMove 39 | , objectMoveAndFall 40 | ) where 41 | 42 | import Control.Lens 43 | import Control.Monad.Reader (MonadReader) 44 | import Control.Monad.State 45 | import Data.Bits 46 | import Data.Halves (finiteBitHalves) 47 | import Data.Int 48 | import Data.Word (Word8) 49 | import Foreign.C.Types 50 | import Game.Sega.Sonic.Sine 51 | import Game.Sega.Sonic.Types 52 | import SDL 53 | 54 | import Debug.Trace 55 | 56 | data Player 57 | = Player (V2 CInt) (V2 Int16) (V2 CInt) Int16 Int16 Int16 Int16 Word8 Statuses 58 | deriving (Eq, Ord, Show) 59 | 60 | class HasPlayer a where 61 | player :: Lens' a Player 62 | 63 | instance HasPlayer Player where 64 | player = 65 | id 66 | 67 | data Statuses 68 | = Statuses MdAir MdRoll 69 | deriving (Eq, Ord, Show) 70 | 71 | initialStatuses :: Statuses 72 | initialStatuses = 73 | Statuses MdAirOff MdRollOff 74 | 75 | mdAir :: Lens' Statuses MdAir 76 | mdAir = 77 | lens f g 78 | where 79 | f (Statuses a _) = 80 | a 81 | g (Statuses _ b) a = 82 | Statuses a b 83 | 84 | mdRoll :: Lens' Statuses MdRoll 85 | mdRoll = 86 | lens f g 87 | where 88 | f (Statuses _ b) = 89 | b 90 | g (Statuses a _) b = 91 | Statuses a b 92 | 93 | isJumping :: Statuses -> Bool 94 | isJumping s = 95 | s ^. mdAir == MdAirOn && s ^. mdRoll == MdRollOn 96 | 97 | data PlayerRoutine 98 | = MdNormal 99 | | MdAir 100 | | MdRoll 101 | | MdJump 102 | deriving Show 103 | 104 | playerRoutine :: Statuses -> PlayerRoutine 105 | playerRoutine (Statuses MdAirOff MdRollOff) = 106 | MdNormal 107 | playerRoutine (Statuses MdAirOff MdRollOn) = 108 | MdRoll 109 | playerRoutine (Statuses MdAirOn MdRollOff) = 110 | MdAir 111 | playerRoutine (Statuses MdAirOn MdRollOn) = 112 | MdJump 113 | 114 | data MdAir 115 | = MdAirOn 116 | | MdAirOff 117 | deriving (Eq, Ord, Show) 118 | 119 | data MdRoll 120 | = MdRollOn 121 | | MdRollOff 122 | deriving (Eq, Ord, Show) 123 | 124 | instance HasPosition Player where 125 | position = 126 | lens y z 127 | where 128 | y (Player a _ _ _ _ _ _ _ _) = 129 | a 130 | z (Player _ b c d e f g h i) a = 131 | Player a b c d e f g h i 132 | 133 | playerVelocity :: Lens' Player (V2 Int16) 134 | playerVelocity = 135 | lens y z 136 | where 137 | y (Player _ b _ _ _ _ _ _ _) = 138 | b 139 | z (Player a _ c d e f g h i) b = 140 | Player a b c d e f g h i 141 | 142 | playerRadius :: Lens' Player (V2 CInt) 143 | playerRadius = 144 | lens y z 145 | where 146 | y (Player _ _ c _ _ _ _ _ _) = 147 | c 148 | z (Player a b _ d e f g h i) c = 149 | Player a b c d e f g h i 150 | 151 | playerTopSpeed :: Lens' Player Int16 152 | playerTopSpeed = 153 | lens y z 154 | where 155 | y (Player _ _ _ d _ _ _ _ _) = 156 | d 157 | z (Player a b c _ e f g h i) d = 158 | Player a b c d e f g h i 159 | 160 | playerAcceleration :: Lens' Player Int16 161 | playerAcceleration = 162 | lens y z 163 | where 164 | y (Player _ _ _ _ e _ _ _ _) = 165 | e 166 | z (Player a b c d _ f g h i) e = 167 | Player a b c d e f g h i 168 | 169 | playerDeceleration :: Lens' Player Int16 170 | playerDeceleration = 171 | lens y z 172 | where 173 | y (Player _ _ _ _ _ f _ _ _) = 174 | f 175 | z (Player a b c d e _ g h i) f = 176 | Player a b c d e f g h i 177 | 178 | playerInertia :: Lens' Player Int16 179 | playerInertia = 180 | lens y z 181 | where 182 | y (Player _ _ _ _ _ _ g _ _) = 183 | g 184 | z (Player a b c d e f _ h i) g = 185 | Player a b c d e f g h i 186 | 187 | playerAngle :: Lens' Player Word8 188 | playerAngle = 189 | lens y z 190 | where 191 | y (Player _ _ _ _ _ _ _ h _) = 192 | h 193 | z (Player a b c d e f g _ i) h = 194 | Player a b c d e f g h i 195 | 196 | statuses :: Lens' Player Statuses 197 | statuses = 198 | lens y z 199 | where 200 | y (Player _ _ _ _ _ _ _ _ i) = 201 | i 202 | z (Player a b c d e f g h _) i = 203 | Player a b c d e f g h i 204 | 205 | moveRight :: (MonadState Player m) => m () 206 | moveRight = do 207 | acceleration <- use playerAcceleration 208 | playerInertia += acceleration 209 | topSpeed <- use playerTopSpeed 210 | i <- use playerInertia 211 | unless (i < topSpeed) $ do 212 | playerInertia -= acceleration 213 | i' <- use playerInertia 214 | when (i' >= topSpeed) $ 215 | playerInertia .= topSpeed 216 | 217 | moveLeft :: (MonadState Player m) => m () 218 | moveLeft = do 219 | acceleration <- use playerAcceleration 220 | playerInertia -= acceleration 221 | topSpeed <- use playerTopSpeed 222 | i <- use playerInertia 223 | unless (i > -topSpeed) $ do 224 | playerInertia += acceleration 225 | i' <- use playerInertia 226 | when (i' <= -topSpeed) $ 227 | playerInertia .= -topSpeed 228 | 229 | settle :: (MonadState Player m) => m () 230 | settle = do 231 | i <- use playerInertia 232 | if i > 0 233 | then settleRight 234 | else settleLeft 235 | 236 | settleRight :: (MonadState Player m) => m () 237 | settleRight = do 238 | playerInertia %= \i -> max 0 (i - 0xC) 239 | 240 | settleLeft :: (MonadState Player m) => m () 241 | settleLeft = do 242 | playerInertia %= \i -> min 0 (i + 0xC) 243 | 244 | traction :: (HasPlayer s, MonadState s m) => m () 245 | traction = do 246 | -- let 247 | -- angle = 248 | -- 0 249 | -- cosine = 250 | -- 256 251 | -- sine = 252 | -- 0 253 | inertia <- use (player . playerInertia) 254 | -- let 255 | -- x = 256 | -- (inertia * cosine) `shiftR` 8 257 | -- y = 258 | -- (inertia * sine) `shiftR` 8 259 | -- v = 260 | -- V2 (fromIntegral x) (fromIntegral y) 261 | -- playerVelocity .= v 262 | player . playerVelocity .= V2 (fromIntegral inertia) 0 263 | 264 | cIntHalves :: Iso' CInt (Int16, Int16) 265 | cIntHalves = 266 | finiteBitHalves 267 | 268 | pixels :: Lens' (V2 CInt) (V2 Int16) 269 | pixels = 270 | lens f g 271 | where 272 | f (V2 a b) = 273 | V2 (a ^. cIntHalves . _1) (b ^. cIntHalves . _1) 274 | g (V2 a b) (V2 x y) = 275 | V2 (a & cIntHalves . _1 .~ x) (b & cIntHalves . _1 .~ y) 276 | 277 | jump :: (HasSineData a, MonadReader a m, MonadState Player m) => m () 278 | jump = do 279 | angle' <- use playerAngle 280 | (sine, cosine) <- calcSine (angle' - 0x40) 281 | let 282 | jumpSpeed :: Int32 283 | jumpSpeed = 284 | 0x680 285 | x :: Int16 286 | x = 287 | fromIntegral $ (jumpSpeed * fromIntegral cosine) `shiftR` 8 288 | y :: Int16 289 | y = 290 | fromIntegral $ (jumpSpeed * fromIntegral sine) `shiftR` 8 291 | statuses . mdAir .= MdAirOn 292 | statuses . mdRoll .= MdRollOn 293 | playerVelocity . _x += x 294 | playerVelocity . _y += y 295 | 296 | objectMoveAndFall :: (MonadState Player m) => m () 297 | objectMoveAndFall = do 298 | velocity <- use playerVelocity 299 | playerVelocity . _y += 0x38 300 | position += ((`shiftL` 8) . fromIntegral <$> velocity) 301 | 302 | objectMove :: (MonadState Player m) => m () 303 | objectMove = do 304 | velocity <- use playerVelocity 305 | position += ((`shiftL` 8) . fromIntegral <$> velocity) 306 | 307 | resetOnFloor :: (HasPlayer s, MonadState s m) => m () 308 | resetOnFloor = do 309 | player . statuses . mdAir .= MdAirOff 310 | player . statuses . mdRoll .= MdRollOff 311 | 312 | normalTopSpeed :: Int16 313 | normalTopSpeed = 314 | 0x600 315 | 316 | normalAcceleration :: Int16 317 | normalAcceleration = 318 | 0xC 319 | 320 | normalDeceleration :: Int16 321 | normalDeceleration = 322 | 0x80 323 | 324 | underWaterTopSpeed :: Int16 325 | underWaterTopSpeed = 326 | 0x300 327 | 328 | underWaterAcceleration :: Int16 329 | underWaterAcceleration = 330 | 0x6 331 | 332 | underWaterDeceleration :: Int16 333 | underWaterDeceleration = 334 | 0x40 335 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | import qualified Codec.Compression.Kosinski as Kosinski 6 | import Control.Lens 7 | import Control.Monad.Except 8 | import Control.Monad.Reader 9 | import Control.Monad.State 10 | import Data.Array.Bounded 11 | import Data.Array.Bounded ((!)) 12 | import Data.Bits 13 | import qualified Data.ByteString as BS 14 | import Data.ByteString.Lens 15 | import Data.Halves (collectHalves) 16 | import Data.Int 17 | import Data.Maybe (fromMaybe) 18 | import Data.Semigroup ((<>)) 19 | import Data.Time (diffUTCTime, getCurrentTime) 20 | import Data.Word 21 | import Foreign.C.Types (CInt) 22 | import Game.Sega.Sonic.Animation 23 | import Game.Sega.Sonic.Blocks 24 | import Game.Sega.Sonic.Chunks 25 | import Game.Sega.Sonic.Collision 26 | import Game.Sega.Sonic.Error 27 | import Game.Sega.Sonic.Game 28 | import Game.Sega.Sonic.Layout 29 | import Game.Sega.Sonic.Offsets as Offsets 30 | import Game.Sega.Sonic.Palette 31 | import Game.Sega.Sonic.Player 32 | import Game.Sega.Sonic.Sine 33 | import Game.Sega.Sonic.SpriteMappings 34 | import Game.Sega.Sonic.Sprites 35 | import Game.Sega.Sonic.Tiles 36 | import SDL 37 | import Sega.MegaDrive.Palette 38 | 39 | import Numeric 40 | import Debug.Trace 41 | 42 | decompressFile :: (HasRom g, MonadReader g m, MonadError SonicError m, MonadIO m) => Offset -> m BS.ByteString 43 | decompressFile offset = do 44 | maybeContent <- Kosinski.compressed <$> sliceRom offset 45 | content <- maybe (throwError $ SonicLoadError offset) pure maybeContent 46 | maybe (throwError $ SonicDecompressionError offset) pure $ Kosinski.decompress content 47 | 48 | -- NTSC 49 | frameRate :: Double 50 | frameRate = 51 | 60 52 | 53 | class HasLevel s where 54 | layout :: s -> [[Word8]] 55 | chunkBlocks :: s -> BoundedArray Word8 (BoundedArray Word8 ChunkBlock) 56 | 57 | data LevelData 58 | = LevelData AngleData [[Word8]] (BoundedArray Word8 (BoundedArray Word8 ChunkBlock)) 59 | 60 | instance HasAngleData LevelData where 61 | angleData (LevelData a _ _) = 62 | a 63 | 64 | instance HasLevel LevelData where 65 | layout (LevelData _ a _) = 66 | a 67 | chunkBlocks (LevelData _ _ a) = 68 | a 69 | 70 | findTile :: (HasLevel s, MonadReader s m) => V2 CInt -> m Word16 71 | findTile p = do 72 | layout' <- asks layout 73 | let 74 | p' = 75 | p ^. pixels 76 | V2 layoutX layoutY = 77 | (`div` 0x80) <$> p' 78 | chunkIndex = 79 | layout' !! fromIntegral layoutY !! fromIntegral layoutX 80 | blockIndex = 81 | fromIntegral chunkIndex * (0x80 :: Word16) 82 | + fromIntegral (p' ^. _y .&. 0x70) 83 | + fromIntegral (p' ^. _x .&. 0xE) 84 | pure blockIndex 85 | 86 | data WallDist 87 | = WallDist Word16 CInt Word8 88 | deriving (Eq, Ord, Show) 89 | 90 | -- Scans horizontally for up to 2 16x16 blocks to find solid walls. 91 | -- d2 = y_pos 92 | -- d3 = x_pos 93 | -- d5 = ($c,$d) or ($e,$f) - solidity type bit (L/R/B or top) 94 | -- d6 = $0000 for no flip, $0400 for horizontal flip 95 | -- a3 = delta-x for next location to check if current one is empty 96 | -- a4 = pointer to angle buffer 97 | -- returns relevant block ID in (a1) 98 | -- returns distance to left/right in d1 99 | -- returns angle in (a4) 100 | findWall :: (HasLevel s, MonadReader s m) => V2 CInt -> CInt -> m WallDist 101 | findWall p delta = do 102 | blockIndex <- findTile p 103 | if blockIndex .&. 0x3FF == 0 104 | then do 105 | WallDist a1 d1 a4 <- findWall2 (p & _x +~ delta) 106 | -- dist & distance +~ 0x10 107 | pure $ WallDist a1 (d1 + 0x10) a4 108 | else do 109 | let 110 | d1 = 111 | 0 112 | a4 = 113 | 0 114 | pure $ WallDist blockIndex d1 a4 115 | 116 | findWall2 :: (HasLevel s, MonadReader s m) => V2 CInt -> m WallDist 117 | findWall2 p = do 118 | blockIndex <- (.&. 0x3FF) <$> findTile p 119 | if blockIndex == 0 120 | then do 121 | let 122 | d1 = 123 | 0xF - (p ^. _x .&. 0xF) 124 | pure $ WallDist blockIndex d1 0 125 | else do 126 | let 127 | d1 = 128 | 0 129 | a4 = 130 | 0 131 | pure $ WallDist blockIndex d1 a4 132 | 133 | findFloor :: (HasLevel s, MonadReader s m) => V2 CInt -> CInt -> m WallDist 134 | findFloor p delta = do 135 | blockIndex <- (.&. 0x3FF) <$> findTile p 136 | let d5 = 0xC 137 | if blockIndex == 0 || not (testBit blockIndex d5) 138 | then do 139 | WallDist a1 d1 a4 <- findFloor2 (p & _y +~ delta) 140 | -- dist & distance +~ 0x10 141 | pure $ WallDist a1 (d1 + 0x10) a4 142 | else do 143 | let 144 | d1 = 145 | 0 146 | a4 = 147 | 0 148 | pure $ WallDist blockIndex d1 a4 149 | 150 | findFloor2 :: (HasLevel s, MonadReader s m) => V2 CInt -> m WallDist 151 | findFloor2 p = do 152 | blockIndex <- (.&. 0x3FF) <$> findTile p 153 | let d5 = 0xC 154 | if blockIndex == 0 || not (testBit blockIndex d5) 155 | then do 156 | let 157 | d1 = 158 | 0xF - (p ^. _y .&. 0xF) 159 | pure $ WallDist blockIndex d1 0 160 | else do 161 | let 162 | d1 = 163 | 0 164 | a4 = 165 | 0 166 | pure $ WallDist blockIndex d1 a4 167 | 168 | -- Checks a 16x16 block to find solid walls. May check an additional 169 | -- 16x16 block up for walls. 170 | -- d5 = ($c,$d) or ($e,$f) - solidity type bit (L/R/B or top) 171 | -- returns relevant block ID in (a1) 172 | -- returns distance in d1 173 | -- returns angle in d3, or zero if angle was odd 174 | checkLeftWallDist :: (HasLevel r, MonadReader r m, HasPlayer s, MonadState s m) => m WallDist 175 | checkLeftWallDist = do 176 | p <- use (player . position) 177 | findWall p (-0x10) 178 | 179 | checkRightWallDist :: (HasLevel r, MonadReader r m, HasPlayer s, MonadState s m) => m WallDist 180 | checkRightWallDist = do 181 | p <- use (player . position) 182 | findWall p (0x10) 183 | 184 | checkCeiling :: (HasLevel r, MonadReader r m, HasPlayer s, MonadState s m) => m WallDist 185 | checkCeiling = do 186 | p <- use (player . position) 187 | findFloor p (-0x10) 188 | 189 | checkFloor :: (HasLevel r, MonadReader r m, HasPlayer s, MonadState s m) => m WallDist 190 | checkFloor = do 191 | p <- use (player . position) 192 | findFloor p 0x10 193 | 194 | hitLeftWall :: (HasLevel r, MonadReader r m, HasPlayer s, MonadState s m) => m () 195 | hitLeftWall = do 196 | WallDist _ d1 _ <- checkLeftWallDist 197 | traceShow ("hitLeftWall", d1) $ pure () 198 | if d1 >= 0 199 | then hitCeiling 200 | else do 201 | player . position . _x -= d1 202 | player . playerVelocity . _x .= 0 203 | y_vel <- use (player . playerVelocity . _y) 204 | player . playerInertia .= y_vel 205 | 206 | hitCeiling :: (HasLevel g, MonadReader g m, HasPlayer s, MonadState s m) => m () 207 | hitCeiling = do 208 | WallDist _ d1 _ <- checkCeiling 209 | traceShow ("hitCeiling", d1) $ pure () 210 | if d1 >= 0 211 | then hitFloor 212 | else do 213 | player . position . _y -= d1 214 | y_vel <- use (player . playerVelocity . _y) 215 | when (y_vel < 0) $ 216 | player . playerVelocity . _y .= 0 217 | 218 | hitFloor :: (HasLevel g, MonadReader g m, HasPlayer s, MonadState s m) => m () 219 | hitFloor = do 220 | y_vel <- use (player . playerVelocity . _y) 221 | unless (y_vel < 0) $ do 222 | WallDist _ d1 d3 <- checkFloor 223 | traceShow ("hitFloor", d1) $ pure () 224 | when (d1 < 0) $ do 225 | player . position . _y += d1 226 | player . playerAngle .= d3 227 | resetOnFloor 228 | player . playerVelocity . _y .= 0 229 | x_vel <- use (player . playerVelocity . _x) 230 | player . playerInertia .= x_vel 231 | 232 | hitCeilingAndWalls :: (HasLevel g, MonadReader g m, HasPlayer s, MonadState s m) => m () 233 | hitCeilingAndWalls = do 234 | WallDist _ d1 _ <- checkLeftWallDist 235 | when (d1 < 0) $ do 236 | player . position . _x -= d1 237 | player . playerVelocity . _x .= 0 238 | 239 | WallDist _ d1' _ <- checkRightWallDist 240 | when (d1' < 0) $ do 241 | player . position . _x += d1 242 | player . playerVelocity . _x .= 0 243 | 244 | WallDist _ d1'' d3 <- checkCeiling 245 | when (d1'' < 0) $ do 246 | player . position . _y -= d1'' 247 | let d0 = (d3 + 0x20) .&. 0x40 248 | if (d0 /= 0) 249 | then do 250 | player . playerAngle .= d3 251 | resetOnFloor 252 | y_vel <- use (player . playerVelocity . _y) 253 | player . playerInertia .= y_vel 254 | inertia <- use (player . playerInertia) 255 | unless (d3 < 0) $ 256 | player . playerInertia .= (-inertia) 257 | else player . playerVelocity . _y .= 0; 258 | 259 | hitRightWall :: (HasLevel g, MonadReader g m, HasPlayer s, MonadState s m) => m () 260 | hitRightWall = do 261 | WallDist _ d1 _ <- checkRightWallDist 262 | traceShow ("hitRightWall", d1) $ pure () 263 | if d1 >= 0 264 | then hitCeiling 265 | else do 266 | player . position . _x += d1 267 | player . playerVelocity . _x .= 0 268 | y_vel <- use (player . playerVelocity . _y) 269 | player . playerInertia .= y_vel 270 | 271 | doLevelCollision :: (HasAngleData g, HasLevel g, MonadReader g m, HasPlayer s, MonadState s m) => m () 272 | doLevelCollision = do 273 | -- TODO: Check left/right/bottom solid bit 274 | v <- use (player . playerVelocity) 275 | a <- calcAngle v 276 | traceShow ("doLevelCollision", (a - 0x20) .&. 0xC0) $ pure () 277 | case (a - 0x20) .&. 0xC0 of 278 | 0x40 -> hitLeftWall 279 | 0x80 -> hitCeilingAndWalls 280 | 0xC0 -> hitRightWall 281 | _ -> do 282 | WallDist _ d1 _ <- checkLeftWallDist 283 | when (d1 < 0) $ do 284 | -- p->x_pos -= d1; 285 | -- p->x_vel = 0; 286 | traceShow "TODO" $ pure () 287 | 288 | WallDist _ d1' _ <- checkLeftWallDist 289 | when (d1' < 0) $ do 290 | -- p->x_pos += d1; 291 | -- p->x_vel = 0; 292 | traceShow "TODO" $ pure () 293 | 294 | WallDist _ d1'' d3 <- checkFloor 295 | unless (d1'' < 0) $ do 296 | v <- use (player . playerVelocity) 297 | -- let d2 = negate ((v ^. _y `shiftR` 8) + 8) 298 | player . position . _y += d1'' 299 | player . playerAngle .= d3 300 | resetOnFloor 301 | -- d0 = (d3 + 0x10) & 0x20; 302 | -- if((char)d0 == 0) 303 | -- goto loc_1AF5A; 304 | -- if(p->y_vel < 0){ // p->y_vel /= 2; -- DONE THIS WAY FOR ACCURACY 305 | -- p->y_vel >>= 1; 306 | -- p->y_vel |= 0x80000000; 307 | -- } 308 | -- else 309 | -- p->y_vel >>= 1; 310 | -- goto loc_1AF7C; 311 | 312 | -- Subroutine to change Sonic's angle as he walks along the floor 313 | sonicAngle :: (Applicative m) => Word8 -> m () 314 | sonicAngle _ = 315 | pure () 316 | 317 | anglePos :: (HasLevel g, HasAngleData g, MonadReader g m, HasPlayer s, MonadState s m) => m () 318 | anglePos = do 319 | -- unless onobject 320 | a <- use (player . playerAngle) 321 | let 322 | a' = 323 | if a + 0x20 >= 0 324 | then (if a < 0 then a + 1 else a) + 0x1F 325 | else error "angle pos 1" 326 | 327 | case (a' + 0x20) .&. 0xC0 of 328 | 0x40 -> pure () 329 | 0x80 -> pure () 330 | 0xC0 -> pure () 331 | _ -> do 332 | p <- use (player . position) 333 | r <- use (player . playerRadius) 334 | WallDist _ d1 a4 <- findFloor (p + r) 0x10 335 | sonicAngle a4 336 | unless (d1 == 0) $ do 337 | if d1 >= 0 338 | then do 339 | v <- use (player . playerVelocity) 340 | let d0 = min 0xE (abs (v ^. _x `shiftR` 8) + 4) 341 | if d1 > fromIntegral d0 342 | then player . statuses . mdAir .= MdAirOn 343 | -- player . status &= 0xDF 344 | -- pure () 345 | else player . position . _y += d1 346 | else 347 | unless (d1 < (-0xE)) $ 348 | player . position . _y += d1 349 | 350 | x :: (HasLevel g, MonadReader g m) => V2 CInt -> m WallDist 351 | x p = do 352 | l <- asks layout 353 | c <- asks chunkBlocks 354 | let 355 | reindexedCollisionBlocks = 356 | undefined 357 | reindexedCurves = 358 | undefined 359 | 360 | V2 layoutX layoutY = 361 | (`div` 0x80) <$> p 362 | chunkIndex = 363 | l !! fromIntegral layoutY !! fromIntegral layoutX 364 | V2 blockX blockY = 365 | ((`div` 0x10) . (`rem` 0x80)) <$> p 366 | ChunkBlock blockIndex flipX flipY = 367 | (c ! chunkIndex) ! fromIntegral ((blockY * 8) + blockX) 368 | V2 pixelX pixelY = 369 | (`rem` 0x10) <$> p 370 | CollisionBlock heights = 371 | reindexedCollisionBlocks ! blockIndex 372 | angle' = 373 | (if flipX then negate else id) $ reindexedCurves ! blockIndex 374 | flip' flag n = 375 | if flag then 0xF - n else n 376 | height = 377 | fromMaybe 0 (heights ! fromIntegral (flip' flipX pixelX)) 378 | heightDifference = 379 | (0x10 - flip' flipY pixelY) - (fromIntegral height + 2) 380 | pure $ WallDist blockIndex heightDifference angle' 381 | 382 | loadAndRun :: (MonadReader Game m, MonadError SonicError m, MonadIO m) => m () 383 | loadAndRun = do 384 | sonicMappings <- loadSpriteMappings sonicOffsets 385 | tailsMappings <- loadSpriteMappings tailsOffsets 386 | 387 | curves <- listArrayFill 0 . BS.unpack <$> sliceRom curveAndResistanceMapping 388 | 389 | sonicAnimationScript <- loadAnimation . BS.unpack <$> sliceRom animationSonicWait 390 | tailsAnimationScript <- loadAnimation . BS.unpack <$> sliceRom animationTailsWait 391 | 392 | let offsets = ehz1 393 | maybeSonicPalette <- readPalette <$> sliceRom paletteSonic 394 | maybePalette <- readPalette <$> sliceRom (levelPaletteOffset offsets) 395 | palette <- maybe (throwError . SonicPaletteError $ levelPaletteOffset offsets) (pure . loadPalette) (maybeSonicPalette <> maybePalette) 396 | tileContent <- decompressFile $ levelArtOffset offsets 397 | tileSurfaces <- loadTiles tileContent 398 | blockContent <- decompressFile $ levelBlocksOffset offsets 399 | blockTextures <- loadBlocks palette tileSurfaces blockContent 400 | chunkContent <- decompressFile $ levelChunksOffset offsets 401 | let chunkBlocks = loadChunks chunkContent 402 | chunkTextures <- traverse (loadChunkTexture blockTextures) chunkBlocks 403 | layoutContent <- decompressFile $ levelLayoutOffset offsets 404 | let 405 | layout = 406 | loadLayout layoutContent 407 | layoutChunkTextures = 408 | mapChunkTextures chunkTextures layout 409 | 410 | collisionIndexContent <- decompressFile $ levelCollisionOffset offsets 411 | collisionIndex <- loadCollisionIndex collisionIndexContent 412 | 413 | collisionContent <- sliceRom collisionArray1 414 | let collisionBlocks = loadCollisionBlocks collisionContent 415 | collisionBlockTextures <- traverse loadCollisionTexture collisionBlocks 416 | 417 | let reindexedCollisionTextures = (collisionBlockTextures !) <$> collisionIndex 418 | reindexedCollisionBlocks = (collisionBlocks !) <$> collisionIndex 419 | reindexedCurves = (curves !) <$> collisionIndex 420 | 421 | now <- liftIO getCurrentTime 422 | chunksContent <- decompressFile $ levelChunksOffset offsets 423 | liftIO $ putStrLn "Loading chunks..." 424 | let chunksBlocks = loadChunks chunksContent 425 | chunksTextures <- traverse (loadChunkTexture reindexedCollisionTextures) chunksBlocks 426 | now' <- liftIO getCurrentTime 427 | liftIO . putStrLn $ "Chunks loaded in " <> show (diffUTCTime now' now) 428 | 429 | sineData' <- SineData . listArrayFill 0 . fmap fromIntegral . view (unpackedBytes . collectHalves) <$> sliceRom Offsets.sineData 430 | angleData' <- AngleData . listArrayFill 0 . fmap fromIntegral . view (unpackedBytes . collectHalves) <$> sliceRom Offsets.angleData 431 | 432 | let 433 | collisionTextures = mapChunkTextures chunksTextures layout 434 | levelData = LevelData angleData' layout chunkBlocks 435 | 436 | startPos <- sliceRom $ levelStartPos ehz1 437 | let 438 | playerStart = 439 | case (startPos ^. unpackedBytes . collectHalves) of 440 | [x, y] -> 441 | V2 (fromIntegral x) (fromIntegral y) 442 | _ -> 443 | V2 0 0 444 | 445 | r <- view renderer 446 | rendererRenderTarget r $= Nothing 447 | 448 | let 449 | playerSprite = 450 | Sprite sonicMappings (V2 0 0) sonicAnimationScript emptyAnimationState 451 | render textures (V2 o p) = 452 | ifor_ textures $ \y row -> 453 | ifor_ row $ \x texture -> 454 | let 455 | rectangle = 456 | Rectangle (P (V2 ((fromIntegral x * 0x80) - o) ((fromIntegral y * 0x80) - p))) 0x80 457 | in copy r texture Nothing (Just rectangle) 458 | appLoop playerSprite' game = do 459 | -- startTicks <- ticks 460 | events <- pollEvents 461 | let 462 | eventIsPress keycode event = 463 | case eventPayload event of 464 | KeyboardEvent keyboardEvent -> 465 | keyboardEventKeyMotion keyboardEvent == Pressed && 466 | keysymKeycode (keyboardEventKeysym keyboardEvent) == keycode 467 | _ -> 468 | False 469 | isPressed keycode = 470 | any (eventIsPress keycode) events 471 | qPressed = 472 | isPressed KeycodeQ 473 | jumpPressed = 474 | isPressed KeycodeA || isPressed KeycodeS || isPressed KeycodeD 475 | leftPressed = 476 | isPressed KeycodeLeft 477 | rightPressed = 478 | isPressed KeycodeRight 479 | -- downPressed = 480 | -- isPressed KeycodeDown 481 | -- upPressed = 482 | -- isPressed KeycodeUp 483 | playerSprite'' = 484 | playerSprite' & position .~ (fromIntegral <$> (game ^. player . position . pixels)) 485 | updateGame = do 486 | zoom player $ do 487 | s <- use statuses 488 | traceShow (playerRoutine s) $ pure () 489 | case playerRoutine s of 490 | MdNormal -> do 491 | if jumpPressed 492 | then runReaderT jump sineData' 493 | else do 494 | if rightPressed 495 | then moveRight 496 | else when leftPressed moveLeft 497 | when (not rightPressed && not leftPressed) settle 498 | objectMove 499 | traction 500 | runReaderT anglePos levelData 501 | MdAir -> do 502 | objectMoveAndFall 503 | runReaderT doLevelCollision levelData 504 | MdRoll -> 505 | pure () 506 | MdJump -> do 507 | objectMoveAndFall 508 | runReaderT doLevelCollision levelData 509 | p' <- use (player . position . pixels) 510 | camera .= (fromIntegral <$> p') - V2 160 128 -- V2 o' p' 511 | game' = 512 | execState updateGame game 513 | 514 | rendererDrawColor r $= V4 0 0 0 0xFF 515 | clear r 516 | render layoutChunkTextures (game' ^. camera) 517 | runReaderT (renderSprite playerSprite'') game' 518 | present r 519 | delay 16 520 | unless qPressed (appLoop (stepSprite playerSprite'') game') 521 | game <- ask 522 | appLoop playerSprite (game & player . position . pixels .~ playerStart) 523 | 524 | main :: IO () 525 | main = do 526 | rom' <- BS.readFile "sonic2.md" 527 | 528 | window <- createWindow "Sonic 2" defaultWindow { windowInitialSize = V2 320 224 } 529 | renderer' <- createRenderer window (-1) defaultRenderer 530 | rendererLogicalSize renderer' $= Just (V2 320 224) 531 | 532 | e <- runReaderT (runExceptT loadAndRun) (Game renderer' 0 rom' $ Player (V2 0 0) (V2 0 0) (V2 0 0x13) normalTopSpeed normalAcceleration normalDeceleration 0 0 initialStatuses) 533 | either print pure e 534 | --------------------------------------------------------------------------------