Merge branch 'master' of https://github.com/dpiponi/Stellarator

README.md

@@ -11,6 +11,7 @@ This project has a sister project [Alcator](https://github.com/dpiponi/Alcator).
 
 News
 ----
+* Ported to GLFW
 * I'm going to port from SDL to GLFW and then maybe I can make audio work.
 * Runs at correct frame rate now.
 * Added second joystick emulation.
@@ -32,28 +33,10 @@ Installation
 ------------
 * It's written in Haskell.
 
-* Before doing anything else, you'll need to install the SDL libraries somewhere the Haskell
-  package manager Stack can find them.  I work on a Mac so I used MacPorts which you can install
-  from here: https://www.macports.org
-
-  Once MacPorts was installed I used:
-
-```
-    port install libsdl2
-    port install libsdl2_image
-```
-
-  I've had success with homebrew as well, in which case I think you can use:
-
-```
-    brew install sdl2
-    brew install sdl2_image
-```
-
-Getting SDL2 installed seems to be the main stumbling block.
-
 * If you don't have Stack, install it using the instructions here: https://docs.haskellstack.org/en/stable/
 
+* You may need to install OpenGL and GLFW.
+
 * Now clone the project into a directory. In that directory use:
 
 ```
@@ -70,8 +53,7 @@ You'll need to obtain ADVNTURE.BIN from somewhere like https://www.atariage.com/
 
 * If you started with ADVNTURE.BIN then hit `v` and start using the cursor keys. Have fun!
 
-Similar instructions have worked under Linux but I don't actively maintain that.
-I've never tested under Windows. Looking for a volunteer!
+Similar instructions have worked under Linux and Windows but I don't actively maintain that.
 
 Instructions
 ------------

src/Disasm.hs

@@ -1,8 +1,6 @@
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE BinaryLiterals #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 -- http://nesdev.com/6502_cpu.txt
 -- http://www.zimmers.net/anonftp/pub/cbm/documents/chipdata/64doc
@@ -26,7 +24,7 @@ inHex16 x = "0x" ++ showHex x ""
 address8 :: Word8 -> String
 address8 x =
     if isTIA (fromIntegral x)
-        then inHex8 x ++ case (x .&. 0x3f) of
+        then inHex8 x ++ case x .&. 0x3f of
            0x00 -> "; VSYNC or CXM0P"
            0x01 -> "; VBLANK or CXM1P"
            0x02 -> "; WSYNC or CXP0FB"
@@ -154,8 +152,8 @@ withData02 bbb useY mne bs = case bbb of
 
     _ -> error "Unknown addressing mode"
 
-dis_illegal :: Word8 -> [Word8] -> (Int, String, [Word8])
-dis_illegal _ bs = (0, "error", bs)
+disIllegal :: Word8 -> [Word8] -> (Int, String, [Word8])
+disIllegal _ bs = (0, "error", bs)
 
 disasm :: Word16 -> [Word8] -> (Int, String, [Word8])
 disasm _ [] = error "Shouldn't happen"
@@ -211,7 +209,7 @@ disasm pc (b : bs) =
                         0b110 -> withData02 bbb False "cpy" bs
                         0b111 -> withData02 bbb False "cpx" bs
 
-                        _ -> dis_illegal b bs
+                        _ -> disIllegal b bs
 
                 0b01 -> do
                     let aaa = (b `shift` (-5)) .&. 0b111
@@ -227,7 +225,7 @@ disasm pc (b : bs) =
                         0b110 -> withData01 bbb "cmp" bs
                         0b111 -> withData01 bbb "sbc" bs
 
-                        _ -> dis_illegal b bs
+                        _ -> disIllegal b bs
                 0b10 -> do
                     let aaa = (b `shift` (-5)) .&. 0b111
                     let bbb = (b `shift` (-2)) .&. 0b111
@@ -243,7 +241,7 @@ disasm pc (b : bs) =
                         0b111 -> withData02 bbb False "inc" bs
                         _     -> error "Impossible"
 
-                _ -> dis_illegal b bs
+                _ -> disIllegal b bs
 
 dis :: Int -> Word16 -> [Word8] -> IO ()
 dis 0 _ _ = return ()

src/Display.hs

@@ -12,9 +12,7 @@ import Metrics ( screenWidth, screenHeight )
 import Foreign.Marshal.Alloc ( mallocBytes )
 import Foreign.Ptr ( Ptr )
 import Foreign.Storable ( Storable(pokeElemOff) )
-import System.Exit ( die )
-
-import System.Exit (exitFailure)
+import System.Exit (die, exitFailure)
 import System.IO
 import TIAColors
 import qualified Data.ByteString as BS
@@ -180,8 +178,8 @@ draw windowWidth windowHeight program attrib = do
     -- Retina display requires 2*
     -- Don't know correct GLFW sequence to get this right.
     GL.viewport $= (GL.Position 0 0,
-                    GL.Size (2*fromIntegral windowWidth) (2*fromIntegral windowHeight))
-                    -- GL.Size (fromIntegral windowWidth) (fromIntegral windowHeight))
+                    -- GL.Size (2*fromIntegral windowWidth) (2*fromIntegral windowHeight))
+                    GL.Size (fromIntegral windowWidth) (fromIntegral windowHeight))
 
     GL.currentProgram $= Just program
     GL.vertexAttribArray attrib $= GL.Enabled

src/Emulation.hs

@@ -1,8 +1,5 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE BinaryLiterals #-}
-{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE ApplicativeDo #-}
 
 module Emulation where
@@ -552,7 +549,7 @@ brk = do
 irq :: MonadAtari ()
 irq = do
     fi <- getI
-    when (not fi) $ nmi False
+    unless fi $ nmi False
 
 -- {-# INLINABLE pushTick #-}
 pushTick :: Word8 -> MonadAtari ()
@@ -576,6 +573,7 @@ push v = do
     writeMemory (0x100+i16 sp) v
     putS (sp-1)
 
+{-
 -- {-# INLINABLE pull #-}
 pull :: MonadAtari Word8
 pull = do
@@ -583,16 +581,21 @@ pull = do
     let sp' = sp+1
     putS sp'
     readMemory (0x100+i16 sp')
+-}
 
 spinPC :: MonadAtari ()
 spinPC = discard fetchByteTick
 
+discardReadPC :: MonadAtari ()
+discardReadPC = do
+    tick 1
+    discard $ getPC >>= readMemory
+
 -- 3 clock cycles
 -- {-# INLINABLE pha #-}
 pha :: MonadAtari ()
 pha = do
-    tick 1
-    discard $ getPC >>= readMemory
+    discardReadPC
 
     tick 1
     getA >>= push
@@ -601,8 +604,7 @@ pha = do
 -- {-# INLINABLE php #-}
 php :: MonadAtari ()
 php = do
-    tick 1
-    discard $ getPC >>= readMemory
+    discardReadPC
 
     tick 1
     getP >>= push . (.|. 0x30)
@@ -611,31 +613,17 @@ php = do
 -- {-# INLINABLE plp #-}
 plp :: MonadAtari ()
 plp = do
-    tick 1
-    p0 <- getPC
-    discard $ readMemory p0
-
-    tick 1
-    s <- getS
-    discard $ readMemory (0x100+i16 s)
-
-    tick 1
-    pull >>= putP
+    discardReadPC
+    spinTOS
+    pullTick >>= putP
 
 -- 4 clock cycles
 -- {-# INLINABLE pla #-}
 pla :: MonadAtari ()
 pla = do
-    tick 1
-    p0 <- getPC
-    discard $ readMemory p0
-
-    tick 1
-    s <- getS
-    discard $ readMemory (0x100+i16 s)
-
-    tick 1
-    pull >>= setNZ >>= putA
+    discardReadPC
+    spinTOS
+    pullTick >>= setNZ >>= putA
 
 -- {-# INLINABLE nmi #-}
 nmi :: Bool -> MonadAtari ()
@@ -649,6 +637,7 @@ nmi sw = do
     read16 0xfffe >>= putPC -- irq/brk XXX
     tick 7
 
+-- Read from top of stack but do nothing with it.
 spinTOS :: MonadAtari ()
 spinTOS = do
     tick 1
@@ -659,16 +648,8 @@ spinTOS = do
 -- {-# INLINABLE rti #-}
 rti :: MonadAtari ()
 rti = do
-    tick 1
-    p0 <- getPC
-    void $ readMemory p0
-
-    spinTOS
-
-    tick 1
-    pull >>= putP
-
-    make16 <$> (tick 1 >> pull) <*> (tick 1 >> pull) >>= putPC
+    plp
+    make16 <$> pullTick <*> pullTick >>= putPC
 
 -- 6 clock cycles
 -- {-# INLINABLE jsr #-}
@@ -709,7 +690,7 @@ rts = do
     s <- getS
     discard $ readMemory (0x100+i16 s)
 
-    p0 <- make16 <$> (tick 1 >> pull) <*> (tick 1 >> pull)
+    p0 <- make16 <$> pullTick <*> pullTick
     
     tick 1
     discard $ readMemory p0
@@ -862,29 +843,25 @@ stellaVsync v = do
         renderDisplay
     vsync @= v
 
--- {-# INLINE pureReadRom #-}
--- | pureReadRom sees address in full 6507 range 0x0000-0x1fff
-pureReadRom :: Word16 -> MonadAtari Word8
-pureReadRom addr = do
+withMemory :: Word16 -> (IOUArray Int Word8 -> BankState -> Int-> MonadAtari a) -> MonadAtari a
+withMemory addr op = do
     atari <- ask
     let m = atari ^. rom
     let bankStateRef = atari ^. bankState
     bankState' <- liftIO $ readIORef bankStateRef
     let bankedAddress = bankAddress bankState' addr
-    liftIO $ readArray m bankedAddress
+    op m bankState' bankedAddress
+
+-- {-# INLINE pureReadRom #-}
+-- | pureReadRom sees address in full 6507 range 0x0000-0x1fff
+pureReadRom :: Word16 -> MonadAtari Word8
+pureReadRom addr = withMemory addr $ \m _ bankedAddress -> liftIO $ readArray m bankedAddress
 
 -- {-# INLINE pureWriteRom #-}
 -- | pureWriteRom sees address in full 6507 range 0x0000-0x1fff
 -- You can write to Super Chip "ROM"
 pureWriteRom :: Word16 -> Word8 -> MonadAtari ()
-pureWriteRom addr v = do
-    atari <- ask
-    let m = atari ^. rom
-    let bankStateRef = atari ^. bankState
-    bankState' <- liftIO $ readIORef bankStateRef
-    when (bankWritable bankState' addr) $ do
-        let bankedAddress = bankAddress bankState' addr
-        liftIO $ writeArray m bankedAddress v
+pureWriteRom addr v = withMemory addr $ \m bankState' bankedAddress -> when (bankWritable bankState' addr) $ liftIO $ writeArray m bankedAddress v
 
 -- {-# INLINE pureReadMemory #-}
 -- | pureReadMemory expects an address in range 0x0000-0x1fff
@@ -1084,7 +1061,7 @@ writeStella addr v = do
        0x11 -> (pcStep @-> pcResp1) >> hpos @-> ppos1 -- RESP1
        0x12 -> (pcStep @-> pcResm0) >> hpos @-> mpos0 -- RESM0
        0x13 -> (pcStep @-> pcResm1) >> hpos @-> mpos1 -- RESM1
-       0x14 -> (pcStep @-> pcResbl) >> load hpos >>= (return . max (picx+2)) >>= (bpos @=)  -- RESBL
+       0x14 -> (max (picx + 2) <$> ((pcStep @-> pcResbl) >> load hpos)) >>= (bpos @=)  -- RESBL
        0x15 -> return () -- liftIO $ putStrLn $ "AUDC0 = " ++ showHex v ""
        0x16 -> return () -- liftIO $ putStrLn $ "AUDC1 = " ++ showHex v ""
        0x17 -> return () -- liftIO $ putStrLn $ "AUDF0 = " ++ showHex v ""

src/Keys.hs

@@ -307,7 +307,7 @@ type AtariKeys = M.Map Key AtariKey
 
 keysFromOptions :: Options -> Maybe AtariKeys
 keysFromOptions options = do
-    scancodes <- mapM (sequence . map scancodeFromString) [
+    scancodes <- mapM (mapM scancodeFromString) [
                     joystick1Left options,
                     joystick1Right options,
                     joystick1Up options,

src/Memory.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 
 module Memory(MemoryType(..),

src/VideoOps.hs

@@ -181,7 +181,7 @@ clampMissiles resmp0' resmp1' = do
     when (testBit resmp1' 1) $ ppos1 @-> mpos1
 
 -- Atari2600 programmer's guide p.22
-{- INLINE missile0 -}
+{-# INLINE missile #-}
 missile :: Word8 -> Word8 -> Int -> Word8 -> Bool
 missile _       _      o _       | o < 0                  = False
 missile _       _      _ resmp0' | testBit resmp0' 1      = False
@@ -220,7 +220,7 @@ ball delayBall' oldBall' newBall' ctrlpf' o = do
 
 
 missileSize :: Word8 -> Int
-missileSize nusiz = 1 `shift` (fromIntegral ((nusiz `shift` (-4)) .&. 0b11))
+missileSize nusiz = 1 `shift` fromIntegral ((nusiz `shift` (-4)) .&. 0b11)
 
 data Sprite = COLUBK | COLUB | COLUPF | COLUP0 | COLUP1 | COLUM0 | COLUM1 deriving (Eq, Show)
 
@@ -301,7 +301,7 @@ wrap160' :: Int -> Int
 wrap160' x' | x' < 0 = x'+160
 wrap160' x' = x'
 
-{- INLINE compositeAndCollide -}
+{-# INLINE compositeAndCollide #-}
 compositeAndCollide :: Int -> Int -> MonadAtari Word8
 compositeAndCollide pixelx hpos' = do
     ppos0' <- load ppos0
@@ -342,21 +342,9 @@ compositeAndCollide pixelx hpos' = do
                                 lmissile0 lmissile1
                                 lplayer0 lplayer1 pixelx
     debugColours' <- load debugColours
-    z <- if debugColours'
-            then return $ debugColour sprite
-            else load $ spriteColour sprite
-
-    vpos' <- load vpos
-    if vpos' == 174 && hpos' == 175
-    then do
-        return z
-    {-
-        liftIO $ print $ "lball = " ++ show lball
-        liftIO $ print $ "scoreMode = " ++ show scoreMode
-        liftIO $ print $ "z=" ++ show z
-        return 0xff
-        -}
-    else return z
+    if debugColours'
+       then return $ debugColour sprite
+       else load $ spriteColour sprite
 
 {-# INLINE stellaTick #-}
 stellaTick :: Int -> Ptr Word8 -> MonadAtari ()

stack.yaml

@@ -1,7 +1,7 @@
 flags: {}
 extra-package-dbs: []
-extra-lib-dirs:
-- /usr/lib
+#extra-lib-dirs:
+#- /usr/lib
 packages:
 - .
 extra-deps: