Emulation/Stellarator
1
0
Fork 0
mirror of https://github.com/dpiponi/Stellarator.git synced 2024-05-16 19:10:42 -04:00
Code Issues Packages Projects Releases Wiki Activity

Slightly more Atari2600 reintroduced

Browse source
This commit is contained in:
Dan Piponi 2016-12-08 21:57:16 -08:00
parent bf231df79f
commit 676d588176
4 changed files with 133 additions and 37 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

30
LICENSE Normal file
View file

@ -0,0 +1,30 @@
Copyright Author name here (c) 2016
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Author name here nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

69
app/Main.hs
View file

@ -78,12 +78,16 @@ data Registers = R {
}
-}
{-
data StellaClock = Clock {
_now :: !Int64,
_last :: !Int64
}
-}
{-
$(makeLenses ''StellaClock)
-}
{-
data StellaDebug = Debug {
@ -107,7 +111,8 @@ data StellaSDL = StellaSDL {
$(makeLenses '' StellaSDL)
-}
data StateAtari = S {
{-
data Atari2600 = S {
_mem :: IOUArray Int Word8,
_regs :: !Registers,
_clock :: !Int64,
@ -125,8 +130,9 @@ data StateAtari = S {
_intervalTimer :: IntervalTimer
}
$(makeLenses ''StateAtari)
$(makeLenses ''Atari2600)
$(makeLenses ''Registers)
-}
{-# INLINE i8 #-}
i8 :: Integral a => a -> Word8
@ -188,9 +194,9 @@ swchb = 0x282
{-# INLINE backSurface #-}
{-# INLINE frontSurface #-}
{-# INLINE frontWindow #-}
backSurface :: Lens' StateAtari Surface
frontSurface :: Lens' StateAtari Surface
frontWindow :: Lens' StateAtari SDL.Window
backSurface :: Lens' Atari2600 Surface
frontSurface :: Lens' Atari2600 Surface
frontWindow :: Lens' Atari2600 SDL.Window
backSurface = stellaSDL . sdlBackSurface
frontSurface = stellaSDL . sdlFrontSurface
frontWindow = stellaSDL . sdlFrontWindow
@ -198,7 +204,7 @@ frontWindow = stellaSDL . sdlFrontWindow
{-# INLINE hpos #-}
{-# INLINE vpos #-}
hpos, vpos :: Lens' StateAtari CInt
hpos, vpos :: Lens' Atari2600 CInt
hpos = position . _1
vpos = position . _2
@ -207,43 +213,39 @@ vpos = position . _2
{-# INLINE mpos0 #-}
{-# INLINE mpos1 #-}
{-# INLINE bpos #-}
ppos0, ppos1, mpos0, mpos1, bpos :: Lens' StateAtari CInt
ppos0, ppos1, mpos0, mpos1, bpos :: Lens' Atari2600 CInt
ppos0 = sprites . s_ppos0
ppos1 = sprites . s_ppos1
mpos0 = sprites . s_mpos0
mpos1 = sprites . s_mpos1
bpos = sprites . s_bpos
{-
{-# INLINE nowClock #-}
{-# INLINE lastClock #-}
nowClock, lastClock :: Lens' StateAtari Int64
nowClock, lastClock :: Lens' Atari2600 Int64
nowClock = stellaClock . now
lastClock = stellaClock . last
-}
{- INLINE stellaDebugStr -}
stellaDebugStr :: (MonadIO m, MonadState StateAtari m) =>
stellaDebugStr :: (MonadIO m, MonadState Atari2600 m) =>
Int -> String -> m ()
stellaDebugStr n str = do
d <- use (stellaDebug . debugLevel)
if n <= d
then do
before <- use lastClock
now <- use nowClock
liftIO $ putStr $ show now ++ " +" ++ show (now-before) ++ ": " ++ str
lastClock .= now
liftIO $ putStr str
else return ()
{- INLINE stellaDebugStrLn -}
stellaDebugStrLn :: (MonadIO m, MonadState StateAtari m) =>
stellaDebugStrLn :: (MonadIO m, MonadState Atari2600 m) =>
Int -> String -> m ()
stellaDebugStrLn n str = do
d <- use (stellaDebug . debugLevel)
if n <= d
then do
before <- use lastClock
now <- use nowClock
liftIO $ putStrLn $ show now ++ " +" ++ show (now-before) ++ ": " ++ str
lastClock .= now
liftIO $ putStrLn str
else return ()
{-# INLINE putORegister #-}
@ -365,7 +367,7 @@ stretchPlayer reflect sizeCopies o bitmap =
then testBit bitmap (flipIf reflect $ (fromIntegral ((o `shift` (-2)) .&. 7)))
else False
-- StateAtari programmer's guide p.40
-- Atari2600 programmer's guide p.40
{- INLINE player0 -}
player0 :: IOUArray OReg Word8 -> Graphics -> CInt -> CInt -> IO Bool
player0 r graphics' hpos' ppos0' = do
@ -393,7 +395,7 @@ player1 r graphics' hpos' ppos1' = do
missileSize :: Word8 -> CInt
missileSize nusiz = 1 `shift` (fromIntegral ((nusiz `shift` (-4)) .&. 0b11))
-- StateAtari programmer's guide p.22
-- Atari2600 programmer's guide p.22
{- INLINE missile0 -}
-- XXX Note that this updates mpos0 so need to take into account XXX
missile0 :: IOUArray OReg Word8 -> CInt -> CInt -> Word8 -> IO Bool
@ -575,7 +577,7 @@ bit :: Int -> Bool -> Word8
bit n t = if t then 1 `shift` n else 0
{- INLINE compositeAndCollide -}
compositeAndCollide :: StateAtari -> CInt -> CInt -> IOUArray OReg Word8 -> IO Word8
compositeAndCollide :: Atari2600 -> CInt -> CInt -> IOUArray OReg Word8 -> IO Word8
compositeAndCollide stella x hpos' r = do
resmp0' <- fastGetORegister r resmp0
resmp1' <- fastGetORegister r resmp1
@ -651,7 +653,7 @@ updatePos (hpos, vpos) =
stellaTickUntil :: Int64 -> MonadAtari ()
stellaTickUntil n = do
c <- use nowClock
c <- use stellaClock
stellaTick (fromIntegral (n-c))
stellaTick :: Int -> MonadAtari ()
@ -664,7 +666,7 @@ stellaTick n = do
dumpStella
stellaDebug . posbreak .= (-1, -1) -- Maybe maybe
nowClock += 1
stellaClock += 1
intervalTimer %= timerTick
-- Display
@ -693,8 +695,8 @@ stellaTick n = do
stellaTick (n-1)
newtype MonadAtari a = M { unM :: StateT StateAtari IO a }
deriving (Functor, Applicative, Monad, MonadState StateAtari, MonadIO)
newtype MonadAtari a = M { unM :: StateT Atari2600 IO a }
deriving (Functor, Applicative, Monad, MonadState Atari2600, MonadIO)
instance Emu6502 MonadAtari where
{-# INLINE readMemory #-}
@ -899,13 +901,13 @@ dumpState = do
-- XXX Do this! If reset occurs during horizontal blank, the object will appear at the left side of the television screen
{- INLINE setBreak -}
setBreak :: (MonadIO m, MonadState StateAtari m) =>
setBreak :: (MonadIO m, MonadState Atari2600 m) =>
CInt -> CInt -> m ()
setBreak x y = stellaDebug . posbreak .= (x+picx, y+picy)
{-
{-# INLINE usingStella #-}
usingStella :: StateT StateAtari IO a -> MonadAtari a
usingStella :: StateT Atari2600 IO a -> MonadAtari a
usingStella m = do
stella' <- use stella
(a, stella'') <- liftIO $ flip runStateT stella' m
@ -1337,8 +1339,8 @@ initState :: IOUArray Int Word8 ->
IOUArray IReg Word8 ->
Word16 ->
Surface -> Surface ->
SDL.Window -> StateAtari
initState memory oregs iregs initialPC helloWorld screenSurface window = Main.S {
SDL.Window -> Atari2600
initState memory oregs iregs initialPC helloWorld screenSurface window = Atari2600 {
_mem = memory, _clock = 0, _regs = R initialPC 0 0 0 0 0xff,
_debug = 8,
@ -1353,10 +1355,7 @@ initState memory oregs iregs initialPC helloWorld screenSurface window = Main.S
_sprites = Stella.Sprites.start,
_intervalTimer = Stella.IntervalTimer.start,
_graphics = Stella.Graphics.start,
_stellaClock = Main.Clock {
_now = 0,
_last = 0
},
_stellaClock = 0,
_stellaDebug = DebugState.start
}
@ -1382,7 +1381,7 @@ main = do
let state = initState memory oregs iregs initialPC helloWorld screenSurface window
let loopUntil n = do
stellaClock' <- use nowClock
stellaClock' <- use stellaClock
when (stellaClock' < n) $ do
step
loopUntil n
@ -1395,7 +1394,7 @@ main = do
let quit = elem SDL.QuitEvent $ map SDL.eventPayload events
forM_ events handleEvent
stellaClock' <- use nowClock
stellaClock' <- use stellaClock
loopUntil (stellaClock' + 1000)
loop

4
src/Atari2600.hs
View file

@ -45,7 +45,6 @@ data Registers = R {
_s :: !Word8
}
{-
data BankMode = UnBanked | F8 deriving (Show, Data, Typeable)
data Atari2600 = Atari2600 {
@ -62,7 +61,7 @@ data Atari2600 = Atari2600 {
_stellaSDL :: SDLState,
_position :: (CInt, CInt),
_stellaClock :: Int64,
_stellaClock :: !Int64,
_graphics :: Graphics,
_sprites :: Sprites,
_intervalTimer :: IntervalTimer
@ -71,6 +70,7 @@ data Atari2600 = Atari2600 {
$(makeLenses ''Atari2600)
$(makeLenses ''Registers)
{-
newtype MonadAtari a = M { unM :: StateT Atari2600 IO a }
deriving (Functor, Applicative, Monad, MonadState Atari2600, MonadIO)

67
stack.yaml Normal file
View file

@ -0,0 +1,67 @@
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# http://docs.haskellstack.org/en/stable/yaml_configuration/
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
# resolver: ghcjs-0.1.0_ghc-7.10.2
# resolver:
# name: custom-snapshot
# location: "./custom-snapshot.yaml"
resolver: lts-7.10
# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# - location:
# git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# extra-dep: true
# subdirs:
# - auto-update
# - wai
#
# A package marked 'extra-dep: true' will only be built if demanded by a
# non-dependency (i.e. a user package), and its test suites and benchmarks
# will not be run. This is useful for tweaking upstream packages.
packages:
- '.'
# Dependency packages to be pulled from upstream that are not in the resolver
# (e.g., acme-missiles-0.3)
extra-deps: []
# Override default flag values for local packages and extra-deps
flags: {}
# Extra package databases containing global packages
extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=1.2"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
extra-lib-dirs:
- /usr/lib
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor