├── INSTALL ├── guis ├── test03 │ ├── test03.gladep │ └── test03.glade ├── test01 │ └── test01.gladep └── test02 │ ├── test02.gladep │ └── test02.glade ├── roms └── README ├── src ├── Main.hs ├── Display.hs ├── Prerequisites.hs ├── WordUtil.hs ├── Joypad.hs ├── GuiDrawUtil.hs ├── AsciiTest01.hs ├── AsciiTest02.hs ├── CpuExecution.hs ├── TestRoms.hs ├── Tests.hs ├── RomImage.hs ├── MachineStateIO.hs ├── GuiTest02.hs ├── GuiTest03.hs ├── MachineIO.hs ├── Memory.hs ├── GuiTests.hs ├── Machine.hs └── CpuIO.hs ├── README └── COPYING /INSTALL: -------------------------------------------------------------------------------- 1 | Please see README for more information. 2 | 3 | For now just run: 4 | 5 | cd src 6 | ghc -O --make Main 7 | 8 | 9 | Make sure to compile with optimization, otherwise it runs horribly slow! 10 | 11 | -------------------------------------------------------------------------------- /guis/test03/test03.gladep: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | FALSE 8 | 9 | -------------------------------------------------------------------------------- /guis/test01/test01.gladep: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | test01 6 | test01 7 | FALSE 8 | 9 | -------------------------------------------------------------------------------- /guis/test02/test02.gladep: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | test02 6 | test02 7 | FALSE 8 | 9 | -------------------------------------------------------------------------------- /roms/README: -------------------------------------------------------------------------------- 1 | It would be cool if we could find Game Boy ROMS that we could put in here and 2 | distribute along with OmegaGB. Maybe even a demo developed especially for 3 | showing off OmegaGB :) 4 | 5 | For now you might take a look at this page which has some free ROMS available 6 | for download: 7 | 8 | http://www.zophar.net/roms.phtml?op=show&type=gb 9 | 10 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | -- OmegaGB Copyright 2007 Bit Connor 2 | -- This program is distributed under the terms of the GNU General Public License 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Cpu 6 | -- Copyright : (c) Bit Connor 2007 7 | -- License : GPL 8 | -- Maintainer : bit@mutantlemon.com 9 | -- Stability : in-progress 10 | -- 11 | -- OmegaGB 12 | -- Game Boy Emulator 13 | -- 14 | -- This module does emulation of the Game Boy's Z80 like CPU. 15 | -- A few instructions still need to be implemented 16 | -- 17 | ----------------------------------------------------------------------------- 18 | 19 | module Main where 20 | 21 | -- These are the modules that have different test programs: 22 | 23 | --import AsciiTest01 -- test01 24 | --import AsciiTest02 -- test02 25 | --import GuiTests -- test 01 26 | import GuiTest02 -- test02 27 | --import GuiTest03 -- test03 28 | 29 | main = test02 30 | 31 | -------------------------------------------------------------------------------- /src/Display.hs: -------------------------------------------------------------------------------- 1 | -- OmegaGB Copyright 2007 Bit Connor 2 | -- This program is distributed under the terms of the GNU General Public License 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Display 6 | -- Copyright : (c) Bit Connor 2007 7 | -- License : GPL 8 | -- Maintainer : bit@mutantlemon.com 9 | -- Stability : in-progress 10 | -- 11 | -- OmegaGB 12 | -- Game Boy Emulator 13 | -- 14 | -- This module defines the Display type that represents the Game Boy's LCD 15 | -- display. The Game Boy LCD display has a resolution of 144x160 and 4 16 | -- colors, 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module Display where 21 | 22 | import Data.Array.Unboxed 23 | import Data.Word 24 | 25 | type Display = UArray (Int, Int) Word8 26 | 27 | blankDisplay :: Display 28 | blankDisplay = array ((0, 0), (143, 159)) (map (\i -> (i, 0)) (range ((0, 0), (143, 159)))) 29 | 30 | -------------------------------------------------------------------------------- /src/Prerequisites.hs: -------------------------------------------------------------------------------- 1 | -- OmegaGB Copyright 2007 Bit Connor 2 | -- This program is distributed under the terms of the GNU General Public License 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Prerequisites 6 | -- Copyright : (c) Bit Connor 2007 7 | -- License : GPL 8 | -- Maintainer : bit@mutantlemon.com 9 | -- Stability : in-progress 10 | -- 11 | -- OmegaGB 12 | -- Game Boy Emulator 13 | -- 14 | -- This module should be imported from all other modules 15 | -- 16 | ----------------------------------------------------------------------------- 17 | module Prerequisites where 18 | 19 | import Debug.Trace 20 | import Data.Array.IArray 21 | 22 | {- 23 | 24 | (!) :: (Show i, IArray a e, Ix i) => 25 | a i e -> i -> e 26 | a ! i = let (lowerBound, upperBound) = bounds a in 27 | if i >= lowerBound && i <= upperBound 28 | then a Data.Array.IArray.! i 29 | else error ("Read out of bounds (" ++ show lowerBound ++ ", " ++ show upperBound ++ "), index = " ++ show i) 30 | 31 | (//) :: (Show i, Show e, IArray a e, Ix i) => 32 | a i e -> [(i, e)] -> a i e 33 | a // l = let (lowerBound, upperBound) = bounds a in 34 | if all ( \(i, _) -> i >= lowerBound && i <= upperBound ) l 35 | then a Data.Array.IArray.// l 36 | else error ("Write out of bounds (" ++ show lowerBound ++ ", " ++ show upperBound ++ "), " ++ show l) 37 | 38 | -} 39 | 40 | -------------------------------------------------------------------------------- /src/WordUtil.hs: -------------------------------------------------------------------------------- 1 | -- OmegaGB Copyright 2007 Bit Connor 2 | -- This program is distributed under the terms of the GNU General Public License 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : WordUtil 6 | -- Copyright : (c) Bit Connor 2007 7 | -- License : GPL 8 | -- Maintainer : bit@mutantlemon.com 9 | -- Stability : in-progress 10 | -- 11 | -- OmegaGB 12 | -- Game Boy Emulator 13 | -- 14 | -- Utility Functions for dealing with 8 bit and 16 bit values. 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | module WordUtil where 19 | 20 | import Data.Char 21 | import Data.Word 22 | import Data.Bits 23 | import qualified Numeric as N 24 | 25 | joinWord16 :: Word8 -> Word8 -> Word16 26 | joinWord16 hi lo = 27 | ((fromIntegral lo)::Word16) + (shiftL ((fromIntegral hi)::Word16) 8) 28 | 29 | splitWord16 :: Word16 -> (Word8, Word8) 30 | splitWord16 nn = 31 | let hi = fromIntegral (shiftR nn 8) 32 | lo = fromIntegral nn in 33 | (hi, lo) 34 | 35 | showHex n = '$' : (N.showHex n "") 36 | 37 | showHex1 :: Word8 -> String 38 | showHex1 n = 39 | let s = map toUpper (N.showHex n "") in 40 | if n > 0xF then s else '0' : s 41 | 42 | showHex2 :: Word16 -> String 43 | showHex2 n = 44 | let s = map toUpper (N.showHex n "") in 45 | if n > 0xF 46 | then (if n > 0xFF 47 | then (if n > 0xFFF 48 | then s 49 | else '0' : s) 50 | else "00" ++ s) 51 | else "000" ++ s 52 | 53 | -------------------------------------------------------------------------------- /src/Joypad.hs: -------------------------------------------------------------------------------- 1 | -- OmegaGB Copyright 2007 Bit Connor 2 | -- This program is distributed under the terms of the GNU General Public License 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Joypad 6 | -- Copyright : (c) Bit Connor 2007 7 | -- License : GPL 8 | -- Maintainer : bit@mutantlemon.com 9 | -- Stability : in-progress 10 | -- 11 | -- OmegaGB 12 | -- Game Boy Emulator 13 | -- 14 | -- This module defines the type for the Game Boy joypad, which is basiclly a 15 | -- collection of push buttons. 16 | -- 17 | ----------------------------------------------------------------------------- 18 | 19 | module Joypad where 20 | 21 | type JoypadKeyStates = (Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool) 22 | 23 | --initJoypadKeyStates :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> JoypadKeyStates 24 | initJoypadKeyStates right left up down a b select start = 25 | (right, left, up, down, a, b, select, start) 26 | 27 | getJoypadKeyStateRight jp = let (v, _, _, _, _, _, _, _) = jp in v 28 | getJoypadKeyStateLeft jp = let (_, v, _, _, _, _, _, _) = jp in v 29 | getJoypadKeyStateUp jp = let (_, _, v, _, _, _, _, _) = jp in v 30 | getJoypadKeyStateDown jp = let (_, _, _, v, _, _, _, _) = jp in v 31 | getJoypadKeyStateA jp = let (_, _, _, _, v, _, _, _) = jp in v 32 | getJoypadKeyStateB jp = let (_, _, _, _, _, v, _, _) = jp in v 33 | getJoypadKeyStateSelect jp = let (_, _, _, _, _, _, v, _) = jp in v 34 | getJoypadKeyStateStart jp = let (_, _, _, _, _, _, _, v) = jp in v 35 | 36 | -------------------------------------------------------------------------------- /src/GuiDrawUtil.hs: -------------------------------------------------------------------------------- 1 | -- OmegaGB Copyright 2007 Bit Connor 2 | -- This program is distributed under the terms of the GNU General Public License 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : GuiDrawUtil 6 | -- Copyright : (c) Bit Connor 2007 7 | -- License : GPL 8 | -- Maintainer : bit@mutantlemon.com 9 | -- Stability : in-progress 10 | -- 11 | -- OmegaGB 12 | -- Game Boy Emulator 13 | -- 14 | -- Code for updating a gtk+ canvas 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | module GuiDrawUtil where 19 | 20 | -- Code shamelessly taken from gtk2hs fastdraw demo 21 | 22 | import Graphics.UI.Gtk 23 | 24 | updateCanvas :: DrawingArea -> Pixbuf -> Event -> IO Bool 25 | updateCanvas canvas pb Expose { eventRegion = region } = do 26 | win <- drawingAreaGetDrawWindow canvas 27 | gc <- gcNew win 28 | width <- pixbufGetWidth pb 29 | height <- pixbufGetHeight pb 30 | pbregion <- regionRectangle (Rectangle 0 0 width height) 31 | regionIntersect region pbregion 32 | rects <- regionGetRectangles region 33 | -- putStrLn ("redrawing: "++show rects) 34 | (flip mapM_) rects $ \(Rectangle x y w h) -> do 35 | drawPixbuf win gc pb x y x y w h RgbDitherNone 0 0 36 | return True 37 | 38 | {-# INLINE doFromTo #-} 39 | -- do the action for [from..to], ie it's inclusive. 40 | doFromTo :: Int -> Int -> (Int -> IO ()) -> IO () 41 | doFromTo from to action = 42 | let loop n | n > to = return () 43 | | otherwise = do action n 44 | loop (n+1) 45 | in loop from 46 | 47 | -------------------------------------------------------------------------------- /src/AsciiTest01.hs: -------------------------------------------------------------------------------- 1 | -- OmegaGB Copyright 2007 Bit Connor 2 | -- This program is distributed under the terms of the GNU General Public License 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : AsciiTest01 6 | -- Copyright : (c) Bit Connor 2007 7 | -- License : GPL 8 | -- Maintainer : bit@mutantlemon.com 9 | -- Stability : in-progress 10 | -- 11 | -- OmegaGB 12 | -- Game Boy Emulator 13 | -- 14 | -- This module executes a ROM and does some ascii art output 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | module AsciiTest01 where 19 | import Prerequisites 20 | 21 | import Data.Char 22 | import Data.Array.IArray --hiding ((!), (//)) 23 | 24 | import RomImage 25 | import Machine 26 | import Joypad 27 | 28 | romFile = "roms/Catrap (U) [!].gb" 29 | 30 | test01 :: IO () 31 | test01 = do 32 | romImage <- loadRomImage romFile 33 | let initialState = initialMachineState romImage 34 | 35 | let iter f x = let (r, x') = f x in 36 | r : iter f x' 37 | 38 | let l = iter (updateMachineDisplayFrame (initJoypadKeyStates False False False False False False False False)) initialState 39 | 40 | let clear = putStr ((chr 27) : "[H") 41 | 42 | let pixel c = case c of 43 | 0 -> " " 44 | 1 -> "~" 45 | 2 -> "=" 46 | 3 -> "@" 47 | 48 | let printRow d y = let s = concatMap (\x -> (pixel (d!(y, x)))) [0..159] in putStrLn s 49 | 50 | let printRows d = {- clear >> -} mapM_ (\y -> printRow d y) [0..138] 51 | 52 | mapM_ (\d -> printRows d) (take 200 l) 53 | 54 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | OmegaGB 2 | Nintendo Game Boy Emulator 3 | By Bit Connor 4 | 5 | === Requirements: 6 | 7 | - ghc 6.6 8 | - gtk2hs (with glade support) 0.9.11 9 | These are the versions I am using. Other versions should probably also work 10 | fine. 11 | If you don't have gtk2hs then you can still run the Ascii tests, which do 12 | ascii art rendering to your terminal. 13 | 14 | === About 15 | 16 | This is still in a very rough state. The priority right now is to optimize 17 | the code so that it will run in real time. Right now it runs at about 18 | 10% of real time speed on my workstation. 19 | 20 | There are still lots of pieces missing for full emulation: 21 | 22 | - CPU emulation is almost complete, but it may be buggy 23 | - The memory bus still needs a bit of work. Currently there is no support 24 | for any of the GB memory banks, so only 32K ROMS have a chance at running. 25 | Also missing are a bunch of the various GB registers. 26 | - Only a few of the GB interrupts have been implemented. 27 | - The only part of the graphics hardware that is emulated so far is 28 | rendering of the background map. 29 | - No sound emulation. 30 | - No link cable emulation. 31 | 32 | What all this means is that OmegaGB is capable of showing the title screens 33 | of a few games, but not much more. 34 | 35 | The goal is to get OmegaGB to a state where it can properly emulate most 36 | games. If you don't have a way to dump your game cartdriges to a rom file 37 | (and don't want to download), then you can get some free (legal) roms at 38 | this website: 39 | 40 | http://www.zophar.net/roms.phtml?op=show&type=gb 41 | 42 | I've found that SPACE.GB from the "Diagnostics Rom", by an unknown author 43 | works well. Also, the title screen shows for "Sokoban", by Obsession 44 | Development. 45 | 46 | -------------------------------------------------------------------------------- /src/AsciiTest02.hs: -------------------------------------------------------------------------------- 1 | -- OmegaGB Copyright 2007 Bit Connor 2 | -- This program is distributed under the terms of the GNU General Public License 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : AsciiTest02 6 | -- Copyright : (c) Bit Connor 2007 7 | -- License : GPL 8 | -- Maintainer : bit@mutantlemon.com 9 | -- Stability : in-progress 10 | -- 11 | -- OmegaGB 12 | -- Game Boy Emulator 13 | -- 14 | -- This module executes a ROM and does some ascii art output. To use this, 15 | -- run it in a terminal with a really tiny font. 16 | -- 17 | ----------------------------------------------------------------------------- 18 | 19 | module AsciiTest02 where 20 | import Prerequisites 21 | 22 | import Data.Char 23 | import Data.Array.IArray 24 | import Data.Array.MArray 25 | import Control.Monad 26 | 27 | import RomImage 28 | import MachineIO 29 | import MachineStateIO 30 | import Joypad 31 | 32 | romFile = "roms/Dropzone (U) (GB).gb" 33 | 34 | test02 :: IO () 35 | test02 = do 36 | romImage <- loadRomImage romFile 37 | 38 | machineState <- initMachineStateIO romImage 39 | 40 | let clear = putStr ((chr 27) : "[H") 41 | 42 | let pixel c = case c of 43 | 0 -> ' ' 44 | 1 -> '~' 45 | 2 -> '=' 46 | 3 -> '@' 47 | 48 | let printRow :: ScanLine -> IO () 49 | printRow scanline = mapM_ ( \x -> readArray scanline x >>= ( \c -> putChar (pixel c) ) ) [0..159] 50 | >> putChar '\n' 51 | 52 | --let s = concatMap ( \x -> (pixel (d!(y, x))) ) [0..159] in putStrLn s 53 | 54 | let printRows :: Array Int ScanLine -> IO () 55 | printRows d = clear >> mapM_ ( \y -> printRow (d!y) ) [0..138] 56 | 57 | replicateM_ 5000 ((updateMachineDisplayFrameIO machineState) >> printRows (msDisplay machineState)) 58 | 59 | -------------------------------------------------------------------------------- /src/CpuExecution.hs: -------------------------------------------------------------------------------- 1 | -- OmegaGB Copyright 2007 Bit Connor 2 | -- This program is distributed under the terms of the GNU General Public License 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : CpuExecution 6 | -- Copyright : (c) Bit Connor 2007 7 | -- License : GPL 8 | -- Maintainer : bit@mutantlemon.com 9 | -- Stability : in-progress 10 | -- 11 | -- OmegaGB 12 | -- Game Boy Emulator 13 | -- 14 | -- This module defines an abstract syntax tree CPU execution monad 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | {-# OPTIONS -fglasgow-exts #-} 19 | 20 | module CpuExecution where 21 | 22 | import Data.Word 23 | import Data.Bits 24 | 25 | data M_Register = 26 | M_A | 27 | M_B | 28 | M_C | 29 | M_D | 30 | M_E | 31 | M_F | 32 | M_H | 33 | M_L 34 | 35 | data M_Register2 = 36 | M_AF | 37 | M_BC | 38 | M_DE | 39 | M_HL | 40 | M_PC | 41 | M_SP 42 | 43 | data ExecutionAST result where 44 | Return :: result -> ExecutionAST result 45 | Bind :: (ExecutionAST oldres) -> (oldres -> ExecutionAST result) -> 46 | ExecutionAST result 47 | WriteRegister :: M_Register -> Word8 -> ExecutionAST () 48 | ReadRegister :: M_Register -> ExecutionAST Word8 49 | WriteRegister2 :: M_Register2 -> Word16 -> ExecutionAST () 50 | ReadRegister2 :: M_Register2 -> ExecutionAST Word16 51 | WriteMemory :: Word16 -> Word8 -> ExecutionAST () 52 | ReadMemory :: Word16 -> ExecutionAST Word8 53 | instance Monad ExecutionAST where 54 | return = Return 55 | (>>=) = Bind 56 | 57 | writeRegister = WriteRegister 58 | readRegister = ReadRegister 59 | writeRegister2 = WriteRegister2 60 | readRegister2 = ReadRegister2 61 | writeMemory = WriteMemory 62 | readMemory = ReadMemory 63 | 64 | writeFlags :: Maybe Bool -> 65 | Maybe Bool -> 66 | Maybe Bool -> 67 | Maybe Bool -> 68 | ExecutionAST () 69 | writeFlags z n h c = do 70 | v0 <- readRegister M_F 71 | let v1 = case z of 72 | Nothing -> v0 73 | Just True -> setBit v0 7 74 | Just False -> clearBit v0 7 75 | let v2 = case n of 76 | Nothing -> v1 77 | Just True -> setBit v1 6 78 | Just False -> clearBit v1 6 79 | let v3 = case h of 80 | Nothing -> v2 81 | Just True -> setBit v2 5 82 | Just False -> clearBit v2 5 83 | let v4 = case c of 84 | Nothing -> v3 85 | Just True -> setBit v3 4 86 | Just False -> clearBit v3 4 87 | writeRegister M_F v4 88 | 89 | -------------------------------------------------------------------------------- /src/TestRoms.hs: -------------------------------------------------------------------------------- 1 | -- OmegaGB Copyright 2007 Bit Connor 2 | -- This program is distributed under the terms of the GNU General Public License 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : TestRoms 6 | -- Copyright : (c) Bit Connor 2007 7 | -- License : GPL 8 | -- Maintainer : bit@mutantlemon.com 9 | -- Stability : in-progress 10 | -- 11 | -- OmegaGB 12 | -- Game Boy Emulator 13 | -- 14 | -- This module generates some ROM images that can be used for testing 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | module TestRoms where 19 | 20 | import Data.Array.IO 21 | import Data.Array.MArray 22 | import Data.Word 23 | import System.IO 24 | 25 | import CpuExecution 26 | import RomImage 27 | import Machine 28 | 29 | -- Creates a rom file that does incrementing and decrementing of the 30 | -- A register 31 | createTestRom01 :: FilePath -> IO () 32 | createTestRom01 file = do 33 | rom <- newArray (0, 0x7FFF) 0x00 :: IO (IOUArray Int Word8) 34 | writeArray rom 0x100 0x00 -- NOP 35 | writeArray rom 0x101 0xC3 -- JP 0x0150 36 | writeArray rom 0x102 0x50 -- 37 | writeArray rom 0x103 0x01 -- 38 | let nintendoGraphic = [ 39 | 0xCE, 0xED, 0x66, 0x66, 0xCC, 0x0D, 0x00, 0x0B, 0x03, 0x73, 0x00, 40 | 0x83, 0x00, 0x0C, 0x00, 0x0D, 0x00, 0x08, 0x11, 0x1F, 0x88, 0x89, 41 | 0x00, 0x0E, 0xDC, 0xCC, 0x6E, 0xE6, 0xDD, 0xDD, 0xD9, 0x99, 0xBB, 42 | 0xBB, 0x67, 0x63, 0x6E, 0x0E, 0xEC, 0xCC, 0xDD, 0xDC, 0x99, 0x9F, 43 | 0xBB, 0xB9, 0x33, 0x3E] 44 | mapM_ (\(i, e) -> writeArray rom i e) (zip [0x104..] nintendoGraphic) 45 | let title = map (fromIntegral . fromEnum) "OMEGAGBTEST01" 46 | mapM_ (\(i, e) -> writeArray rom i e) (zip [0x134..] title) 47 | -- TODO write header checksum 48 | 49 | -- now the actual program, starting at 0x150 50 | writeArray rom 0x150 0x3E -- LD A 0x00 51 | writeArray rom 0x151 0x00 52 | -- write alternating INC A (0x3C) / DEC A (0x3D) instructions 53 | mapM_ (\i -> writeArray rom i (if i `mod` 3 == 0 then 0x3C else 0x3D)) [0x152..0x7FFC] 54 | 55 | -- write a jump back to 0x150 56 | writeArray rom 0x7FFD 0xC3 -- JP 0x0150 57 | writeArray rom 0x7FFE 0x50 58 | writeArray rom 0x7FFF 0x01 59 | 60 | -- write the file 61 | fp <- openBinaryFile file WriteMode 62 | hPutArray fp rom 0x8000 63 | hClose fp 64 | 65 | return () 66 | 67 | runTestRom01 :: FilePath -> IO () 68 | runTestRom01 file = do 69 | rom <- loadRomImage file 70 | let machine = initialMachineState rom 71 | putStrLn "" 72 | putStrLn "Running 10,000 instructions" 73 | let ((registers, _), _) = (iterate updateMachine machine) !! 10000 74 | putStr "Value of A register (Should be 251): " 75 | putStrLn (show (getRegState registers M_A)) 76 | 77 | return () 78 | 79 | -------------------------------------------------------------------------------- /src/Tests.hs: -------------------------------------------------------------------------------- 1 | -- OmegaGB Copyright 2007 Bit Connor 2 | -- This program is distributed under the terms of the GNU General Public License 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Tests 6 | -- Copyright : (c) Bit Connor 2007 7 | -- License : GPL 8 | -- Maintainer : bit@mutantlemon.com 9 | -- Stability : in-progress 10 | -- 11 | -- OmegaGB 12 | -- Game Boy Emulator 13 | -- 14 | -- Some really basic tests. From the early life of the project. 15 | -- Not really useful anymore 16 | -- 17 | ----------------------------------------------------------------------------- 18 | 19 | module Tests where 20 | 21 | import Data.Array.IArray 22 | import Data.Word 23 | 24 | import Machine 25 | import Cpu 26 | import CpuExecution 27 | import RomImage 28 | import Memory 29 | import WordUtil 30 | 31 | cpuTest :: Int -> Bool 32 | 33 | type ReallySimpleMemory = Array Word16 Word8 34 | 35 | instance MemoryModel ReallySimpleMemory where 36 | readMem = readReallySimpleMemory 37 | writeMem = writeReallySimpleMemory 38 | 39 | initialReallySimpleMemoryMachineState = 40 | (initialRegisterStates, zeroReallySimpleMemory) 41 | 42 | zeroReallySimpleMemory :: ReallySimpleMemory 43 | zeroReallySimpleMemory = listArray (0x0000, 0xFFFF) (replicate (0xFFFF+1) 0x00) 44 | 45 | readReallySimpleMemory :: ReallySimpleMemory -> Word16 -> Word8 46 | readReallySimpleMemory m a = m!a 47 | 48 | writeReallySimpleMemory :: ReallySimpleMemory -> Word16 -> Word8 -> ReallySimpleMemory 49 | writeReallySimpleMemory m a v = m//[(a, v)] 50 | 51 | -- LD A,1 52 | -- LD (0),A 53 | cpuTest 1 = 54 | let s0 = initialReallySimpleMemoryMachineState 55 | s1 = machineCpuExecute s0 (executeInstruction (LDRN A 0x9B)) 56 | s2 = machineCpuExecute s1 (executeInstruction (LDPN 0x0000)) 57 | (_, mem) = s2 58 | m0 = readReallySimpleMemory mem 0x0000 in 59 | m0 == 0x9B 60 | 61 | -- LD BC,0xFAEB 62 | -- PUSH BC 63 | -- POP AF 64 | -- LD (0),A 65 | cpuTest 2 = 66 | let s0 = initialReallySimpleMemoryMachineState 67 | s1 = machineCpuExecute s0 (executeInstruction (LD2 BC 0xFAEB)) 68 | s2 = machineCpuExecute s1 (executeInstruction (PUSH StackRegBC)) 69 | s3 = machineCpuExecute s2 (executeInstruction (POP StackRegAF)) 70 | s4 = machineCpuExecute s3 (executeInstruction (LDPN 0)) 71 | (_, mem) = s4 72 | m0 = readReallySimpleMemory mem 0 in 73 | m0 == 0xFA 74 | 75 | -- LD SP,0x0002 76 | -- LD BC,0xFAEB 77 | -- PUSH BC 78 | cpuTest 3 = 79 | let s0 = initialReallySimpleMemoryMachineState 80 | s1 = machineCpuExecute s0 (executeInstruction (LD2 SP 0x0002)) 81 | s2 = machineCpuExecute s1 (executeInstruction (LD2 BC 0xFAEB)) 82 | s3 = machineCpuExecute s2 (executeInstruction (PUSH StackRegBC)) 83 | (_, mem) = s3 84 | m0 = readReallySimpleMemory mem 0x0000 85 | m1 = readReallySimpleMemory mem 0x0001 in 86 | (m0 == 0xEB) && (m1 == 0xFA) 87 | 88 | -- LD BC 0xFA45 89 | cpuTest 4 = 90 | let s0 = initialReallySimpleMemoryMachineState 91 | s1 = machineCpuExecute s0 (executeInstruction (LD2 BC 0xFA45)) 92 | (regs, _) = s1 93 | b = getRegState regs M_B in 94 | b == 0xFA 95 | 96 | romFile = "roms/Loopz (U).gb" 97 | 98 | fetchPC :: (MemoryModel m) => (RegisterStates, m) -> Word16 99 | fetchPC (regS, _) = getReg2State regS M_PC 100 | 101 | fetchA :: (MemoryModel m) => (RegisterStates, m) -> Word8 102 | fetchA (regS, _) = getRegState regS M_A 103 | 104 | romExecutionTest :: Int -> IO () 105 | romExecutionTest 1 = do 106 | romImage <- loadRomImage romFile 107 | let l = iterate updateMachine ((initialRegisterStates, initMemory romImage), 108 | initialIrqStates) 109 | let dis = map (\s -> 110 | (showHex (fetchPC s)) ++ " " ++ (show (fetchInstruction s)) ++ " " ++ (showHex (fetchA s)) 111 | ) (map fst l) 112 | mapM_ (\s -> putStr s >> wait) dis 113 | 114 | where wait = putStrLn "" --getChar 115 | 116 | -------------------------------------------------------------------------------- /src/RomImage.hs: -------------------------------------------------------------------------------- 1 | -- OmegaGB Copyright 2007 Bit Connor 2 | -- This program is distributed under the terms of the GNU General Public License 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : RomImage 6 | -- Copyright : (c) Bit Connor 2007 7 | -- License : GPL 8 | -- Maintainer : bit@mutantlemon.com 9 | -- Stability : in-progress 10 | -- 11 | -- OmegaGB 12 | -- Game Boy Emulator 13 | -- 14 | -- This module defines the type for a ROM image: the contents of a dumped 15 | -- Game Boy game cartdrige. 16 | -- 17 | ----------------------------------------------------------------------------- 18 | 19 | module RomImage where 20 | 21 | import System.Posix.Files (getFileStatus, fileSize) 22 | import System.IO 23 | import Control.Monad (when) 24 | import Control.Exception (bracket) 25 | import Data.Array.Unboxed 26 | import Data.Word 27 | import Data.Char (chr) 28 | import Foreign.Marshal.Alloc (mallocBytes, free) 29 | import Foreign.Storable (peekElemOff) 30 | 31 | type RomImage = UArray Int Word8 32 | 33 | readRomImageByte :: RomImage -> Int -> Word8 34 | readRomImageByte ri a = ri!a 35 | 36 | loadRomImage :: FilePath -> IO RomImage 37 | loadRomImage file = do 38 | fileStatus <- getFileStatus file 39 | let size = fromIntegral (fileSize fileStatus) 40 | 41 | a <- bracket 42 | (openBinaryFile file ReadMode) 43 | (hClose) 44 | (\handle -> do 45 | bracket 46 | (mallocBytes size) 47 | (free) 48 | (\buf -> do 49 | numBytesRead <- hGetBuf handle buf size 50 | when (numBytesRead /= size) (error "TODO error") 51 | let readIndex :: Int -> IO (Int, Word8) 52 | readIndex i = do 53 | v <- peekElemOff buf (fromIntegral i) 54 | return (i, v) 55 | 56 | resultList <- mapM readIndex [0..(size-1)] 57 | 58 | let result :: RomImage 59 | result = array (0, size-1) resultList 60 | 61 | return result 62 | ) 63 | ) 64 | 65 | putStrLn "RomImage Loaded Succesfully:" 66 | putStrLn file 67 | putStrLn $ "Title: " ++ (map (\i -> chr (fromIntegral (a!i))) 68 | [0x0134..0x0142]) 69 | putStrLn $ "Cartridge type: " ++ case a!0x0147 of 70 | 0x00 -> "ROM ONLY" 71 | 0x01 -> "ROM+MBC1" 72 | 0x02 -> "ROM+MBC1+RAM" 73 | 0x03 -> "ROM+MBC1+RAM+BATT" 74 | 0x05 -> "ROM+MBC2" 75 | 0x06 -> "ROM+MBC2+BATTERY" 76 | 0x08 -> "ROM+RAM" 77 | 0x09 -> "ROM+RAM+BATTERY" 78 | 0x0B -> "ROM+MMM01" 79 | 0x0C -> "ROM+MMM01+SRAM" 80 | 0x0D -> "ROM+MMM01+SRAM+BATT" 81 | 0x0F -> "ROM+MBC3+TIMER+BATT" 82 | 0x10 -> "ROM+MBC3+TIMER+RAM+BATT" 83 | 0x11 -> "ROM+MBC3" 84 | 0x12 -> "ROM+MBC3+RAM" 85 | 0x13 -> "ROM+MBC3+RAM+BATT" 86 | 0x19 -> "ROM+MBC5" 87 | 0x1A -> "ROM+MBC5+RAM" 88 | 0x1B -> "ROM+MBC5+RAM+BATT" 89 | 0x1C -> "ROM+MBC5+RUMBLE" 90 | 0x1D -> "ROM+MBC5+RUMBLE+SRAM" 91 | 0x1E -> "ROM+MBC5+RUMBLE+SRAM+BATT" 92 | 0x1F -> "Pocket Camera" 93 | 0xFD -> "Bandai TAMA5" 94 | 0xFE -> "Hudson HuC-3" 95 | 0xFF -> "Hudson HuC-1" 96 | _ -> "INVALID OR UKNOWN" 97 | putStrLn $ "ROM Size: " ++ case a!0x0148 of 98 | 0x00 -> "256Kbit = 32KByte = 2 banks" 99 | 0x01 -> "512Kbit = 64KByte = 4 banks" 100 | 0x02 -> "1Mbit = 128KByte = 8 banks" 101 | 0x03 -> "2Mbit = 256KByte = 16 banks" 102 | 0x04 -> "4Mbit = 512KByte = 32 banks" 103 | 0x05 -> "8Mbit = 1MByte = 64 banks" 104 | 0x06 -> "16Mbit = 2MByte = 128 banks" 105 | 0x52 -> "9Mbit = 1.1MByte = 72 banks" 106 | 0x53 -> "10Mbit = 1.2MByte = 80 banks" 107 | 0x54 -> "12Mbit = 1.5MByte = 96 banks" 108 | _ -> "INVALID OR UKNOWN" 109 | putStrLn $ "RAM Size: " ++ case a!0x0149 of 110 | 0x00 -> "None" 111 | 0x01 -> "16kBit = 2kB = 1 bank" 112 | 0x02 -> "64kBit = 8kB = 1 bank" 113 | 0x03 -> "256kBit = 32kB = 4 banks" 114 | 0x04 -> "1MBit = 128kB = 16 banks" 115 | _ -> "INVALID OR UKNOWN" 116 | putStrLn $ "Destination code: " ++ case a!0x014A of 117 | 0x00 -> "Japanese" 118 | 0x01 -> "Non-Japanese" 119 | _ -> "INVALID OR UKNOWN" 120 | putStrLn $ "Licensee code: " ++ case a!0x014B of 121 | 0x79 -> "Accolade" 122 | 0xA4 -> "Konami" 123 | 0x33 -> [chr (fromIntegral (a!0x0144)), chr (fromIntegral (a!0x0145))] 124 | _ -> "INVALID OR UNKOWN" 125 | putStrLn $ "Mask ROM Version number: " ++ (show (a!0x014C)) 126 | 127 | return a 128 | 129 | -------------------------------------------------------------------------------- /src/MachineStateIO.hs: -------------------------------------------------------------------------------- 1 | -- OmegaGB Copyright 2007 Bit Connor 2 | -- This program is distributed under the terms of the GNU General Public License 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : MachineStateIO 6 | -- Copyright : (c) Bit Connor 2007 7 | -- License : GPL 8 | -- Maintainer : bit@mutantlemon.com 9 | -- Stability : in-progress 10 | -- 11 | -- OmegaGB 12 | -- Game Boy Emulator 13 | -- 14 | -- This module defines mutable state for the MachineIO module. 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | module MachineStateIO where 19 | 20 | import Data.Bits 21 | import Data.IORef 22 | import Data.Word 23 | import Data.Array.Base 24 | import Data.Array.IArray 25 | import Data.Array.MArray 26 | import Data.Array.IO 27 | 28 | import RomImage 29 | import WordUtil 30 | 31 | type DisplayPixel = Word8 32 | 33 | type ScanLine = IOUArray Int DisplayPixel 34 | 35 | data MachineStateIO = MachineStateIO { 36 | msRegA :: (IORef Word8), 37 | msRegB :: (IORef Word8), 38 | msRegC :: (IORef Word8), 39 | msRegD :: (IORef Word8), 40 | msRegE :: (IORef Word8), 41 | msRegF :: (IORef Word8), 42 | msRegH :: (IORef Word8), 43 | msRegL :: (IORef Word8), 44 | msRegPC :: (IORef Word16), 45 | msRegSP :: (IORef Word16), 46 | msRam :: (IOUArray Int Word8), 47 | msRomImage :: RomImage, 48 | msIME :: (IORef Bool), 49 | msVBlankCounter :: (IORef Int), 50 | msHBlankCounter :: (IORef Int), 51 | msHBlankMode3Counter :: (IORef Int), 52 | msHBlankMode0Counter :: (IORef Int), 53 | msCurrentScanline :: (IORef Int), 54 | msDisplay :: (Array Int ScanLine), 55 | msVBlankNow :: (IORef Bool), 56 | msDIVCounter :: (IORef Int) 57 | } 58 | 59 | initMachineStateIO :: RomImage -> IO MachineStateIO 60 | initMachineStateIO romImage = do 61 | a <- newIORef 0x01 62 | b <- newIORef 0x00 63 | c <- newIORef 0x13 64 | d <- newIORef 0x00 65 | e <- newIORef 0xD8 66 | f <- newIORef 0xB0 67 | h <- newIORef 0x01 68 | l <- newIORef 0x4D 69 | pc <- newIORef 0x0100 70 | sp <- newIORef 0xFFFE 71 | ram <- newArray (0x8000, 0xFFFF) 0x00 72 | writeArray ram 0xFF00 0x30 73 | writeArray ram 0xFF05 0x00 74 | writeArray ram 0xFF06 0x00 75 | writeArray ram 0xFF07 0x00 76 | writeArray ram 0xFF10 0x80 77 | writeArray ram 0xFF11 0xBF 78 | writeArray ram 0xFF12 0xF3 79 | writeArray ram 0xFF14 0xBF 80 | writeArray ram 0xFF16 0x3F 81 | writeArray ram 0xFF17 0x00 82 | writeArray ram 0xFF19 0xBF 83 | writeArray ram 0xFF1A 0x7F 84 | writeArray ram 0xFF1B 0xFF 85 | writeArray ram 0xFF1C 0x9F 86 | writeArray ram 0xFF1E 0xBF 87 | writeArray ram 0xFF20 0xFF 88 | writeArray ram 0xFF21 0x00 89 | writeArray ram 0xFF22 0x22 90 | writeArray ram 0xFF23 0xBF 91 | writeArray ram 0xFF24 0x77 92 | writeArray ram 0xFF25 0xF3 93 | writeArray ram 0xFF26 0xF1 94 | writeArray ram 0xFF40 0x91 95 | writeArray ram 0xFF42 0x00 96 | writeArray ram 0xFF43 0x00 97 | writeArray ram 0xFF45 0x00 98 | writeArray ram 0xFF47 0xFC 99 | writeArray ram 0xFF48 0xFF 100 | writeArray ram 0xFF49 0xFF 101 | writeArray ram 0xFF4A 0x00 102 | writeArray ram 0xFF4B 0x00 103 | writeArray ram 0xFFFF 0x00 104 | ime <- newIORef False 105 | vBlankCounter <- newIORef 0 106 | hBlankCounter <- newIORef 0 107 | hBlankMode3Counter <- newIORef 80 108 | hBlankMode0Counter <- newIORef (80 + 172) 109 | currentScanline <- newIORef 153 110 | associations <- mapM ( \n -> do { a <- newArray (0, 159) 0; return (n, a) } ) [0..143] 111 | let display = array (0, 143) associations 112 | vBlankNow <- newIORef False 113 | divCounter <- newIORef 0 114 | return MachineStateIO { 115 | msRegA = a, 116 | msRegB = b, 117 | msRegC = c, 118 | msRegD = d, 119 | msRegE = e, 120 | msRegF = f, 121 | msRegH = h, 122 | msRegL = l, 123 | msRegPC = pc, 124 | msRegSP = sp, 125 | msRam = ram, 126 | msRomImage = romImage, 127 | msIME = ime, 128 | msVBlankCounter = vBlankCounter, 129 | msHBlankCounter = hBlankCounter, 130 | msHBlankMode3Counter = hBlankMode3Counter, 131 | msHBlankMode0Counter = hBlankMode0Counter, 132 | msCurrentScanline = currentScanline, 133 | msDisplay = display, 134 | msVBlankNow = vBlankNow, 135 | msDIVCounter = divCounter } 136 | 137 | 138 | {-# INLINE readMemoryIO #-} 139 | readMemoryIO :: MachineStateIO -> Word16 -> IO Word8 140 | readMemoryIO s a 141 | | a < 0x8000 = return $ (msRomImage s) ! (fromIntegral a) 142 | | a == 0xFF00 = return 0x00 143 | | otherwise = unsafeRead (msRam s) (fromIntegral a) 144 | -- where m = msRam s 145 | -- readRam = readArray m a 146 | 147 | {-# INLINE writeMemoryIO #-} 148 | writeMemoryIO :: MachineStateIO -> Word16 -> Word8 -> IO () 149 | writeMemoryIO s a v 150 | | a < 0x8000 = return () 151 | | a == 0xF000 = if v == 0x00 || v == 0x20 || v == 0x10 || v == 0x30 152 | then writeRam 153 | else error ("$FF00 P1, Joypad, not allowed: " ++ show v) 154 | | a == 0xF004 = writeArray m (fromIntegral a) 0x00 155 | | a == 0xFF07 = if not (testBit v 2) 156 | then writeRam 157 | else error ("$FF07 TAC, Timer Control Register, not allowed: " ++ show v) 158 | | a == 0xFF44 = writeArray m (fromIntegral a) 0x00 159 | | a == 0xFF46 = mapM_ ( \i -> do srcVal <- readArray m (fromIntegral ((i-0xFE00) + (joinWord16 v 0))) 160 | writeArray m (fromIntegral i) srcVal ) 161 | [0xFE00..0xFE9f] 162 | -- | a >= 0xFF00 && a < 0xFF4C = error ((showHex a) ++ " = " ++ (showHex v) ++ " IO Register NOT IMPLEMENTED") 163 | | a == 0xFFFF = if v .&. 0x1C == 0 then writeRam else error ("$FFFF IE, Interrupt Enable, not allowed interrupt: " ++ show v)-- TODO IE, Interrupt Enable, maybe do some shit here 164 | | otherwise = writeRam 165 | where m = msRam s 166 | writeRam = writeArray m (fromIntegral a) v 167 | 168 | 169 | -------------------------------------------------------------------------------- /src/GuiTest02.hs: -------------------------------------------------------------------------------- 1 | -- OmegaGB Copyright 2007 Bit Connor 2 | -- This program is distributed under the terms of the GNU General Public License 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : GuiTest02 6 | -- Copyright : (c) Bit Connor 2007 7 | -- License : GPL 8 | -- Maintainer : bit@mutantlemon.com 9 | -- Stability : in-progress 10 | -- 11 | -- OmegaGB 12 | -- Game Boy Emulator 13 | -- 14 | -- This module runs a gtk+ application that emulates a ROM, including a 15 | -- display and push buttons for joypad control. 16 | -- 17 | ----------------------------------------------------------------------------- 18 | 19 | module GuiTest02 where 20 | 21 | import qualified Control.Exception as C 22 | import Maybe(fromJust) 23 | import Data.IORef 24 | import Data.Word 25 | import Data.Array.IArray 26 | import Data.Array.MArray 27 | import Text.Printf 28 | 29 | import Graphics.UI.Gtk 30 | import Graphics.UI.Gtk.Glade 31 | 32 | import RomImage 33 | import GuiDrawUtil 34 | import Machine 35 | import Joypad 36 | import MachineIO 37 | 38 | gladeFile = "guis/test03/test03.glade" 39 | 40 | test02 :: IO () 41 | test02 = do 42 | initGUI 43 | 44 | windowXml <- C.catch 45 | ((xmlNew gladeFile) >>= return . fromJust) 46 | (\e -> putStrLn ("Error Loading " ++ gladeFile) >> C.throwIO e) 47 | 48 | let bindWidget x y = xmlGetWidget windowXml x y 49 | main_window <- bindWidget castToWindow "main_window" 50 | menu_open <- bindWidget castToMenuItem "menu_open" 51 | menu_quit <- bindWidget castToMenuItem "menu_quit" 52 | menu_about <- bindWidget castToMenuItem "menu_about" 53 | display <- bindWidget castToDrawingArea "display" 54 | joypad_right <- bindWidget castToToggleButton "joypad_right" 55 | joypad_left <- bindWidget castToToggleButton "joypad_left" 56 | joypad_up <- bindWidget castToToggleButton "joypad_up" 57 | joypad_down <- bindWidget castToToggleButton "joypad_down" 58 | joypad_a <- bindWidget castToToggleButton "joypad_a" 59 | joypad_b <- bindWidget castToToggleButton "joypad_b" 60 | joypad_select <- bindWidget castToToggleButton "joypad_select" 61 | joypad_start <- bindWidget castToToggleButton "joypad_start" 62 | 63 | displayPixBuf <- pixbufNew ColorspaceRgb False 8 160 144 64 | pbData <- (pixbufGetPixels displayPixBuf :: IO (PixbufData Int Word8)) 65 | row <- pixbufGetRowstride displayPixBuf 66 | chan <- pixbufGetNChannels displayPixBuf 67 | bits <- pixbufGetBitsPerSample displayPixBuf 68 | 69 | state <- newIORef Nothing 70 | 71 | -- for video capture, counts the current frame number 72 | --n <- newIORef (0::Int) 73 | 74 | let 75 | ------------------------------------------------------------------------ 76 | 77 | refreshDisplay d = do 78 | -- draw into the Pixbuf 79 | doFromTo 0 143 $ \y -> 80 | doFromTo 0 159 $ \x -> do 81 | let color = d!(y, x) 82 | colorByte = (fromIntegral color) * 85 83 | writeArray pbData (x*chan+y*row) colorByte 84 | writeArray pbData (1+x*chan+y*row) colorByte 85 | writeArray pbData (2+x*chan+y*row) colorByte 86 | 87 | widgetQueueDraw display 88 | 89 | ------------------------------------------------------------------------ 90 | 91 | step = do 92 | s <- readIORef state 93 | case s of 94 | Nothing -> return () 95 | Just s' -> do 96 | right <- toggleButtonGetActive joypad_right 97 | left <- toggleButtonGetActive joypad_left 98 | up <- toggleButtonGetActive joypad_up 99 | down <- toggleButtonGetActive joypad_down 100 | a <- toggleButtonGetActive joypad_a 101 | b <- toggleButtonGetActive joypad_b 102 | select <- toggleButtonGetActive joypad_select 103 | start <- toggleButtonGetActive joypad_start 104 | let jp = initJoypadKeyStates right left up down a b select start 105 | let (d, s'') = updateMachineDisplayFrame jp s' 106 | writeIORef state (Just s'') 107 | refreshDisplay d 108 | --- for video capture, dump current frame to png file 109 | --num <- readIORef n 110 | --pixbufSave displayPixBuf ("tmp/f" ++ (printf "%04d" num) ++ ".png") "png" [] 111 | --modifyIORef n (+1) 112 | --- 113 | return True 114 | 115 | ------------------------------------------------------------------------ 116 | 117 | ------------------------------------------------------------------------ 118 | 119 | open = do 120 | fileSelect <- fileChooserDialogNew 121 | (Just "Open Game Boy ROM") 122 | (Just main_window) 123 | FileChooserActionOpen 124 | [("gtk-open", ResponseOk), ("gtk-cancel", ResponseDeleteEvent)] 125 | response <- dialogRun fileSelect 126 | case response of 127 | ResponseOk -> do 128 | romFile <- fileChooserGetFilename fileSelect 129 | romImage <- loadRomImage (fromJust romFile) 130 | writeIORef state $ Just (initialMachineState romImage) 131 | ResponseDeleteEvent -> do 132 | return () 133 | widgetDestroy fileSelect 134 | 135 | -- register Idle action 136 | 137 | ------------------------------------------------------------------------ 138 | 139 | quit = widgetDestroy main_window >> mainQuit 140 | 141 | ------------------------------------------------------------------------ 142 | 143 | menu_quit `onActivateLeaf` quit 144 | main_window `onDestroy` quit 145 | menu_open `onActivateLeaf` open 146 | menu_about `onActivateLeaf` do 147 | dia <- aboutDialogNew 148 | aboutDialogSetName dia "OmegaGB test01" 149 | aboutDialogSetComments dia "Game Boy Emulator Development Test" 150 | dialogRun dia 151 | widgetDestroy dia 152 | 153 | display `onSizeRequest` return (Requisition 160 144) 154 | display `onExpose` updateCanvas display displayPixBuf 155 | 156 | idleAdd step priorityDefaultIdle 157 | 158 | mainGUI 159 | return () 160 | 161 | -------------------------------------------------------------------------------- /src/GuiTest03.hs: -------------------------------------------------------------------------------- 1 | -- OmegaGB Copyright 2007 Bit Connor 2 | -- This program is distributed under the terms of the GNU General Public License 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : GuiTest03 6 | -- Copyright : (c) Bit Connor 2007 7 | -- License : GPL 8 | -- Maintainer : bit@mutantlemon.com 9 | -- Stability : in-progress 10 | -- 11 | -- OmegaGB 12 | -- Game Boy Emulator 13 | -- 14 | -- This module runs is supposed to be a gtk+ application that emulates a ROM, 15 | -- using the IO based emulation core. It doesn't seem to compile. 16 | -- 17 | ----------------------------------------------------------------------------- 18 | 19 | module GuiTest03 where 20 | 21 | import qualified Control.Exception as C 22 | import Maybe(fromJust) 23 | import Data.IORef 24 | import Data.Word 25 | import Data.Array.IArray 26 | import Data.Array.MArray 27 | import Text.Printf 28 | 29 | import Graphics.UI.Gtk 30 | import Graphics.UI.Gtk.Glade 31 | 32 | import RomImage 33 | import GuiDrawUtil 34 | import Machine 35 | import Joypad 36 | import MachineIO 37 | 38 | gladeFile = "guis/test03/test03.glade" 39 | 40 | test03 :: IO () 41 | test03 = do 42 | initGUI 43 | 44 | windowXml <- C.catch 45 | ((xmlNew gladeFile) >>= return . fromJust) 46 | (\e -> putStrLn ("Error Loading " ++ gladeFile) >> C.throwIO e) 47 | 48 | let bindWidget x y = xmlGetWidget windowXml x y 49 | main_window <- bindWidget castToWindow "main_window" 50 | menu_open <- bindWidget castToMenuItem "menu_open" 51 | menu_quit <- bindWidget castToMenuItem "menu_quit" 52 | menu_about <- bindWidget castToMenuItem "menu_about" 53 | display <- bindWidget castToDrawingArea "display" 54 | joypad_right <- bindWidget castToToggleButton "joypad_right" 55 | joypad_left <- bindWidget castToToggleButton "joypad_left" 56 | joypad_up <- bindWidget castToToggleButton "joypad_up" 57 | joypad_down <- bindWidget castToToggleButton "joypad_down" 58 | joypad_a <- bindWidget castToToggleButton "joypad_a" 59 | joypad_b <- bindWidget castToToggleButton "joypad_b" 60 | joypad_select <- bindWidget castToToggleButton "joypad_select" 61 | joypad_start <- bindWidget castToToggleButton "joypad_start" 62 | 63 | displayPixBuf <- pixbufNew ColorspaceRgb False 8 160 144 64 | pbData <- (pixbufGetPixels displayPixBuf :: IO (PixbufData Int Word8)) 65 | row <- pixbufGetRowstride displayPixBuf 66 | chan <- pixbufGetNChannels displayPixBuf 67 | bits <- pixbufGetBitsPerSample displayPixBuf 68 | 69 | state <- newIORef Nothing 70 | 71 | -- for video capture, counts the current frame number 72 | --n <- newIORef (0::Int) 73 | 74 | let 75 | ------------------------------------------------------------------------ 76 | 77 | refreshDisplay d = do 78 | -- draw into the Pixbuf 79 | doFromTo 0 143 $ \y -> 80 | let scanline = d!y in 81 | doFromTo 0 159 $ \x -> do 82 | color <- readArray scanline x 83 | let colorByte = (fromIntegral color) * 85 84 | writeArray pbData (x*chan+y*row) colorByte 85 | writeArray pbData (1+x*chan+y*row) colorByte 86 | writeArray pbData (2+x*chan+y*row) colorByte 87 | 88 | widgetQueueDraw display 89 | 90 | ------------------------------------------------------------------------ 91 | 92 | step = do 93 | s <- readIORef state 94 | case s of 95 | Nothing -> return () 96 | Just machineState -> do 97 | right <- toggleButtonGetActive joypad_right 98 | left <- toggleButtonGetActive joypad_left 99 | up <- toggleButtonGetActive joypad_up 100 | down <- toggleButtonGetActive joypad_down 101 | a <- toggleButtonGetActive joypad_a 102 | b <- toggleButtonGetActive joypad_b 103 | select <- toggleButtonGetActive joypad_select 104 | start <- toggleButtonGetActive joypad_start 105 | 106 | let jp = initJoypadKeyStates right left up down a b select start 107 | 108 | --let (d, s'') = updateMachineDisplayFrame jp s' 109 | --writeIORef state (Just s'') 110 | updateMachineDisplayFrameIO machineState 111 | 112 | refreshDisplay (msDisplay machineState) 113 | --- for video capture, dump current frame to png file 114 | --num <- readIORef n 115 | --pixbufSave displayPixBuf ("tmp/f" ++ (printf "%04d" num) ++ ".png") "png" [] 116 | --modifyIORef n (+1) 117 | --- 118 | return True 119 | 120 | ------------------------------------------------------------------------ 121 | 122 | ------------------------------------------------------------------------ 123 | 124 | open = do 125 | fileSelect <- fileChooserDialogNew 126 | (Just "Open Game Boy ROM") 127 | (Just main_window) 128 | FileChooserActionOpen 129 | [("gtk-open", ResponseOk), ("gtk-cancel", ResponseDeleteEvent)] 130 | response <- dialogRun fileSelect 131 | case response of 132 | ResponseOk -> do 133 | romFile <- fileChooserGetFilename fileSelect 134 | romImage <- loadRomImage (fromJust romFile) 135 | machineState <- initMachineStateIO romImage 136 | writeIORef state $ Just machineState 137 | ResponseDeleteEvent -> do 138 | return () 139 | widgetDestroy fileSelect 140 | 141 | -- register Idle action 142 | 143 | ------------------------------------------------------------------------ 144 | 145 | quit = widgetDestroy main_window >> mainQuit 146 | 147 | ------------------------------------------------------------------------ 148 | 149 | menu_quit `onActivateLeaf` quit 150 | main_window `onDestroy` quit 151 | menu_open `onActivateLeaf` open 152 | menu_about `onActivateLeaf` do 153 | dia <- aboutDialogNew 154 | aboutDialogSetName dia "OmegaGB test01" 155 | aboutDialogSetComments dia "Game Boy Emulator Development Test" 156 | aboutDialogSetWebsite dia "http://www.mutantlemon.com/omegagb" 157 | dialogRun dia 158 | widgetDestroy dia 159 | 160 | display `onSizeRequest` return (Requisition 160 144) 161 | display `onExpose` updateCanvas display displayPixBuf 162 | 163 | idleAdd step priorityDefaultIdle 164 | 165 | mainGUI 166 | return () 167 | 168 | 169 | -------------------------------------------------------------------------------- /guis/test02/test02.glade: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | True 8 | window1 9 | GTK_WINDOW_TOPLEVEL 10 | GTK_WIN_POS_NONE 11 | False 12 | True 13 | False 14 | True 15 | False 16 | False 17 | GDK_WINDOW_TYPE_HINT_NORMAL 18 | GDK_GRAVITY_NORTH_WEST 19 | True 20 | False 21 | 22 | 23 | 24 | True 25 | False 26 | 0 27 | 28 | 29 | 30 | True 31 | GTK_PACK_DIRECTION_LTR 32 | GTK_PACK_DIRECTION_LTR 33 | 34 | 35 | 36 | True 37 | _File 38 | True 39 | 40 | 41 | 42 | 43 | 44 | 45 | True 46 | gtk-open 47 | True 48 | 49 | 50 | 51 | 52 | 53 | 54 | True 55 | 56 | 57 | 58 | 59 | 60 | True 61 | gtk-quit 62 | True 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | True 74 | _Edit 75 | True 76 | 77 | 78 | 79 | 80 | 81 | 82 | True 83 | gtk-cut 84 | True 85 | 86 | 87 | 88 | 89 | 90 | 91 | True 92 | gtk-copy 93 | True 94 | 95 | 96 | 97 | 98 | 99 | 100 | True 101 | gtk-paste 102 | True 103 | 104 | 105 | 106 | 107 | 108 | 109 | True 110 | gtk-delete 111 | True 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | True 123 | _Help 124 | True 125 | 126 | 127 | 128 | 129 | 130 | 131 | True 132 | _About 133 | True 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 0 144 | False 145 | False 146 | 147 | 148 | 149 | 150 | 151 | True 152 | False 153 | 0 154 | 155 | 156 | 157 | 160 158 | 144 159 | True 160 | 161 | 162 | 0 163 | True 164 | False 165 | 166 | 167 | 168 | 169 | 0 170 | True 171 | False 172 | 173 | 174 | 175 | 176 | 177 | 178 | 179 | -------------------------------------------------------------------------------- /src/MachineIO.hs: -------------------------------------------------------------------------------- 1 | -- OmegaGB Copyright 2007 Bit Connor 2 | -- This program is distributed under the terms of the GNU General Public License 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : MachineIO 6 | -- Copyright : (c) Bit Connor 2007 7 | -- License : GPL 8 | -- Maintainer : bit@mutantlemon.com 9 | -- Stability : in-progress 10 | -- 11 | -- OmegaGB 12 | -- Game Boy Emulator 13 | -- 14 | -- This module is an alternative implementation of Machine, using the IO 15 | -- monad and mutable variables in an attempt to get better performance. 16 | -- I'm not sure if it works. 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module MachineIO where 21 | 22 | import Data.Array.MArray 23 | import Data.Bits 24 | import Data.IORef 25 | import Data.List (elemIndex) 26 | import Data.Maybe (fromJust, isJust) 27 | import Data.Word 28 | import Control.Monad.State 29 | 30 | import Cpu 31 | import CpuIO 32 | import CpuExecution 33 | import Machine 34 | import MachineStateIO 35 | import WordUtil 36 | 37 | msRegIORef :: MachineStateIO -> M_Register -> IORef Word8 38 | msRegIORef s reg = case reg of 39 | M_A -> msRegA s 40 | M_B -> msRegB s 41 | M_C -> msRegC s 42 | M_D -> msRegD s 43 | M_E -> msRegE s 44 | M_F -> msRegF s 45 | M_H -> msRegH s 46 | M_L -> msRegL s 47 | 48 | msReg2IORef :: MachineStateIO -> M_Register2 -> IORef Word16 49 | msReg2IORef s reg2 = case reg2 of 50 | M_PC -> msRegPC s 51 | M_SP -> msRegSP s 52 | 53 | machineCpuExecuteIO :: MachineStateIO -> ExecutionAST () -> IO () 54 | machineCpuExecuteIO s e = machineCpuExecuteIO' s e 55 | 56 | machineCpuExecuteIO' :: MachineStateIO -> ExecutionAST a -> IO a 57 | machineCpuExecuteIO' s e = case e of 58 | Return result -> return result 59 | Bind l r -> do result <- machineCpuExecuteIO' s l 60 | machineCpuExecuteIO' s (r result) 61 | WriteRegister reg n -> writeIORef (msRegIORef s reg) n 62 | ReadRegister reg -> readIORef (msRegIORef s reg) 63 | WriteRegister2 reg2 nn -> let (hi, lo) = splitWord16 nn in 64 | case reg2 of 65 | M_PC -> writeIORef (msRegPC s) nn 66 | M_SP -> writeIORef (msRegSP s) nn 67 | M_AF -> writeIORef (msRegA s) hi >> 68 | writeIORef (msRegF s) (lo.&.0xF0) 69 | M_BC -> writeIORef (msRegB s) hi >> 70 | writeIORef (msRegC s) lo 71 | M_DE -> writeIORef (msRegD s) hi >> 72 | writeIORef (msRegE s) lo 73 | M_HL -> writeIORef (msRegH s) hi >> 74 | writeIORef (msRegL s) lo 75 | ReadRegister2 reg2 -> case reg2 of 76 | M_PC -> readIORef (msRegPC s) 77 | M_SP -> readIORef (msRegSP s) 78 | M_AF -> do hi <- readIORef (msRegA s) 79 | lo <- readIORef (msRegF s) 80 | return $ joinWord16 hi lo 81 | M_BC -> do hi <- readIORef (msRegB s) 82 | lo <- readIORef (msRegC s) 83 | return $ joinWord16 hi lo 84 | M_DE -> do hi <- readIORef (msRegD s) 85 | lo <- readIORef (msRegE s) 86 | return $ joinWord16 hi lo 87 | M_HL -> do hi <- readIORef (msRegH s) 88 | lo <- readIORef (msRegL s) 89 | return $ joinWord16 hi lo 90 | WriteMemory a n -> writeMemoryIO s a n 91 | ReadMemory a -> readMemoryIO s a 92 | 93 | fetchInstructionIO :: MachineStateIO -> IO Instruction 94 | fetchInstructionIO s = do 95 | pc <- readIORef (msRegPC s) 96 | opcode <- readMemoryIO s pc 97 | n <- readMemoryIO s (pc + 1) 98 | n' <- readMemoryIO s (pc + 2) 99 | let nn = joinWord16 n' n 100 | return $ machineCodeToInstruction opcode (n, nn) 101 | 102 | machineStepInstructionIO :: MachineStateIO -> IO () 103 | machineStepInstructionIO s = do 104 | instruction <- fetchInstructionIO s 105 | let execution = executeInstruction instruction 106 | machineCpuExecuteIO s execution 107 | 108 | updateMachineIO :: MachineStateIO -> IO () 109 | updateMachineIO s = do 110 | pc <- readIORef (msRegPC s) 111 | opcode <- readMemoryIO s pc 112 | let cycles = opcodeCycleCount opcode 113 | -- let ime = opcodeQueryIME opcode 114 | --machineStepInstructionIO s 115 | machineUpdateInstructionIO s 116 | irqUpdateIO s cycles --ime 117 | 118 | updateMachineDisplayFrameIO :: MachineStateIO -> IO () 119 | updateMachineDisplayFrameIO s = do 120 | updateMachineIO s 121 | vbn <- readIORef (msVBlankNow s) 122 | case vbn of 123 | True -> return () 124 | False -> updateMachineDisplayFrameIO s 125 | 126 | irqUpdateIO :: MachineStateIO -> CycleCount -> IO() --Maybe Bool -> IO () 127 | irqUpdateIO s cycles = do --ime = do 128 | -- when (isJust ime) (writeIORef (msIME s) (fromJust ime)) 129 | 130 | let subtractCycles x = modifyIORef (x s) (subtract cycles) 131 | mapM_ subtractCycles [msVBlankCounter, msHBlankCounter, msHBlankMode3Counter, 132 | msHBlankMode0Counter, msDIVCounter] 133 | 134 | v <- readIORef (msVBlankCounter s) 135 | writeIORef (msVBlankNow s) (v <= 0) 136 | 137 | let processCounter x y z = do c <- readIORef (x s) 138 | when (c <= 0) 139 | (writeIORef (x s) (c + y) >> z s) 140 | 141 | processCounter msHBlankCounter hBlankPeriod tickHBlankIO 142 | processCounter msHBlankMode3Counter hBlankPeriod tickHBlankMode3IO 143 | processCounter msHBlankMode0Counter hBlankPeriod tickHBlankMode0IO 144 | processCounter msVBlankCounter vBlankPeriod tickVBlankIO 145 | processCounter msDIVCounter divPeriod tickDIVIO 146 | 147 | ime <- readIORef (msIME s) 148 | flagsIF <- readMemoryIO s 0xFF0F 149 | flagsIE <- readMemoryIO s 0xFFFF 150 | 151 | when (ime && (flagsIF .&. flagsIE > 0)) 152 | ( 153 | let i = getLowBit (flagsIF .&. flagsIE) 154 | jumpAddr = case i of 155 | 0 -> 0x0040 156 | 1 -> 0x0048 157 | 2 -> 0x0050 158 | 3 -> 0x0058 159 | 4 -> 0x0060 in 160 | do writeIORef (msIME s) False 161 | modifyArray (msRam s) 0xFF0F (`clearBit` i) 162 | oldPC <- readIORef (msRegPC s) 163 | let (hiPC, loPC) = splitWord16 oldPC 164 | oldSP <- readIORef (msRegSP s) 165 | writeMemoryIO s (oldSP - 1) hiPC 166 | writeMemoryIO s (oldSP - 2) loPC 167 | writeIORef (msRegSP s) (oldSP - 2) 168 | writeIORef (msRegPC s) jumpAddr 169 | ) 170 | 171 | where getLowBit :: Word8 -> Int 172 | getLowBit n = fromJust (elemIndex True (map (testBit n) [0..4])) 173 | 174 | modifyArray a i f = readArray a i >>= ( \v -> writeArray a i (f v) ) 175 | 176 | tickHBlankIO :: MachineStateIO -> IO () 177 | tickHBlankIO s = do 178 | modifyArray (msRam s) 0xFF44 ((`mod` 154).(+1)) 179 | modifyIORef (msCurrentScanline s) ((`mod` 154).(+1)) 180 | cs <- readIORef (msCurrentScanline s) 181 | when (cs < 144) 182 | ( do 183 | ly <- readArray (msRam s) 0xFF44 184 | lyc <- readArray (msRam s) 0xFF45 185 | statB5 <- readArray (msRam s) 0xFF41 >>= return . (`testBit` 5) 186 | statB6 <- readArray (msRam s) 0xFF41 >>= return . (`testBit` 6) 187 | modifyArray (msRam s) 0xFF41 (execState $ do 188 | modify (`clearBit` 0) 189 | modify (`setBit` 1) 190 | modify (if ly==lyc then (`setBit` 2) else (`clearBit` 2))) 191 | modifyArray (msRam s) 0xFF0F (execState $ when (statB5 || (statB6 && ly==lyc)) (modify (`setBit` 1))) 192 | readIORef (msCurrentScanline s) >>= renderScanLineIO s 193 | ) 194 | 195 | tickHBlankMode3IO :: MachineStateIO -> IO () 196 | tickHBlankMode3IO s = do 197 | cs <- readIORef (msCurrentScanline s) 198 | when (cs < 144) 199 | ( do 200 | modifyArray (msRam s) 0xFF41 (execState $ do 201 | modify (`setBit` 0) 202 | modify (`setBit` 1)) 203 | ) 204 | 205 | tickHBlankMode0IO :: MachineStateIO -> IO () 206 | tickHBlankMode0IO s = do 207 | cs <- readIORef (msCurrentScanline s) 208 | when (cs < 144) 209 | ( do 210 | statB3 <- readArray (msRam s) 0xFF41 >>= return . (`testBit` 3) 211 | modifyArray (msRam s) 0xFF41 (execState $ do 212 | modify (`clearBit` 0) 213 | modify (`clearBit` 1)) 214 | modifyArray (msRam s) 0xFF0F (execState $ when statB3 (modify (`setBit` 1))) 215 | ) 216 | 217 | tickVBlankIO :: MachineStateIO -> IO () 218 | tickVBlankIO s = do 219 | statB4 <- readArray (msRam s) 0xFF41 >>= return . (`testBit` 4) 220 | modifyArray (msRam s) 0xFF41 (execState $ do 221 | modify (`setBit` 0) 222 | modify (`clearBit` 1)) 223 | modifyArray (msRam s) 0xFF0F (execState $ do 224 | when statB4 (modify (`setBit` 1)) 225 | modify (`setBit` 0)) 226 | 227 | tickDIVIO :: MachineStateIO -> IO () 228 | tickDIVIO s = modifyArray (msRam s) 0xFF04 (+1) 229 | 230 | renderScanLineIO s scanlineNum = return () 231 | {- 232 | renderScanLineIO :: MachineStateIO -> Int -> IO () 233 | renderScanLineIO s scanlineNum = let scanline = (msDisplay s)!scanlineNum in do 234 | scx <- readMemoryIO s 0xFF43 >>= return . fromIntegral 235 | scy <- readMemoryIO s 0xFF42 >>= return . fromIntegral 236 | lcdc <- readMemoryIO s 0xFF40 237 | let lcdon = testBit lcdc 7 238 | let bgon = testBit lcdc 0 239 | let bgmap = testBit lcdc 3 240 | let bgmapStartAddr = if bgmap then 0x9C00 else 0x9800 241 | let bgtiles = testBit lcdc 4 242 | let bgtilesStartAddr = if bgtiles then 0x8000 else 0x9000 243 | let spriteson = testBit lcdc 1 244 | let spritesbig = testBit lcdc 2 245 | let getBgPixel :: Int -> Int -> IO Word8 246 | getBgPixel x y = do 247 | let x' = (x + scx) `mod` 256 248 | y' = (y + scy) `mod` 256 249 | xrow = x' `div` 8 250 | yrow = y' `div` 8 251 | tileNum = fromIntegral (yrow * 32 + xrow) 252 | tileIndex <- readMemoryIO s (tileNum + bgmapStartAddr) 253 | let tileStartMem = bgtilesStartAddr + (16 * (fromIntegral tileIndex)) 254 | xoff = 7 - (x' `mod` 8) 255 | yoff = y' `mod` 8 256 | hiByte = tileStartMem + (yoff * 2) 257 | loByte = tileStartMem + (yoff * 2) + 1 258 | hiByteValue <- readMemoryIO s (fromIntegral hiByte) 259 | loByteValue <- readMemoryIO s (fromIntegral loByte) 260 | let color = (2 * (fromEnum (testBit loByteValue xoff))) + 261 | (fromEnum (testBit hiByteValue xoff)) 262 | if (bgon && lcdon) 263 | then return (fromIntegral color) 264 | else return 0 265 | 266 | mapM_ ( \x -> getBgPixel x scanlineNum >>= writeArray scanline x ) [0..159] 267 | -} 268 | 269 | 270 | -------------------------------------------------------------------------------- /src/Memory.hs: -------------------------------------------------------------------------------- 1 | -- OmegaGB Copyright 2007 Bit Connor 2 | -- This program is distributed under the terms of the GNU General Public License 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Memory 6 | -- Copyright : (c) Bit Connor 2007 7 | -- License : GPL 8 | -- Maintainer : bit@mutantlemon.com 9 | -- Stability : in-progress 10 | -- 11 | -- OmegaGB 12 | -- Game Boy Emulator 13 | -- 14 | -- This module does emulation of the Game Boy's memory architecture. 15 | -- Still lots more work to do. 16 | -- 17 | ----------------------------------------------------------------------------- 18 | 19 | module Memory where 20 | --import Prerequisites 21 | 22 | import Data.Array.Unboxed 23 | import Data.Word 24 | import Data.Bits 25 | 26 | import Debug.Trace 27 | 28 | import RomImage 29 | import Joypad 30 | import WordUtil 31 | 32 | class MemoryModel a where 33 | readMem :: a -> Word16 -> Word8 34 | writeMem :: a -> Word16 -> Word8 -> a 35 | 36 | data Memory = Memory { 37 | memRomImage :: RomImage, 38 | memRam :: UArray Word16 Word8, 39 | memJoypadKeyStates :: JoypadKeyStates 40 | } 41 | 42 | initMemory :: RomImage -> Memory 43 | initMemory ri = Memory { 44 | memRomImage = ri, 45 | memRam = (listArray (0x8000, 0xFFFF) (replicate 0x8000 0x00)) // 46 | [ 47 | (0xFF00, 0x30), 48 | (0xFF05, 0x00), 49 | (0xFF06, 0x00), 50 | (0xFF07, 0x00), 51 | (0xFF10, 0x80), 52 | (0xFF11, 0xBF), 53 | (0xFF12, 0xF3), 54 | (0xFF14, 0xBF), 55 | (0xFF16, 0x3F), 56 | (0xFF17, 0x00), 57 | (0xFF19, 0xBF), 58 | (0xFF1A, 0x7F), 59 | (0xFF1B, 0xFF), 60 | (0xFF1C, 0x9F), 61 | (0xFF1E, 0xBF), 62 | (0xFF20, 0xFF), 63 | (0xFF21, 0x00), 64 | (0xFF22, 0x22), 65 | (0xFF23, 0xBF), 66 | (0xFF24, 0x77), 67 | (0xFF25, 0xF3), 68 | (0xFF26, 0xF1), 69 | (0xFF40, 0x91), 70 | (0xFF42, 0x00), 71 | (0xFF43, 0x00), 72 | (0xFF45, 0x00), 73 | (0xFF47, 0xFC), 74 | (0xFF48, 0xFF), 75 | (0xFF49, 0xFF), 76 | (0xFF4A, 0x00), 77 | (0xFF4B, 0x00), 78 | (0xFFFF, 0x00) 79 | ], 80 | memJoypadKeyStates = initJoypadKeyStates False False False False False False False False 81 | 82 | {- XXX -} -- Rom Bank 83 | } 84 | 85 | 86 | instance MemoryModel Memory where 87 | readMem m a 88 | | a < 0x8000 = readRomImageByte (memRomImage m) (fromIntegral a) 89 | | a == 0xFF00 = let p0 = (memRam m)!0xFF00 90 | boolBit :: Int -> Bool -> Word8 91 | boolBit n b = if b then 0x00 else bit n in 92 | if not (testBit p0 4) 93 | then let p10 = boolBit 0 (getJoypadKeyStateRight (memJoypadKeyStates m)) 94 | p11 = boolBit 1 (getJoypadKeyStateLeft (memJoypadKeyStates m)) 95 | p12 = boolBit 2 (getJoypadKeyStateUp (memJoypadKeyStates m)) 96 | p13 = boolBit 3 (getJoypadKeyStateDown (memJoypadKeyStates m)) 97 | in p10 .|. p11 .|. p12 .|. p13 98 | else if not (testBit p0 5) 99 | then let p10 = boolBit 0 (getJoypadKeyStateA (memJoypadKeyStates m)) 100 | p11 = boolBit 1 (getJoypadKeyStateB (memJoypadKeyStates m)) 101 | p12 = boolBit 2 (getJoypadKeyStateSelect (memJoypadKeyStates m)) 102 | p13 = boolBit 3 (getJoypadKeyStateStart (memJoypadKeyStates m)) 103 | in p10 .|. p11 .|. p12 .|. p13 104 | else 0x0F 105 | | a == 0xFF01 = readRam 106 | | a == 0xFF02 = readRam 107 | | a == 0xFF03 = readRam 108 | | a == 0xFF04 = readRam -- DIV Register, should work 109 | | a == 0xFF05 = readRam 110 | | a == 0xFF06 = readRam 111 | | a == 0xFF07 = readRam 112 | | a == 0xFF08 = readRam 113 | | a == 0xFF09 = readRam 114 | | a == 0xFF0A = readRam 115 | | a == 0xFF0B = readRam 116 | | a == 0xFF0C = readRam 117 | | a == 0xFF0D = readRam 118 | | a == 0xFF0E = readRam 119 | | a == 0xFF0F = readRam -- IF, Interrupt Flag 120 | | a == 0xFF10 = readRam 121 | | a == 0xFF30 = readRam 122 | | a == 0xFF33 = readRam 123 | | a == 0xFF34 = readRam 124 | | a == 0xFF35 = readRam 125 | | a == 0xFF36 = readRam 126 | | a == 0xFF37 = readRam 127 | | a == 0xFF38 = readRam 128 | | a == 0xFF39 = readRam 129 | | a == 0xFF3A = readRam 130 | | a == 0xFF3B = readRam 131 | | a == 0xFF3C = readRam 132 | | a == 0xFF3D = readRam 133 | | a == 0xFF3E = readRam 134 | | a == 0xFF3F = readRam 135 | | a == 0xFF40 = readRam 136 | | a == 0xFF41 = readRam -- TODO STAT, LCDC Status TODO this is some bizarre read/write register 137 | | a == 0xFF42 = readRam -- SCY Scroll Y 138 | | a == 0xFF43 = readRam -- SCX Scroll X 139 | | a == 0xFF44 = readRam 140 | | a == 0xFF45 = readRam 141 | | a == 0xFF47 = readRam -- TODO BGP, BG & Window Pallette Data, do some shit here 142 | | a == 0xFF48 = readRam -- TODO OBP0, Object Pallette 0 Data, do some shit here 143 | | a == 0xFF49 = readRam -- TODO OBP1, Object Pallette 1 Data, do some shit here 144 | -- | a >= 0xFF00 && a < 0xFF4C = error ((showHex a) ++ " IO Register NOT IMPLEMENTED") 145 | | otherwise = readRam 146 | 147 | where readRam = (flip const) ("read " ++ showHex2 a) ((memRam m) ! a) 148 | 149 | writeMem m a v 150 | | a < 0x8000 = m 151 | | a == 0xFF00 = if v == 0x00 || v == 0x20 || v == 0x10 || v == 0x30 then writeRam else error ("$FF00 P1, Joypad, not allowed: " ++ show v) -- P1 Joypad 152 | | a == 0xFF01 = writeRam 153 | | a == 0xFF02 = writeRam 154 | | a == 0xFF03 = writeRam -- TODO wtf is this register??? allow the write for now 155 | | a == 0xFF04 = m { memRam = (memRam m)//[(a, 0x00)] } -- DIV (Divider Register) 156 | | a == 0xFF05 = writeRam -- TODO Timer counter TIMA probably don't need to do anything here 157 | | a == 0xFF06 = writeRam -- TODO Timer Modulo TMA maybe we need to do some shit here 158 | | a == 0xFF07 = if not (testBit v 2) then writeRam else error ("$FF07 TAC, Timer Control Register, not allowed: " ++ show v) -- TODO Timer Control TAC maybe we need to do some shit here 159 | | a == 0xFF08 = writeRam -- TODO wtf is this register??? allow the write for now 160 | | a == 0xFF09 = writeRam -- TODO wtf is this register??? allow the write for now 161 | | a == 0xFF0A = writeRam -- TODO wtf is this register??? allow the write for now 162 | | a == 0xFF0B = writeRam -- TODO wtf is this register??? allow the write for now 163 | | a == 0xFF0C = writeRam -- TODO wtf is this register??? allow the write for now 164 | | a == 0xFF0D = writeRam -- TODO wtf is this register??? allow the write for now 165 | | a == 0xFF0E = writeRam -- TODO wtf is this register??? allow the write for now 166 | | a == 0xFF0F = writeRam -- IF Interrupt Flag 167 | | a == 0xFF10 = writeRam 168 | | a == 0xFF11 = writeRam 169 | | a == 0xFF12 = writeRam 170 | | a == 0xFF13 = writeRam 171 | | a == 0xFF14 = writeRam 172 | | a == 0xFF15 = writeRam -- TODO wtf is this register??? allow the write for now 173 | | a == 0xFF16 = writeRam 174 | | a == 0xFF17 = writeRam 175 | | a == 0xFF18 = writeRam 176 | | a == 0xFF19 = writeRam 177 | | a == 0xFF1A = writeRam 178 | | a == 0xFF1B = writeRam 179 | | a == 0xFF1C = writeRam 180 | | a == 0xFF1D = writeRam 181 | | a == 0xFF1E = writeRam 182 | | a == 0xFF1F = writeRam -- TODO wtf is this register??? allow the write for now 183 | | a == 0xFF20 = writeRam 184 | | a == 0xFF21 = writeRam 185 | | a == 0xFF22 = writeRam 186 | | a == 0xFF23 = writeRam 187 | | a == 0xFF24 = writeRam 188 | | a == 0xFF25 = writeRam 189 | | a == 0xFF26 = writeRam 190 | | a == 0xFF27 = writeRam -- TODO wtf is this register??? allow the write for now 191 | | a == 0xFF28 = writeRam -- TODO wtf is this register??? allow the write for now 192 | | a == 0xFF29 = writeRam -- TODO wtf is this register??? allow the write for now 193 | | a == 0xFF2A = writeRam -- TODO wtf is this register??? allow the write for now 194 | | a == 0xFF2B = writeRam -- TODO wtf is this register??? allow the write for now 195 | | a == 0xFF2C = writeRam -- TODO wtf is this register??? allow the write for now 196 | | a == 0xFF2D = writeRam -- TODO wtf is this register??? allow the write for now 197 | | a == 0xFF2E = writeRam -- TODO wtf is this register??? allow the write for now 198 | | a == 0xFF2F = writeRam -- TODO wtf is this register??? allow the write for now 199 | | a == 0xFF30 = writeRam 200 | | a == 0xFF31 = writeRam 201 | | a == 0xFF32 = writeRam 202 | | a == 0xFF33 = writeRam 203 | | a == 0xFF34 = writeRam 204 | | a == 0xFF35 = writeRam 205 | | a == 0xFF36 = writeRam 206 | | a == 0xFF37 = writeRam 207 | | a == 0xFF38 = writeRam 208 | | a == 0xFF39 = writeRam 209 | | a == 0xFF3A = writeRam 210 | | a == 0xFF3B = writeRam 211 | | a == 0xFF3C = writeRam 212 | | a == 0xFF3D = writeRam 213 | | a == 0xFF3E = writeRam 214 | | a == 0xFF3F = writeRam 215 | | a == 0xFF40 = writeRam -- TODO LCDC, LCD Control, maybe do shit 216 | | a == 0xFF41 = writeRam -- if v .&. 0x78 == 0 then m else error ("$FF41 STAT Register, tried to turn on interrupt, not allowed " ++ show v ++ " LYC=" ++ show ((memRam m)!0xFF45))-- TODO STAT, LCDC Status, only modify bits 3,4,5,6! maybe do some other shit 217 | | a == 0xFF42 = writeRam -- TODO SCY, Scroll Y, maybe do shit 218 | | a == 0xFF43 = writeRam -- TODO SCX, Scroll X, maybe do shit 219 | | a == 0xFF44 = m { memRam = (memRam m)//[(a, 0x00)] } -- error "write to IO Register $FF44 (LY - LCDC Y Coordanite)" 220 | | a == 0xFF45 = writeRam -- TODO LYC, LY Compare, maybe do shit 221 | | a == 0xFF46 = m { memRam = (memRam m)// 222 | (map ( \i -> 223 | (i, 224 | (flip const) 225 | ("DMA: " ++ showHex2 ((i-0xFE00)+(joinWord16 v 0)) ++ " " ++ showHex1 v) 226 | (readMem m ((i-0xFE00)+(joinWord16 v 0)))) 227 | ) 228 | [0xFE00..0xFE9F]) 229 | } 230 | | a == 0xFF47 = writeRam -- TODO BGP, BG & Window Pallette Data, maybe we need to do some shit here 231 | | a == 0xFF48 = writeRam -- TODO OBP0, Object Palette 0 Data, maybe we need to do some shit here 232 | | a == 0xFF49 = writeRam -- TODO OBP1, Object Palette 1 Data, maybe we need to do some shit here 233 | | a == 0xFF4A = writeRam -- TODO WY, Window Y Position, maybe we need to do some shit here 234 | | a == 0xFF4B = writeRam -- TODO WX, Window X Position, maybe we need to do some shit here 235 | | a >= 0xFF00 && a < 0xFF4C = error ((showHex a) ++ " = " ++ (showHex v) ++ " IO Register NOT IMPLEMENTED") 236 | -- | a == 0xFFFF = if v == 0 then writeRam else error ((showHex a) ++ " = " ++ (showHex v) ++ " IE Register NOT IMPLEMENTED") 237 | | a == 0xFFFF = if v .&. 0x1C == 0 then writeRam else error ("$FFFF IE, Interrupt Enable, not allowed interrupt: " ++ show v)-- TODO IE, Interrupt Enable, maybe do some shit here 238 | | otherwise = writeRam 239 | 240 | where writeRam = (flip const) ("write " ++ showHex2 a ++ " " ++ showHex1 v) (m { memRam = (memRam m)//[(a, v)] }) 241 | 242 | -------------------------------------------------------------------------------- /guis/test03/test03.glade: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | True 8 | OmegaGB 9 | GTK_WINDOW_TOPLEVEL 10 | GTK_WIN_POS_NONE 11 | False 12 | True 13 | False 14 | True 15 | False 16 | False 17 | GDK_WINDOW_TYPE_HINT_NORMAL 18 | GDK_GRAVITY_NORTH_WEST 19 | True 20 | False 21 | 22 | 23 | 24 | True 25 | False 26 | 0 27 | 28 | 29 | 30 | True 31 | GTK_PACK_DIRECTION_LTR 32 | GTK_PACK_DIRECTION_LTR 33 | 34 | 35 | 36 | True 37 | _File 38 | True 39 | 40 | 41 | 42 | 43 | 44 | 45 | True 46 | gtk-open 47 | True 48 | 49 | 50 | 51 | 52 | 53 | 54 | True 55 | 56 | 57 | 58 | 59 | 60 | True 61 | gtk-quit 62 | True 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | True 74 | _Edit 75 | True 76 | 77 | 78 | 79 | 80 | 81 | 82 | True 83 | gtk-cut 84 | True 85 | 86 | 87 | 88 | 89 | 90 | 91 | True 92 | gtk-copy 93 | True 94 | 95 | 96 | 97 | 98 | 99 | 100 | True 101 | gtk-paste 102 | True 103 | 104 | 105 | 106 | 107 | 108 | 109 | True 110 | gtk-delete 111 | True 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | True 123 | _Help 124 | True 125 | 126 | 127 | 128 | 129 | 130 | 131 | True 132 | _About 133 | True 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 0 144 | False 145 | False 146 | 147 | 148 | 149 | 150 | 151 | True 152 | False 153 | 0 154 | 155 | 156 | 157 | 160 158 | 144 159 | True 160 | 161 | 162 | 0 163 | True 164 | False 165 | 166 | 167 | 168 | 169 | 0 170 | True 171 | False 172 | 173 | 174 | 175 | 176 | 177 | True 178 | False 179 | 0 180 | 181 | 182 | 183 | True 184 | False 185 | 0 186 | 187 | 188 | 189 | True 190 | 191 | 192 | 193 | 32 194 | 32 195 | True 196 | True 197 | GTK_RELIEF_NORMAL 198 | True 199 | False 200 | False 201 | 202 | 203 | 204 | True 205 | gtk-go-up 206 | 4 207 | 0.5 208 | 0.5 209 | 0 210 | 0 211 | 212 | 213 | 214 | 215 | 32 216 | 0 217 | 218 | 219 | 220 | 221 | 222 | 32 223 | 32 224 | True 225 | True 226 | GTK_RELIEF_NORMAL 227 | True 228 | False 229 | False 230 | 231 | 232 | 233 | True 234 | gtk-go-back 235 | 4 236 | 0.5 237 | 0.5 238 | 0 239 | 0 240 | 241 | 242 | 243 | 244 | 0 245 | 32 246 | 247 | 248 | 249 | 250 | 251 | 32 252 | 32 253 | True 254 | True 255 | GTK_RELIEF_NORMAL 256 | True 257 | False 258 | False 259 | 260 | 261 | 262 | True 263 | gtk-go-forward 264 | 4 265 | 0.5 266 | 0.5 267 | 0 268 | 0 269 | 270 | 271 | 272 | 273 | 64 274 | 32 275 | 276 | 277 | 278 | 279 | 280 | 32 281 | 32 282 | True 283 | True 284 | GTK_RELIEF_NORMAL 285 | True 286 | False 287 | False 288 | 289 | 290 | 291 | True 292 | gtk-go-down 293 | 4 294 | 0.5 295 | 0.5 296 | 0 297 | 0 298 | 299 | 300 | 301 | 302 | 32 303 | 64 304 | 305 | 306 | 307 | 308 | 309 | 64 310 | 32 311 | True 312 | True 313 | SELECT 314 | True 315 | GTK_RELIEF_NORMAL 316 | True 317 | False 318 | False 319 | 320 | 321 | 24 322 | 104 323 | 324 | 325 | 326 | 327 | 328 | 64 329 | 32 330 | True 331 | True 332 | START 333 | True 334 | GTK_RELIEF_NORMAL 335 | True 336 | False 337 | False 338 | 339 | 340 | 96 341 | 104 342 | 343 | 344 | 345 | 346 | 347 | 32 348 | 32 349 | True 350 | True 351 | B 352 | True 353 | GTK_RELIEF_NORMAL 354 | True 355 | False 356 | False 357 | 358 | 359 | 104 360 | 56 361 | 362 | 363 | 364 | 365 | 366 | 32 367 | 32 368 | True 369 | True 370 | A 371 | True 372 | GTK_RELIEF_NORMAL 373 | True 374 | False 375 | False 376 | 377 | 378 | 144 379 | 56 380 | 381 | 382 | 383 | 384 | 0 385 | True 386 | True 387 | 388 | 389 | 390 | 391 | 4 392 | True 393 | False 394 | 395 | 396 | 397 | 398 | 4 399 | True 400 | False 401 | 402 | 403 | 404 | 405 | 406 | 407 | 408 | -------------------------------------------------------------------------------- /src/GuiTests.hs: -------------------------------------------------------------------------------- 1 | -- OmegaGB Copyright 2007 Bit Connor 2 | -- This program is distributed under the terms of the GNU General Public License 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : GuiTests 6 | -- Copyright : (c) Bit Connor 2007 7 | -- License : GPL 8 | -- Maintainer : bit@mutantlemon.com 9 | -- Stability : in-progress 10 | -- 11 | -- OmegaGB 12 | -- Game Boy Emulator 13 | -- 14 | -- This module runs a gtk+ application that is some sort of Game Boy 15 | -- debugger. It allows you to step through instructions and view the values 16 | -- of registers, and graphics memory. 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module GuiTests where 21 | 22 | import Maybe(fromJust) 23 | import qualified Control.Exception as C 24 | import Data.IORef 25 | import Data.Bits 26 | import Control.Monad 27 | import Data.Array.MArray 28 | import Data.Word 29 | import Data.Int 30 | 31 | import Graphics.UI.Gtk 32 | import Graphics.UI.Gtk.Glade 33 | 34 | import WordUtil 35 | import Machine 36 | import Memory 37 | import RomImage 38 | import CpuExecution 39 | import GuiDrawUtil 40 | 41 | type State = Maybe (((RegisterStates, Memory), IrqStates), Maybe HandlerId) 42 | 43 | test01 :: IO () 44 | test01 = do 45 | initGUI 46 | 47 | windowXml <- C.catch 48 | ((xmlNew gladeFile) >>= return . fromJust) 49 | (\e -> putStrLn ("Error Loading " ++ gladeFile) >> C.throwIO e) 50 | 51 | return () 52 | 53 | let bindWidget x y = xmlGetWidget windowXml x y 54 | window_main <- bindWidget castToWindow "window_main" 55 | menu_open <- bindWidget castToMenuItem "menu_open" 56 | menu_quit <- bindWidget castToMenuItem "menu_quit" 57 | menu_step <- bindWidget castToMenuItem "menu_step" 58 | menu_run <- bindWidget castToMenuItem "menu_run" 59 | menu_pause <- bindWidget castToMenuItem "menu_pause" 60 | menu_about <- bindWidget castToMenuItem "menu_about" 61 | button_open <- bindWidget castToToolButton "button_open" 62 | button_step <- bindWidget castToToolButton "button_step" 63 | button_run <- bindWidget castToToolButton "button_run" 64 | button_pause <- bindWidget castToToolButton "button_pause" 65 | reg_a <- bindWidget castToEntry "reg_a" 66 | reg_b <- bindWidget castToEntry "reg_b" 67 | reg_c <- bindWidget castToEntry "reg_c" 68 | reg_d <- bindWidget castToEntry "reg_d" 69 | reg_e <- bindWidget castToEntry "reg_e" 70 | reg_f <- bindWidget castToEntry "reg_f" 71 | reg_h <- bindWidget castToEntry "reg_h" 72 | reg_l <- bindWidget castToEntry "reg_l" 73 | reg_pc <- bindWidget castToEntry "reg_pc" 74 | reg_sp <- bindWidget castToEntry "reg_sp" 75 | flag_ime <- bindWidget castToCheckButton "flag_ime" 76 | flag_z <- bindWidget castToEntry "flag_z" 77 | flag_n <- bindWidget castToEntry "flag_n" 78 | flag_h <- bindWidget castToEntry "flag_h" 79 | flag_c <- bindWidget castToEntry "flag_c" 80 | reg_ie <- bindWidget castToEntry "reg_ie" 81 | reg_stat <- bindWidget castToEntry "reg_stat" 82 | dissassembler_textview <- bindWidget castToTextView "dissassembler_textview" 83 | main_notebook <- bindWidget castToNotebook "main_notebook" 84 | map_refresh <- bindWidget castToButton "map_refresh" 85 | map_selector <- bindWidget castToComboBox "map_selector" 86 | map_drawingarea <- bindWidget castToDrawingArea "map_drawingarea" 87 | 88 | mapPixBuf <- pixbufNew ColorspaceRgb False 8 256 256 89 | 90 | state <- newIORef (Nothing::State) 91 | 92 | let setStepSensitivity s = mapM_ (`widgetSetSensitivity` s) [toWidget button_step, toWidget menu_step] 93 | setRunSensitivity s = mapM_ (`widgetSetSensitivity` s) [toWidget button_run, toWidget menu_run] 94 | setPauseSensitivity s = mapM_ (`widgetSetSensitivity` s) [toWidget button_pause, toWidget menu_pause] 95 | 96 | ------------------------------------------------------------------------ 97 | 98 | updateRunCommandsSensitivity = do 99 | s <- readIORef state 100 | case s of 101 | Nothing -> do 102 | setStepSensitivity False 103 | setRunSensitivity False 104 | setPauseSensitivity False 105 | Just (_, Nothing) -> do 106 | setStepSensitivity True 107 | setRunSensitivity True 108 | setPauseSensitivity False 109 | Just (_, Just _) -> do 110 | setStepSensitivity False 111 | setRunSensitivity False 112 | setPauseSensitivity True 113 | 114 | ------------------------------------------------------------------------ 115 | 116 | updateDebugPanel = do 117 | s <- readIORef state 118 | case s of 119 | Nothing -> return () 120 | Just (((regS, memS), irqS), _) -> do 121 | reg_a `entrySetText` showHex1 (getRegState regS M_A) 122 | reg_b `entrySetText` showHex1 (getRegState regS M_B) 123 | reg_c `entrySetText` showHex1 (getRegState regS M_C) 124 | reg_d `entrySetText` showHex1 (getRegState regS M_D) 125 | reg_e `entrySetText` showHex1 (getRegState regS M_E) 126 | reg_f `entrySetText` showHex1 (getRegState regS M_F) 127 | reg_h `entrySetText` showHex1 (getRegState regS M_H) 128 | reg_l `entrySetText` showHex1 (getRegState regS M_L) 129 | reg_pc `entrySetText` showHex2 (getReg2State regS M_PC) 130 | reg_sp `entrySetText` showHex2 (getReg2State regS M_SP) 131 | reg_ie `entrySetText` showHex1 (readMem memS 0xFFFF) 132 | --reg_stat `entrySetText` showHex1 (readMem memS 0xFF41) 133 | flag_ime `toggleButtonSetActive` irqStateIME irqS 134 | flag_z `entrySetText` show (fromEnum (testBit (getRegState regS M_F) 7)) 135 | flag_n `entrySetText` show (fromEnum (testBit (getRegState regS M_F) 6)) 136 | flag_h `entrySetText` show (fromEnum (testBit (getRegState regS M_F) 5)) 137 | flag_c `entrySetText` show (fromEnum (testBit (getRegState regS M_F) 4)) 138 | 139 | ------------------------------------------------------------------------ 140 | 141 | displayCurrentInstruction = do 142 | s <- readIORef state 143 | case s of 144 | Nothing -> return () 145 | Just (((regS, memS), _), _) -> do 146 | let pc = getReg2State regS M_PC 147 | let instruction = fetchInstruction (regS, memS) 148 | let s = (showHex2 pc) ++ " " ++ (show instruction) ++ "\n" 149 | buffer <- textViewGetBuffer dissassembler_textview 150 | n <- textBufferGetLineCount buffer 151 | when (n > instructionHistoryCount) 152 | (do iterStart <- textBufferGetStartIter buffer 153 | iter1 <- textBufferGetIterAtLine buffer 1 154 | textBufferDelete buffer iterStart iter1) 155 | endIter <- textBufferGetEndIter buffer 156 | textBufferInsert buffer endIter s 157 | 158 | ------------------------------------------------------------------------ 159 | 160 | clearInstructionDisplay = do 161 | buffer <- textViewGetBuffer dissassembler_textview 162 | startIter <- textBufferGetStartIter buffer 163 | endIter <- textBufferGetEndIter buffer 164 | textBufferDelete buffer startIter endIter 165 | 166 | ------------------------------------------------------------------------ 167 | 168 | step = do 169 | modifyIORef state (\s -> case s of 170 | Nothing -> Nothing 171 | Just (m, b) -> Just (updateMachine m, b)) 172 | updateDebugPanel 173 | displayCurrentInstruction 174 | 175 | ------------------------------------------------------------------------ 176 | 177 | run = do 178 | handlerId <- idleAdd (replicateM_ 100 step >> return True) priorityDefaultIdle 179 | modifyIORef state (\s -> case s of 180 | Nothing -> Nothing 181 | Just (m, _) -> Just (m, Just handlerId)) 182 | updateRunCommandsSensitivity 183 | 184 | ------------------------------------------------------------------------ 185 | 186 | pause = do 187 | s <- readIORef state 188 | case s of 189 | Nothing -> return () 190 | Just (_, Nothing) -> return () 191 | Just (_, Just handlerId) -> idleRemove handlerId 192 | modifyIORef state (\s -> case s of 193 | Nothing -> Nothing 194 | Just (m, _) -> Just (m, Nothing)) 195 | updateRunCommandsSensitivity 196 | 197 | ------------------------------------------------------------------------ 198 | 199 | open = do 200 | fileSelect <- fileChooserDialogNew 201 | (Just "Open Game Boy ROM") 202 | (Just window_main) 203 | FileChooserActionOpen 204 | [("gtk-open", ResponseOk), ("gtk-cancel", ResponseDeleteEvent)] 205 | response <- dialogRun fileSelect 206 | case response of 207 | ResponseOk -> do 208 | romFile <- fileChooserGetFilename fileSelect 209 | romImage <- loadRomImage (fromJust romFile) 210 | writeIORef state $ Just (((initialRegisterStates, initMemory romImage), 211 | initialIrqStates), 212 | Nothing) 213 | ResponseDeleteEvent -> do 214 | return () 215 | widgetDestroy fileSelect 216 | updateRunCommandsSensitivity 217 | updateDebugPanel 218 | clearInstructionDisplay 219 | displayCurrentInstruction 220 | 221 | ------------------------------------------------------------------------ 222 | 223 | quit = widgetDestroy window_main >> mainQuit 224 | 225 | ------------------------------------------------------------------------ 226 | 227 | getMapViewerSelection :: IO Int 228 | getMapViewerSelection = comboBoxGetActive map_selector >>= return . fromJust 229 | 230 | ------------------------------------------------------------------------ 231 | 232 | refreshMapViewer = do 233 | s <- readIORef state 234 | case s of 235 | Nothing -> return () 236 | Just (((_, mem), _), _) -> do 237 | pbData <- (pixbufGetPixels mapPixBuf :: IO (PixbufData Int Word8)) 238 | row <- pixbufGetRowstride mapPixBuf 239 | chan <- pixbufGetNChannels mapPixBuf 240 | bits <- pixbufGetBitsPerSample mapPixBuf 241 | 242 | -- draw into the Pixbuf 243 | 244 | mvs <- getMapViewerSelection 245 | case mvs of 246 | 0 -> do 247 | doFromTo 0 63 $ \y -> 248 | doFromTo 0 255 $ \x -> do 249 | let yrow = y `div` 8 250 | xrow = x `div` 8 251 | tileNum = yrow * 32 + xrow 252 | tileStartMem = 0x8000 + (16 * tileNum) 253 | xoff = 7 - (x `mod` 8) 254 | yoff = y `mod` 8 255 | hiByte = tileStartMem + (yoff * 2) 256 | loByte = tileStartMem + (yoff * 2) + 1 257 | hiByteValue = readMem mem (fromIntegral hiByte) 258 | loByteValue = readMem mem (fromIntegral loByte) 259 | color = (2 * (fromEnum (testBit loByteValue xoff))) + (fromEnum (testBit hiByteValue xoff)) 260 | colorByte = (fromIntegral color) * 85 261 | writeArray pbData (x*chan+y*row) colorByte 262 | writeArray pbData (1+x*chan+y*row) colorByte 263 | writeArray pbData (2+x*chan+y*row) colorByte 264 | 265 | doFromTo 64 127 $ \y -> 266 | doFromTo 0 255 $ \x -> do 267 | let yrow = (y-64) `div` 8 268 | xrow = x `div` 8 269 | tileNum = yrow * 32 + xrow 270 | tileStartMem = 0x8F00 + (16 * tileNum) 271 | xoff = 7 - (x `mod` 8) 272 | yoff = (y-64) `mod` 8 273 | hiByte = tileStartMem + (yoff * 2) 274 | loByte = tileStartMem + (yoff * 2) + 1 275 | hiByteValue = readMem mem (fromIntegral hiByte) 276 | loByteValue = readMem mem (fromIntegral loByte) 277 | color = (2 * (fromEnum (testBit loByteValue xoff))) + (fromEnum (testBit hiByteValue xoff)) 278 | colorByte = (fromIntegral color) * 85 279 | writeArray pbData (x*chan+y*row) colorByte 280 | writeArray pbData (1+x*chan+y*row) colorByte 281 | writeArray pbData (2+x*chan+y*row) colorByte 282 | 1 -> do 283 | doFromTo 0 255 $ \y -> 284 | doFromTo 0 255 $ \x -> do 285 | let yrow = y `div` 8 286 | xrow = x `div` 8 287 | tileNum = yrow * 32 + xrow 288 | tileIndex = readMem mem ((fromIntegral tileNum) + 0x9800) 289 | tileStartMem = 0x8000 + (16 * (fromIntegral tileIndex)) 290 | xoff = 7 - (x `mod` 8) 291 | yoff = y `mod` 8 292 | hiByte = tileStartMem + (yoff * 2) 293 | loByte = tileStartMem + (yoff * 2) + 1 294 | hiByteValue = readMem mem (fromIntegral hiByte) 295 | loByteValue = readMem mem (fromIntegral loByte) 296 | color = (2 * (fromEnum (testBit loByteValue xoff))) + (fromEnum (testBit hiByteValue xoff)) 297 | colorByte = (fromIntegral color) * 85 298 | writeArray pbData (x*chan+y*row) colorByte 299 | writeArray pbData (1+x*chan+y*row) colorByte 300 | writeArray pbData (2+x*chan+y*row) colorByte 301 | 2 -> do 302 | doFromTo 0 255 $ \y -> 303 | doFromTo 0 255 $ \x -> do 304 | let yrow = y `div` 8 305 | xrow = x `div` 8 306 | tileNum = yrow * 32 + xrow 307 | tileIndex = (fromIntegral (readMem mem ((fromIntegral tileNum) + 0x9800)))::Int8 308 | tileStartMem = 0x9000 + (16 * (fromIntegral tileIndex)) 309 | xoff = 7 - (x `mod` 8) 310 | yoff = y `mod` 8 311 | hiByte = tileStartMem + (yoff * 2) 312 | loByte = tileStartMem + (yoff * 2) + 1 313 | hiByteValue = readMem mem (fromIntegral hiByte) 314 | loByteValue = readMem mem (fromIntegral loByte) 315 | color = (2 * (fromEnum (testBit loByteValue xoff))) + (fromEnum (testBit hiByteValue xoff)) 316 | colorByte = (fromIntegral color) * 85 317 | writeArray pbData (x*chan+y*row) colorByte 318 | writeArray pbData (1+x*chan+y*row) colorByte 319 | writeArray pbData (2+x*chan+y*row) colorByte 320 | 321 | 322 | widgetQueueDraw map_drawingarea 323 | 324 | ------------------------------------------------------------------------ 325 | 326 | comboBoxSetActive map_selector 0 327 | 328 | menu_quit `onActivateLeaf` quit 329 | window_main `onDestroy` quit 330 | 331 | menu_open `onActivateLeaf` open 332 | button_open `onToolButtonClicked` open 333 | 334 | menu_step `onActivateLeaf` step 335 | button_step `onToolButtonClicked` step 336 | 337 | menu_run `onActivateLeaf` run 338 | button_run `onToolButtonClicked` run 339 | 340 | menu_pause `onActivateLeaf` pause 341 | button_pause `onToolButtonClicked` pause 342 | 343 | menu_about `onActivateLeaf` do 344 | dia <- aboutDialogNew 345 | aboutDialogSetName dia "OmegaGB test01" 346 | aboutDialogSetComments dia "Game Boy Emulator Development Test" 347 | aboutDialogSetWebsite dia "http://www.mutantlemon.com/omegagb" 348 | dialogRun dia 349 | widgetDestroy dia 350 | 351 | map_drawingarea `onSizeRequest` return (Requisition 256 256) 352 | map_drawingarea `onExpose` updateCanvas map_drawingarea mapPixBuf 353 | 354 | map_refresh `onClicked` refreshMapViewer 355 | main_notebook `onSwitchPage` (\pageNum -> when (pageNum == 1) refreshMapViewer) 356 | map_selector `onChanged` refreshMapViewer 357 | 358 | updateRunCommandsSensitivity 359 | 360 | -- C.catchJust C.errorCalls 361 | -- mainGUI 362 | -- (\e -> do 363 | -- dia <- dialogNew 364 | -- windowSetTitle dia "Error" 365 | -- dialogAddButton dia "gtk-ok" ResponseOk 366 | -- upper <- dialogGetUpper dia 367 | -- message <- labelNew (Just ("Error: " ++ (show e))) 368 | -- widgetShow message 369 | -- boxPackStartDefaults upper message 370 | -- dialogRun dia 371 | -- widgetDestroy dia) 372 | 373 | mainGUI 374 | return () 375 | 376 | where 377 | gladeFile = "guis/test01/test01.glade" 378 | instructionHistoryCount = 20 379 | 380 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 2, June 1991 3 | 4 | Copyright (C) 1989, 1991 Free Software Foundation, Inc., 5 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | Preamble 10 | 11 | The licenses for most software are designed to take away your 12 | freedom to share and change it. By contrast, the GNU General Public 13 | License is intended to guarantee your freedom to share and change free 14 | software--to make sure the software is free for all its users. This 15 | General Public License applies to most of the Free Software 16 | Foundation's software and to any other program whose authors commit to 17 | using it. (Some other Free Software Foundation software is covered by 18 | the GNU Lesser General Public License instead.) You can apply it to 19 | your programs, too. 20 | 21 | When we speak of free software, we are referring to freedom, not 22 | price. Our General Public Licenses are designed to make sure that you 23 | have the freedom to distribute copies of free software (and charge for 24 | this service if you wish), that you receive source code or can get it 25 | if you want it, that you can change the software or use pieces of it 26 | in new free programs; and that you know you can do these things. 27 | 28 | To protect your rights, we need to make restrictions that forbid 29 | anyone to deny you these rights or to ask you to surrender the rights. 30 | These restrictions translate to certain responsibilities for you if you 31 | distribute copies of the software, or if you modify it. 32 | 33 | For example, if you distribute copies of such a program, whether 34 | gratis or for a fee, you must give the recipients all the rights that 35 | you have. You must make sure that they, too, receive or can get the 36 | source code. And you must show them these terms so they know their 37 | rights. 38 | 39 | We protect your rights with two steps: (1) copyright the software, and 40 | (2) offer you this license which gives you legal permission to copy, 41 | distribute and/or modify the software. 42 | 43 | Also, for each author's protection and ours, we want to make certain 44 | that everyone understands that there is no warranty for this free 45 | software. If the software is modified by someone else and passed on, we 46 | want its recipients to know that what they have is not the original, so 47 | that any problems introduced by others will not reflect on the original 48 | authors' reputations. 49 | 50 | Finally, any free program is threatened constantly by software 51 | patents. We wish to avoid the danger that redistributors of a free 52 | program will individually obtain patent licenses, in effect making the 53 | program proprietary. To prevent this, we have made it clear that any 54 | patent must be licensed for everyone's free use or not licensed at all. 55 | 56 | The precise terms and conditions for copying, distribution and 57 | modification follow. 58 | 59 | GNU GENERAL PUBLIC LICENSE 60 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 61 | 62 | 0. This License applies to any program or other work which contains 63 | a notice placed by the copyright holder saying it may be distributed 64 | under the terms of this General Public License. The "Program", below, 65 | refers to any such program or work, and a "work based on the Program" 66 | means either the Program or any derivative work under copyright law: 67 | that is to say, a work containing the Program or a portion of it, 68 | either verbatim or with modifications and/or translated into another 69 | language. (Hereinafter, translation is included without limitation in 70 | the term "modification".) Each licensee is addressed as "you". 71 | 72 | Activities other than copying, distribution and modification are not 73 | covered by this License; they are outside its scope. The act of 74 | running the Program is not restricted, and the output from the Program 75 | is covered only if its contents constitute a work based on the 76 | Program (independent of having been made by running the Program). 77 | Whether that is true depends on what the Program does. 78 | 79 | 1. You may copy and distribute verbatim copies of the Program's 80 | source code as you receive it, in any medium, provided that you 81 | conspicuously and appropriately publish on each copy an appropriate 82 | copyright notice and disclaimer of warranty; keep intact all the 83 | notices that refer to this License and to the absence of any warranty; 84 | and give any other recipients of the Program a copy of this License 85 | along with the Program. 86 | 87 | You may charge a fee for the physical act of transferring a copy, and 88 | you may at your option offer warranty protection in exchange for a fee. 89 | 90 | 2. You may modify your copy or copies of the Program or any portion 91 | of it, thus forming a work based on the Program, and copy and 92 | distribute such modifications or work under the terms of Section 1 93 | above, provided that you also meet all of these conditions: 94 | 95 | a) You must cause the modified files to carry prominent notices 96 | stating that you changed the files and the date of any change. 97 | 98 | b) You must cause any work that you distribute or publish, that in 99 | whole or in part contains or is derived from the Program or any 100 | part thereof, to be licensed as a whole at no charge to all third 101 | parties under the terms of this License. 102 | 103 | c) If the modified program normally reads commands interactively 104 | when run, you must cause it, when started running for such 105 | interactive use in the most ordinary way, to print or display an 106 | announcement including an appropriate copyright notice and a 107 | notice that there is no warranty (or else, saying that you provide 108 | a warranty) and that users may redistribute the program under 109 | these conditions, and telling the user how to view a copy of this 110 | License. (Exception: if the Program itself is interactive but 111 | does not normally print such an announcement, your work based on 112 | the Program is not required to print an announcement.) 113 | 114 | These requirements apply to the modified work as a whole. If 115 | identifiable sections of that work are not derived from the Program, 116 | and can be reasonably considered independent and separate works in 117 | themselves, then this License, and its terms, do not apply to those 118 | sections when you distribute them as separate works. But when you 119 | distribute the same sections as part of a whole which is a work based 120 | on the Program, the distribution of the whole must be on the terms of 121 | this License, whose permissions for other licensees extend to the 122 | entire whole, and thus to each and every part regardless of who wrote it. 123 | 124 | Thus, it is not the intent of this section to claim rights or contest 125 | your rights to work written entirely by you; rather, the intent is to 126 | exercise the right to control the distribution of derivative or 127 | collective works based on the Program. 128 | 129 | In addition, mere aggregation of another work not based on the Program 130 | with the Program (or with a work based on the Program) on a volume of 131 | a storage or distribution medium does not bring the other work under 132 | the scope of this License. 133 | 134 | 3. You may copy and distribute the Program (or a work based on it, 135 | under Section 2) in object code or executable form under the terms of 136 | Sections 1 and 2 above provided that you also do one of the following: 137 | 138 | a) Accompany it with the complete corresponding machine-readable 139 | source code, which must be distributed under the terms of Sections 140 | 1 and 2 above on a medium customarily used for software interchange; or, 141 | 142 | b) Accompany it with a written offer, valid for at least three 143 | years, to give any third party, for a charge no more than your 144 | cost of physically performing source distribution, a complete 145 | machine-readable copy of the corresponding source code, to be 146 | distributed under the terms of Sections 1 and 2 above on a medium 147 | customarily used for software interchange; or, 148 | 149 | c) Accompany it with the information you received as to the offer 150 | to distribute corresponding source code. (This alternative is 151 | allowed only for noncommercial distribution and only if you 152 | received the program in object code or executable form with such 153 | an offer, in accord with Subsection b above.) 154 | 155 | The source code for a work means the preferred form of the work for 156 | making modifications to it. For an executable work, complete source 157 | code means all the source code for all modules it contains, plus any 158 | associated interface definition files, plus the scripts used to 159 | control compilation and installation of the executable. However, as a 160 | special exception, the source code distributed need not include 161 | anything that is normally distributed (in either source or binary 162 | form) with the major components (compiler, kernel, and so on) of the 163 | operating system on which the executable runs, unless that component 164 | itself accompanies the executable. 165 | 166 | If distribution of executable or object code is made by offering 167 | access to copy from a designated place, then offering equivalent 168 | access to copy the source code from the same place counts as 169 | distribution of the source code, even though third parties are not 170 | compelled to copy the source along with the object code. 171 | 172 | 4. You may not copy, modify, sublicense, or distribute the Program 173 | except as expressly provided under this License. Any attempt 174 | otherwise to copy, modify, sublicense or distribute the Program is 175 | void, and will automatically terminate your rights under this License. 176 | However, parties who have received copies, or rights, from you under 177 | this License will not have their licenses terminated so long as such 178 | parties remain in full compliance. 179 | 180 | 5. You are not required to accept this License, since you have not 181 | signed it. However, nothing else grants you permission to modify or 182 | distribute the Program or its derivative works. These actions are 183 | prohibited by law if you do not accept this License. Therefore, by 184 | modifying or distributing the Program (or any work based on the 185 | Program), you indicate your acceptance of this License to do so, and 186 | all its terms and conditions for copying, distributing or modifying 187 | the Program or works based on it. 188 | 189 | 6. Each time you redistribute the Program (or any work based on the 190 | Program), the recipient automatically receives a license from the 191 | original licensor to copy, distribute or modify the Program subject to 192 | these terms and conditions. You may not impose any further 193 | restrictions on the recipients' exercise of the rights granted herein. 194 | You are not responsible for enforcing compliance by third parties to 195 | this License. 196 | 197 | 7. If, as a consequence of a court judgment or allegation of patent 198 | infringement or for any other reason (not limited to patent issues), 199 | conditions are imposed on you (whether by court order, agreement or 200 | otherwise) that contradict the conditions of this License, they do not 201 | excuse you from the conditions of this License. If you cannot 202 | distribute so as to satisfy simultaneously your obligations under this 203 | License and any other pertinent obligations, then as a consequence you 204 | may not distribute the Program at all. For example, if a patent 205 | license would not permit royalty-free redistribution of the Program by 206 | all those who receive copies directly or indirectly through you, then 207 | the only way you could satisfy both it and this License would be to 208 | refrain entirely from distribution of the Program. 209 | 210 | If any portion of this section is held invalid or unenforceable under 211 | any particular circumstance, the balance of the section is intended to 212 | apply and the section as a whole is intended to apply in other 213 | circumstances. 214 | 215 | It is not the purpose of this section to induce you to infringe any 216 | patents or other property right claims or to contest validity of any 217 | such claims; this section has the sole purpose of protecting the 218 | integrity of the free software distribution system, which is 219 | implemented by public license practices. Many people have made 220 | generous contributions to the wide range of software distributed 221 | through that system in reliance on consistent application of that 222 | system; it is up to the author/donor to decide if he or she is willing 223 | to distribute software through any other system and a licensee cannot 224 | impose that choice. 225 | 226 | This section is intended to make thoroughly clear what is believed to 227 | be a consequence of the rest of this License. 228 | 229 | 8. If the distribution and/or use of the Program is restricted in 230 | certain countries either by patents or by copyrighted interfaces, the 231 | original copyright holder who places the Program under this License 232 | may add an explicit geographical distribution limitation excluding 233 | those countries, so that distribution is permitted only in or among 234 | countries not thus excluded. In such case, this License incorporates 235 | the limitation as if written in the body of this License. 236 | 237 | 9. The Free Software Foundation may publish revised and/or new versions 238 | of the General Public License from time to time. Such new versions will 239 | be similar in spirit to the present version, but may differ in detail to 240 | address new problems or concerns. 241 | 242 | Each version is given a distinguishing version number. If the Program 243 | specifies a version number of this License which applies to it and "any 244 | later version", you have the option of following the terms and conditions 245 | either of that version or of any later version published by the Free 246 | Software Foundation. If the Program does not specify a version number of 247 | this License, you may choose any version ever published by the Free Software 248 | Foundation. 249 | 250 | 10. If you wish to incorporate parts of the Program into other free 251 | programs whose distribution conditions are different, write to the author 252 | to ask for permission. For software which is copyrighted by the Free 253 | Software Foundation, write to the Free Software Foundation; we sometimes 254 | make exceptions for this. Our decision will be guided by the two goals 255 | of preserving the free status of all derivatives of our free software and 256 | of promoting the sharing and reuse of software generally. 257 | 258 | NO WARRANTY 259 | 260 | 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 261 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 262 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 263 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 264 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 265 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 266 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 267 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 268 | REPAIR OR CORRECTION. 269 | 270 | 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 271 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 272 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 273 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 274 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 275 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 276 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 277 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 278 | POSSIBILITY OF SUCH DAMAGES. 279 | 280 | END OF TERMS AND CONDITIONS 281 | 282 | How to Apply These Terms to Your New Programs 283 | 284 | If you develop a new program, and you want it to be of the greatest 285 | possible use to the public, the best way to achieve this is to make it 286 | free software which everyone can redistribute and change under these terms. 287 | 288 | To do so, attach the following notices to the program. It is safest 289 | to attach them to the start of each source file to most effectively 290 | convey the exclusion of warranty; and each file should have at least 291 | the "copyright" line and a pointer to where the full notice is found. 292 | 293 | 294 | Copyright (C) 295 | 296 | This program is free software; you can redistribute it and/or modify 297 | it under the terms of the GNU General Public License as published by 298 | the Free Software Foundation; either version 2 of the License, or 299 | (at your option) any later version. 300 | 301 | This program is distributed in the hope that it will be useful, 302 | but WITHOUT ANY WARRANTY; without even the implied warranty of 303 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 304 | GNU General Public License for more details. 305 | 306 | You should have received a copy of the GNU General Public License along 307 | with this program; if not, write to the Free Software Foundation, Inc., 308 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 309 | 310 | Also add information on how to contact you by electronic and paper mail. 311 | 312 | If the program is interactive, make it output a short notice like this 313 | when it starts in an interactive mode: 314 | 315 | Gnomovision version 69, Copyright (C) year name of author 316 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 317 | This is free software, and you are welcome to redistribute it 318 | under certain conditions; type `show c' for details. 319 | 320 | The hypothetical commands `show w' and `show c' should show the appropriate 321 | parts of the General Public License. Of course, the commands you use may 322 | be called something other than `show w' and `show c'; they could even be 323 | mouse-clicks or menu items--whatever suits your program. 324 | 325 | You should also get your employer (if you work as a programmer) or your 326 | school, if any, to sign a "copyright disclaimer" for the program, if 327 | necessary. Here is a sample; alter the names: 328 | 329 | Yoyodyne, Inc., hereby disclaims all copyright interest in the program 330 | `Gnomovision' (which makes passes at compilers) written by James Hacker. 331 | 332 | , 1 April 1989 333 | Ty Coon, President of Vice 334 | 335 | This General Public License does not permit incorporating your program into 336 | proprietary programs. If your program is a subroutine library, you may 337 | consider it more useful to permit linking proprietary applications with the 338 | library. If this is what you want to do, use the GNU Lesser General 339 | Public License instead of this License. 340 | -------------------------------------------------------------------------------- /src/Machine.hs: -------------------------------------------------------------------------------- 1 | -- OmegaGB Copyright 2007 Bit Connor 2 | -- This program is distributed under the terms of the GNU General Public License 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Machine 6 | -- Copyright : (c) Bit Connor 2007 7 | -- License : GPL 8 | -- Maintainer : bit@mutantlemon.com 9 | -- Stability : in-progress 10 | -- 11 | -- OmegaGB 12 | -- Game Boy Emulator 13 | -- 14 | -- This module does emulation of a lot of the Game Boy's hardware, including 15 | -- interrupts and graphics rendering. It's still incomplete. 16 | -- 17 | -- The complete state of all of the GameBoy is represented as the tuple: 18 | -- ((RegisterStates, Memory), IrqStates) 19 | -- 20 | ----------------------------------------------------------------------------- 21 | 22 | module Machine where 23 | --import Prerequisites 24 | 25 | import Data.Array.IArray 26 | import Data.Word 27 | import Data.Int 28 | import Data.Bits 29 | import Data.Maybe 30 | import Data.List 31 | import Control.Monad.State 32 | 33 | import WordUtil 34 | import Cpu 35 | import CpuExecution 36 | import Memory 37 | import Display 38 | import Joypad 39 | 40 | import Debug.Trace 41 | 42 | --cpuClockFrequency :: Double 43 | --cpuClockFrequency = 4194304 44 | 45 | --horizSync :: Double 46 | --horizSync = 9198000 47 | 48 | --vertSync :: Double 49 | --vertSync = 59.73 50 | 51 | --vblankPeriod = cpuClockFrequency / vertSync 52 | 53 | --scanlinePeriod = vblankPeriod / 153 54 | 55 | type RegisterStates = (Word8, -- A 56 | Word8, -- B 57 | Word8, -- C 58 | Word8, -- D 59 | Word8, -- E 60 | Word8, -- F 61 | Word8, -- H 62 | Word8, -- L 63 | Word16, -- PC 64 | Word16) -- SP 65 | 66 | getRegState :: RegisterStates -> M_Register -> Word8 67 | getRegState rs r = 68 | let (a, b, c, d, e, f, h, l, _, _) = rs in 69 | case r of 70 | M_A -> a 71 | M_B -> b 72 | M_C -> c 73 | M_D -> d 74 | M_E -> e 75 | M_F -> f 76 | M_H -> h 77 | M_L -> l 78 | 79 | setRegState :: RegisterStates -> M_Register -> Word8 -> RegisterStates 80 | setRegState rs r n = 81 | let (a, b, c, d, e, f, h, l, pc, sp) = rs in 82 | case r of 83 | M_A -> (n, b, c, d, e, f, h, l, pc, sp) 84 | M_B -> (a, n, c, d, e, f, h, l, pc, sp) 85 | M_C -> (a, b, n, d, e, f, h, l, pc, sp) 86 | M_D -> (a, b, c, n, e, f, h, l, pc, sp) 87 | M_E -> (a, b, c, d, n, f, h, l, pc, sp) 88 | M_F -> (a, b, c, d, e, n.&.0xF0, h, l, pc, sp) 89 | M_H -> (a, b, c, d, e, f, n, l, pc, sp) 90 | M_L -> (a, b, c, d, e, f, h, n, pc, sp) 91 | 92 | getReg2State :: RegisterStates -> M_Register2 -> Word16 93 | getReg2State rs r2 = 94 | let (a, b, c, d, e, f, h, l, pc, sp) = rs in 95 | case r2 of 96 | M_AF -> joinWord16 a f 97 | M_BC -> joinWord16 b c 98 | M_DE -> joinWord16 d e 99 | M_HL -> joinWord16 h l 100 | M_PC -> pc 101 | M_SP -> sp 102 | 103 | setReg2State :: RegisterStates -> M_Register2 -> Word16 -> RegisterStates 104 | setReg2State rs r2 nn = 105 | let (a, b, c, d, e, f, h, l, pc, sp) = rs 106 | (hi, lo) = splitWord16 nn in 107 | case r2 of 108 | M_AF -> (hi, b, c, d, e, lo.&.0xF0, h, l, pc, sp) 109 | M_BC -> (a, hi, lo, d, e, f, h, l, pc, sp) 110 | M_DE -> (a, b, c, hi, lo, f, h, l, pc, sp) 111 | M_HL -> (a, b, c, d, e, f, hi, lo, pc, sp) 112 | M_PC -> (a, b, c, d, e, f, h, l, nn, sp) 113 | M_SP -> (a, b, c, d, e, f, h, l, pc, nn) 114 | 115 | initialA_GB, initialA_GBP, initialA_GBC :: Word8 116 | initialA_GB = 0x01 117 | initialA_GBP = 0xFF 118 | initialA_GBC = 0x11 119 | 120 | initialRegisterStates :: RegisterStates 121 | initialRegisterStates = 122 | (initialA_GB, -- A 123 | 0x00, -- B 124 | 0x13, -- C 125 | 0x00, -- D 126 | 0xD8, -- E 127 | 0xB0, -- F 128 | 0x01, -- H 129 | 0x4D, -- L 130 | 0x0100, -- PC 131 | 0xFFFE) -- SP 132 | 133 | vBlankPeriod = 70224 134 | hBlankPeriod = 456 135 | 136 | divPeriod = 256 137 | 138 | data IrqStates = IrqStates { 139 | irqStateIME :: Bool, -- Interrupt Master Enable 140 | irqStateVBlankCounter :: Int, -- CPU cycles until next V-Blank (mode1) 141 | irqStateHBlankCounter :: Int, -- CPU cycles until next H-Blank (mode2) 142 | irqStateHBlankMode3Counter :: Int, -- CPU cycles until next H-Blank mode3 cycle 143 | irqStateHBlankMode0Counter :: Int, -- CPU cycles until next H-Blank mode0 cycle 144 | irqStateCurrentScanline :: Int, -- Current scanline, 0-153 145 | irqStateDisplay :: Display, -- LCD Display pixels 146 | irqStateVBlankNow :: Bool, -- VBlank happened right now at the current instruction 147 | irqStateDIVCounter :: Int -- DIV register 148 | } 149 | 150 | initialIrqStates = IrqStates { 151 | irqStateIME = False, 152 | irqStateVBlankCounter = 0, 153 | irqStateHBlankCounter = 0, 154 | irqStateHBlankMode3Counter = 80, 155 | irqStateHBlankMode0Counter = (80 + 172), 156 | irqStateCurrentScanline = 153, 157 | irqStateDisplay = blankDisplay, 158 | irqStateVBlankNow = False, 159 | irqStateDIVCounter = 0 160 | } 161 | 162 | irqUpdate :: CycleCount -> 163 | Maybe Bool -> 164 | ((RegisterStates, Memory), IrqStates) -> 165 | ((RegisterStates, Memory), IrqStates) 166 | irqUpdate cycles ime = execState $ do 167 | when (isJust ime) (modify $ transformIrq (\i -> i { irqStateIME = fromJust ime })) 168 | let updateCounters i = i { irqStateVBlankCounter = (irqStateVBlankCounter i) - cycles, 169 | irqStateHBlankCounter = (irqStateHBlankCounter i) - cycles, 170 | irqStateHBlankMode3Counter = (irqStateHBlankMode3Counter i) - cycles, 171 | irqStateHBlankMode0Counter = (irqStateHBlankMode0Counter i) - cycles, 172 | irqStateDIVCounter = (irqStateDIVCounter i) - cycles } 173 | modify $ transformIrq updateCounters 174 | 175 | modify $ transformIrq (\i -> i { irqStateVBlankNow = (irqStateVBlankCounter i) <= 0 }) 176 | 177 | (_, irq) <- get 178 | when ((irqStateHBlankCounter irq) <= 0) 179 | (do modify $ transformIrq (\i -> i { irqStateHBlankCounter = (irqStateHBlankCounter i) + hBlankPeriod }) 180 | modify tickHBlank) 181 | when ((irqStateHBlankMode3Counter irq) <= 0) 182 | (do modify $ transformIrq (\i -> i { irqStateHBlankMode3Counter = (irqStateHBlankMode3Counter i) + hBlankPeriod }) 183 | modify tickHBlankMode3) 184 | when ((irqStateHBlankMode0Counter irq) <= 0) 185 | (do modify $ transformIrq (\i -> i { irqStateHBlankMode0Counter = (irqStateHBlankMode0Counter i) + hBlankPeriod }) 186 | modify tickHBlankMode0) 187 | when ((irqStateVBlankCounter irq) <= 0) 188 | (do modify $ transformIrq (\i -> i { irqStateVBlankCounter = (irqStateVBlankCounter i) + vBlankPeriod }) 189 | modify tickVBlank) 190 | when ((irqStateDIVCounter irq) <= 0) 191 | (do modify $ transformIrq (\i -> i { irqStateDIVCounter = (irqStateDIVCounter i) + divPeriod }) 192 | modify tickDIV) 193 | 194 | ((_, mem), irq2) <- get 195 | let ime = irqStateIME irq2 196 | flagsIF = (memRam mem)!0xFF0F 197 | flagsIE = (memRam mem)!0xFFFF 198 | when (ime && (flagsIF .&. flagsIE > 0)) 199 | (let i = getLowBit (flagsIF .&. flagsIE) 200 | jumpAddr = case i of 201 | 0 -> 0x0040 202 | 1 -> 0x0048 203 | 2 -> 0x0050 204 | 3 -> 0x0058 205 | 4 -> 0x0060 in 206 | do modify $ transformIrq (\i -> i { irqStateIME = False }) 207 | modify $ transformMem (transformMemoryAddr (`clearBit` i) 0xFF0F) 208 | ((reg, mem), _) <- get 209 | let oldPC = getReg2State reg M_PC 210 | (hiPC, loPC) = splitWord16 oldPC 211 | oldSP = getReg2State reg M_SP 212 | (flip const) (showHex2 oldSP) (modify $ transformMem ( \m -> writeMem (writeMem m (oldSP-1) hiPC) (oldSP-2) loPC )) 213 | modify $ transformReg (\r -> setReg2State r M_SP (oldSP-2)) 214 | modify $ transformReg (\r -> setReg2State r M_PC jumpAddr) 215 | return ()) 216 | 217 | where getLowBit :: Word8 -> Int 218 | getLowBit n = fromJust (elemIndex True (map (testBit n) [0..4])) 219 | 220 | transformReg :: (RegisterStates -> RegisterStates) -> 221 | ((RegisterStates, Memory), IrqStates) -> 222 | ((RegisterStates, Memory), IrqStates) 223 | transformReg t ((r, m), i) = ((t r, m), i) 224 | 225 | transformMem :: (Memory -> Memory) -> 226 | ((RegisterStates, Memory), IrqStates) -> 227 | ((RegisterStates, Memory), IrqStates) 228 | transformMem t ((r, m), i) = ((r, t m), i) 229 | 230 | transformIrq :: (IrqStates -> IrqStates) -> 231 | ((RegisterStates, Memory), IrqStates) -> 232 | ((RegisterStates, Memory), IrqStates) 233 | transformIrq t ((r, m), i) = ((r, m), t i) 234 | 235 | transformMemoryAddr :: (Word8 -> Word8) -> Word16 -> Memory -> Memory 236 | transformMemoryAddr t a m = m { memRam = (memRam m)//[(a, (t ((memRam m)!a)))] } 237 | 238 | tickHBlank :: ((RegisterStates, Memory), IrqStates) -> ((RegisterStates, Memory), IrqStates) 239 | tickHBlank = execState $ do 240 | let incrementLY = transformMemoryAddr ((`mod` 154).(+1)) 0xFF44 241 | modify $ transformMem incrementLY 242 | modify $ transformIrq (\i -> i { irqStateCurrentScanline = (((`mod` 154).(+1)) (irqStateCurrentScanline i)) } ) 243 | ((_, _), irq) <- get 244 | when ((irqStateCurrentScanline irq) < 144) $ do 245 | ((_, mem), _) <- get 246 | let (ly, lyc) = ((memRam mem)!0xFF44, (memRam mem)!0xFF45) 247 | (statB5, statB6) = ((memRam mem)!0xFF41 `testBit` 5, (memRam mem)!0xFF41 `testBit` 6) 248 | updateSTATFlags = transformMemoryAddr 249 | (execState $ do 250 | modify (`clearBit` 0) 251 | modify (`setBit` 1) 252 | modify (if ly==lyc then (`setBit` 2) else (`clearBit` 2))) 253 | (0xFF41) 254 | updateIF = transformMemoryAddr 255 | (execState $ when (statB5 || (statB6 && ly==lyc)) (modify (`setBit` 1))) 256 | (0xFF0F) 257 | modify $ transformMem updateSTATFlags 258 | modify $ transformMem updateIF 259 | modify $ renderScanLine (irqStateCurrentScanline irq) 260 | 261 | tickHBlankMode3 :: ((RegisterStates, Memory), IrqStates) -> ((RegisterStates, Memory), IrqStates) 262 | tickHBlankMode3 = execState $ do 263 | ((_, _), irq) <- get 264 | when ((irqStateCurrentScanline irq) < 144) $ do 265 | let updateSTATFlags = transformMemoryAddr 266 | (execState $ do 267 | modify (`setBit` 0) 268 | modify (`setBit` 1)) 269 | (0xFF41) 270 | modify $ transformMem updateSTATFlags 271 | 272 | tickHBlankMode0 :: ((RegisterStates, Memory), IrqStates) -> ((RegisterStates, Memory), IrqStates) 273 | tickHBlankMode0 = execState $ do 274 | ((_, _), irq) <- get 275 | when ((irqStateCurrentScanline irq) < 144) $ do 276 | ((_, mem), _) <- get 277 | let statB3 = (memRam mem)!0xFF41 `testBit` 3 278 | updateSTATFlags = transformMemoryAddr 279 | (execState $ do 280 | modify (`clearBit` 0) 281 | modify (`clearBit` 1)) 282 | (0xFF41) 283 | updateIF = transformMemoryAddr 284 | (execState $ when statB3 (modify (`setBit` 1))) 285 | (0xFF0F) 286 | modify $ transformMem updateSTATFlags 287 | modify $ transformMem updateIF 288 | 289 | tickVBlank :: ((RegisterStates, Memory), IrqStates) -> ((RegisterStates, Memory), IrqStates) 290 | tickVBlank = execState $ do 291 | ((_, mem), _) <- get 292 | let statB4 = (memRam mem)!0xFF41 `testBit` 4 293 | updateSTATFlags = transformMemoryAddr 294 | (execState $ do 295 | modify (`setBit` 0) 296 | modify (`clearBit` 1)) 297 | (0xFF41) 298 | updateIF = transformMemoryAddr 299 | (execState $ do 300 | when statB4 (modify (`setBit` 1)) 301 | modify (`setBit` 0)) 302 | (0xFF0F) 303 | modify $ transformMem updateSTATFlags 304 | modify $ transformMem updateIF 305 | 306 | tickDIV :: ((RegisterStates, Memory), IrqStates) -> ((RegisterStates, Memory), IrqStates) 307 | tickDIV = execState $ do 308 | ((_, mem), _) <- get 309 | modify $ transformMem (transformMemoryAddr (+1) 0xFF04) 310 | 311 | renderScanLine :: Int -> ((RegisterStates, Memory), IrqStates) -> ((RegisterStates, Memory), IrqStates) 312 | renderScanLine scanline = execState $ do 313 | ((_, mem), irq) <- get 314 | let d = irqStateDisplay irq 315 | let scx = fromIntegral (readMem mem 0xFF43) 316 | let scy = fromIntegral (readMem mem 0xFF42) 317 | let lcdc = readMem mem 0xFF40 318 | let lcdon = testBit lcdc 7 319 | let bgon = testBit lcdc 0 320 | let bgmap = testBit lcdc 3 321 | let bgmapStartAddr = if bgmap then 0x9C00 else 0x9800 322 | let bgtiles = testBit lcdc 4 323 | let bgtilesStartAddr = if bgtiles then 0x8000 else 0x9000 324 | let spritesOn = testBit lcdc 1 325 | let spritesBig = testBit lcdc 2 326 | let getBgPixel :: Int -> Int -> Word8 327 | getBgPixel x y = 328 | let x' = (x + scx) `mod` 256 329 | y' = (y + scy) `mod` 256 330 | yrow = y' `div` 8 331 | xrow = x' `div` 8 332 | tileNum = yrow * 32 + xrow 333 | tileIndex = (fromIntegral (readMem mem ((fromIntegral tileNum) + bgmapStartAddr)))::Int8 334 | tileStartMem = bgtilesStartAddr + (16 * fromIntegral tileIndex) 335 | xoff = 7 - (x' `mod` 8) 336 | yoff = y' `mod` 8 337 | hiByte = tileStartMem + (yoff * 2) 338 | loByte = tileStartMem + (yoff * 2) + 1 339 | hiByteValue = readMem mem (fromIntegral hiByte) 340 | loByteValue = readMem mem (fromIntegral loByte) 341 | color = (2 * (fromEnum (testBit loByteValue xoff))) + (fromEnum (testBit hiByteValue xoff)) 342 | in if bgon && lcdon then fromIntegral color else 0 343 | let getSpritesPixel :: Int -> Int -> Maybe Word8 344 | getSpritesPixel x y = case spritesBig of 345 | False -> let xposes = map ( \i -> readMem mem (0xFE00 + (i*4) + 1) ) [0..39] 346 | yposes = map ( \i -> readMem mem (0xFE00 + (i*4) + 0) ) [0..39] 347 | tileIndexes = map ( \i -> readMem mem (0xFE00 + (i*4) + 2) ) [0..39] 348 | xflips = map ( \i -> testBit (readMem mem (0xFE00 + (i*4) + 2)) 5 ) [0..39] 349 | yflips = map ( \i -> testBit (readMem mem (0xFE00 + (i*4) + 2)) 4 ) [0..39] 350 | getSingleSpritePixel :: Int -> Int -> Int -> Int -> Word8 -> Bool -> Bool -> Maybe Word8 351 | getSingleSpritePixel x y xpos ypos tileIndex xflip yflip = 352 | if x > (fromIntegral xpos)-8 && x <= xpos && 353 | y > (fromIntegral ypos)-16 && y <= ypos-8 354 | then let x' = x - (fromIntegral xpos) + 8 355 | y' = y - (fromIntegral ypos) + 16 356 | x'' = if xflip then 7-x' else x' 357 | y'' = if yflip then 7-y' else y' 358 | tileStartMem = 0x8000 + (16 * (fromIntegral tileIndex)) 359 | xoff = 7 - (x'' `mod` 8) 360 | yoff = y'' `mod` 8 361 | hiByte = tileStartMem + (yoff * 2) 362 | loByte = tileStartMem + (yoff * 2) + 1 363 | hiByteValue = readMem mem (fromIntegral hiByte) 364 | loByteValue = readMem mem (fromIntegral loByte) 365 | color = (2 * (fromEnum (testBit loByteValue xoff))) + (fromEnum (testBit hiByteValue xoff)) 366 | in if color > 0 then Just (fromIntegral color) else Nothing 367 | else Nothing 368 | in foldl' ( \a b -> if isJust a 369 | then a 370 | else getSingleSpritePixel x 371 | y 372 | (fromIntegral (xposes!!b)) 373 | (fromIntegral (yposes!!b)) 374 | (tileIndexes!!b) 375 | (xflips!!b) 376 | (yflips!!b) 377 | ) Nothing [0..39] 378 | True -> trace ("eek") Nothing 379 | 380 | let getPixel x y = case getSpritesPixel x y of 381 | Just c -> c 382 | Nothing -> getBgPixel x y 383 | 384 | let updateList = map (\x -> ((scanline, x), getBgPixel x scanline)) [0..159] 385 | let d' = d//updateList 386 | modify $ transformIrq (\i -> i { irqStateDisplay = d' }) 387 | 388 | 389 | machineCpuExecute :: (MemoryModel m) => 390 | (RegisterStates, m) -> 391 | ExecutionAST () -> 392 | (RegisterStates, m) 393 | machineCpuExecute s e = fst (machineCpuExecute' s e) 394 | 395 | machineCpuExecute' :: (MemoryModel m) => 396 | (RegisterStates, m) -> 397 | ExecutionAST a -> 398 | ((RegisterStates, m), a) 399 | machineCpuExecute' state@(regS, memS) e = case e of 400 | Return result -> (state, result) 401 | Bind l r -> let (s, result) = machineCpuExecute' state l in 402 | machineCpuExecute' s (r result) 403 | WriteRegister reg n -> ((setRegState regS reg n, memS), ()) 404 | ReadRegister reg -> (state, getRegState regS reg) 405 | WriteRegister2 reg2 nn -> ((setReg2State regS reg2 nn, memS), ()) 406 | ReadRegister2 reg2 -> (state, getReg2State regS reg2) 407 | WriteMemory a n -> ((regS, writeMem memS a n), ()) 408 | ReadMemory a -> (state, readMem memS a) 409 | 410 | fetchInstruction :: (MemoryModel m) => (RegisterStates, m) -> Instruction 411 | fetchInstruction (regS, memS) = 412 | let pc = getReg2State regS M_PC 413 | opcode = readMem memS pc 414 | n :: Word8 415 | n = readMem memS (pc+1) 416 | nn :: Word16 417 | nn = joinWord16 (readMem memS (pc+2)) (readMem memS (pc+1)) 418 | instruction = machineCodeToInstruction opcode (n, nn) in 419 | instruction 420 | 421 | machineStepInstruction :: (MemoryModel m) => 422 | (RegisterStates, m) -> 423 | (RegisterStates, m) 424 | machineStepInstruction state@(regS, memS) = 425 | let instruction = fetchInstruction state 426 | execution = executeInstruction instruction in 427 | machineCpuExecute state execution 428 | 429 | updateMachine :: ((RegisterStates, Memory), IrqStates) -> 430 | ((RegisterStates, Memory), IrqStates) 431 | updateMachine (state@(regS, memS), irqS) = 432 | let stepInstruction = machineStepInstruction state 433 | pc = getReg2State regS M_PC 434 | opcode = readMem memS pc 435 | cycles = opcodeCycleCount opcode 436 | ime = opcodeQueryIME opcode in 437 | irqUpdate cycles ime (stepInstruction, irqS) 438 | 439 | initialMachineState romImage = 440 | ((initialRegisterStates, initMemory romImage), initialIrqStates) 441 | 442 | --instance Show JoypadKeyStates 443 | 444 | updateMachineDisplayFrame :: JoypadKeyStates -> 445 | ((RegisterStates, Memory), IrqStates) -> 446 | (Display, ((RegisterStates, Memory), IrqStates)) 447 | updateMachineDisplayFrame jp s = 448 | let s' = transformMem (\mem -> mem { memJoypadKeyStates = jp } ) s 449 | l = tail (iterate updateMachine s') 450 | pred (_, irq) = irqStateVBlankNow irq 451 | f@(_, irqS) = fromJust (find pred l) in 452 | (irqStateDisplay irqS, f) 453 | 454 | --updateMachineDisplayFrame' jp s = 455 | -- let (_, s') = updateMachineDisplayFrame jp s in 456 | -- updateMachineDisplayFrame jp s' 457 | 458 | -------------------------------------------------------------------------------- /src/CpuIO.hs: -------------------------------------------------------------------------------- 1 | -- OmegaGB Copyright 2007 Bit Connor 2 | -- This program is distributed under the terms of the GNU General Public License 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : CpuIO 6 | -- Copyright : (c) Bit Connor 2007 7 | -- License : GPL 8 | -- Maintainer : bit@mutantlemon.com 9 | -- Stability : in-progress 10 | -- 11 | -- OmegaGB 12 | -- Game Boy Emulator 13 | -- 14 | -- This module does emulation of the Game Boy's Z80 like CPU, using 15 | -- an alternative implementation that uses the IO monad and mutable 16 | -- variables as an attempt to get good performance. 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module CpuIO where 21 | 22 | import Data.Word 23 | import Data.Int 24 | import Data.Bits 25 | import Data.IORef 26 | 27 | import MachineStateIO 28 | import WordUtil 29 | 30 | data Register = 31 | A | 32 | B | 33 | C | 34 | D | 35 | E | 36 | H | 37 | L 38 | 39 | data RegisterPair = 40 | BC | 41 | DE | 42 | HL | 43 | SP 44 | 45 | data StackRegister = 46 | StackRegAF | 47 | StackRegBC | 48 | StackRegDE | 49 | StackRegHL 50 | 51 | data RestartAddress = 52 | RST_00H | 53 | RST_08H | 54 | RST_10H | 55 | RST_18H | 56 | RST_20H | 57 | RST_28H | 58 | RST_30H | 59 | RST_38H 60 | 61 | data BitIndex = 62 | Bit0 | 63 | Bit1 | 64 | Bit2 | 65 | Bit3 | 66 | Bit4 | 67 | Bit5 | 68 | Bit6 | 69 | Bit7 70 | 71 | data FlagCondition = 72 | FlagC | 73 | FlagNC | 74 | FlagNZ | 75 | FlagZ 76 | 77 | machineUpdateInstructionIO :: MachineStateIO -> IO () 78 | machineUpdateInstructionIO s = do 79 | pc <- readIORef (msRegPC s) 80 | opcode <- readMemoryIO s pc 81 | n <- readMemoryIO s (pc + 1) 82 | n' <- readMemoryIO s (pc + 2) 83 | let nn = joinWord16 n' n 84 | 85 | case opcode of 86 | 0x00 -> execNOP 87 | 0x01 -> execLD2 BC nn 88 | 0x02 -> execLDPR True 89 | 0x03 -> execINC2 BC 90 | 0x04 -> execINC B 91 | 0x05 -> execDEC B 92 | 0x06 -> execLDRN B n 93 | 0x07 -> execRLCA 94 | 0x08 -> execLDP2 nn 95 | 0x09 -> execADD2HL BC 96 | 0x0A -> execLDAP True 97 | 0x0B -> execDEC2 BC 98 | 0x0C -> execINC C 99 | 0x0D -> execDEC C 100 | 0x0E -> execLDRN C n 101 | 0x0F -> execRRCA 102 | 103 | 0x10 -> execSTOP 104 | 0x11 -> execLD2 DE nn 105 | 0x12 -> execLDPR False 106 | 0x13 -> execINC2 DE 107 | 0x14 -> execINC D 108 | 0x15 -> execDEC D 109 | 0x16 -> execLDRN D n 110 | 0x17 -> execRLA 111 | 0x18 -> execJR Nothing (fromIntegral n) 112 | 0x19 -> execADD2HL DE 113 | 0x1A -> execLDAP False 114 | 0x1B -> execDEC2 DE 115 | 0x1C -> execINC E 116 | 0x1D -> execDEC E 117 | 0x1E -> execLDRN E n 118 | 0x1F -> execRRA 119 | 120 | 0x20 -> execJR (Just FlagNZ) (fromIntegral n) 121 | 0x21 -> execLD2 HL nn 122 | 0x22 -> execLDI True 123 | 0x23 -> execINC2 HL 124 | 0x24 -> execINC H 125 | 0x25 -> execDEC H 126 | 0x26 -> execLDRN H n 127 | 0x27 -> execDAA 128 | 0x28 -> execJR (Just FlagZ) (fromIntegral n) 129 | 0x29 -> execADD2HL HL 130 | 0x2A -> execLDI False 131 | 0x2B -> execDEC2 HL 132 | 0x2C -> execINC L 133 | 0x2D -> execDEC L 134 | 0x2E -> execLDRN L n 135 | 0x2F -> execCPL 136 | 137 | 0x30 -> execJR (Just FlagNC) (fromIntegral n) 138 | 0x31 -> execLD2 SP nn 139 | 0x32 -> execLDD True 140 | 0x33 -> execINC2 SP 141 | 0x34 -> execINCHL 142 | 0x35 -> execDECHL 143 | 0x36 -> execLDHLN n 144 | 0x37 -> execSCF 145 | 0x38 -> execJR (Just FlagC) (fromIntegral n) 146 | 0x39 -> execADD2HL SP 147 | 0x3A -> execLDD False 148 | 0x3B -> execDEC2 SP 149 | 0x3C -> execINC A 150 | 0x3D -> execDEC A 151 | 0x3E -> execLDRN A n 152 | 0x3F -> execCCF 153 | 154 | 0x40 -> execLDR B B 155 | 0x41 -> execLDR B C 156 | 0x42 -> execLDR B D 157 | 0x43 -> execLDR B E 158 | 0x44 -> execLDR B H 159 | 0x45 -> execLDR B L 160 | 0x46 -> execLDRHL B 161 | 0x47 -> execLDR B A 162 | 0x48 -> execLDR C B 163 | 0x49 -> execLDR C C 164 | 0x4A -> execLDR C D 165 | 0x4B -> execLDR C E 166 | 0x4C -> execLDR C H 167 | 0x4D -> execLDR C L 168 | 0x4E -> execLDRHL C 169 | 0x4F -> execLDR C A 170 | 171 | 0x50 -> execLDR D B 172 | 0x51 -> execLDR D C 173 | 0x52 -> execLDR D D 174 | 0x53 -> execLDR D E 175 | 0x54 -> execLDR D H 176 | 0x55 -> execLDR D L 177 | 0x56 -> execLDRHL D 178 | 0x57 -> execLDR D A 179 | 0x58 -> execLDR E B 180 | 0x59 -> execLDR E C 181 | 0x5A -> execLDR E D 182 | 0x5B -> execLDR E E 183 | 0x5C -> execLDR E H 184 | 0x5D -> execLDR E L 185 | 0x5E -> execLDRHL E 186 | 0x5F -> execLDR E A 187 | 188 | 0x60 -> execLDR H B 189 | 0x61 -> execLDR H C 190 | 0x62 -> execLDR H D 191 | 0x63 -> execLDR H E 192 | 0x64 -> execLDR H H 193 | 0x65 -> execLDR H L 194 | 0x66 -> execLDRHL H 195 | 0x67 -> execLDR H A 196 | 0x68 -> execLDR L B 197 | 0x69 -> execLDR L C 198 | 0x6A -> execLDR L D 199 | 0x6B -> execLDR L E 200 | 0x6C -> execLDR L H 201 | 0x6D -> execLDR L L 202 | 0x6E -> execLDRHL L 203 | 0x6F -> execLDR L A 204 | 205 | 0x70 -> execLDHL B 206 | 0x71 -> execLDHL C 207 | 0x72 -> execLDHL D 208 | 0x73 -> execLDHL E 209 | 0x74 -> execLDHL H 210 | 0x75 -> execLDHL L 211 | 0x76 -> execHALT 212 | 0x77 -> execLDHL A 213 | 0x78 -> execLDR A B 214 | 0x79 -> execLDR A C 215 | 0x7A -> execLDR A D 216 | 0x7B -> execLDR A E 217 | 0x7C -> execLDR A H 218 | 0x7D -> execLDR A L 219 | 0x7E -> execLDRHL A 220 | 0x7F -> execLDR A A 221 | 222 | 0x80 -> execADD B 223 | 0x81 -> execADD C 224 | 0x82 -> execADD D 225 | 0x83 -> execADD E 226 | 0x84 -> execADD H 227 | 0x85 -> execADD L 228 | 0x86 -> execADDHL 229 | 0x87 -> execADD A 230 | 0x88 -> execADC B 231 | 0x89 -> execADC C 232 | 0x8A -> execADC D 233 | 0x8B -> execADC E 234 | 0x8C -> execADC H 235 | 0x8D -> execADC L 236 | 0x8E -> execADCHL 237 | 0x8F -> execADC A 238 | 239 | 0x90 -> execSUB B 240 | 0x91 -> execSUB C 241 | 0x92 -> execSUB D 242 | 0x93 -> execSUB E 243 | 0x94 -> execSUB H 244 | 0x95 -> execSUB L 245 | 0x96 -> execSUBHL 246 | 0x97 -> execSUB A 247 | 0x98 -> execSBC B 248 | 0x99 -> execSBC C 249 | 0x9A -> execSBC D 250 | 0x9B -> execSBC E 251 | 0x9C -> execSBC H 252 | 0x9D -> execSBC L 253 | 0x9E -> execSBCHL 254 | 0x9F -> execSBC A 255 | 256 | 0xA0 -> execAND B 257 | 0xA1 -> execAND C 258 | 0xA2 -> execAND D 259 | 0xA3 -> execAND E 260 | 0xA4 -> execAND H 261 | 0xA5 -> execAND L 262 | 0xA6 -> execANDHL 263 | 0xA7 -> execAND A 264 | 0xA8 -> execXOR B 265 | 0xA9 -> execXOR C 266 | 0xAA -> execXOR D 267 | 0xAB -> execXOR E 268 | 0xAC -> execXOR H 269 | 0xAD -> execXOR L 270 | 0xAE -> execXORHL 271 | 0xAF -> execXOR A 272 | 273 | 0xB0 -> execOR B 274 | 0xB1 -> execOR C 275 | 0xB2 -> execOR D 276 | 0xB3 -> execOR E 277 | 0xB4 -> execOR H 278 | 0xB5 -> execOR L 279 | 0xB6 -> execORHL 280 | 0xB7 -> execOR A 281 | 0xB8 -> execCP B 282 | 0xB9 -> execCP C 283 | 0xBA -> execCP D 284 | 0xBB -> execCP E 285 | 0xBC -> execCP H 286 | 0xBD -> execCP L 287 | 0xBE -> execCPHL 288 | 0xBF -> execCP A 289 | 290 | 0xC0 -> execRET (Just FlagNZ) 291 | 0xC1 -> execPOP StackRegBC 292 | 0xC2 -> execJP (Just FlagNZ) nn 293 | 0xC3 -> execJP Nothing nn 294 | 0xC4 -> execCALL (Just FlagNZ) nn 295 | 0xC5 -> execPUSH StackRegBC 296 | 0xC6 -> execADDN n 297 | 0xC7 -> execRST RST_00H 298 | 0xC8 -> execRET (Just FlagZ) 299 | 0xC9 -> execRET Nothing 300 | 0xCA -> execJP (Just FlagZ) nn 301 | 0xCB -> case n of 302 | 0x00 -> execRLC B 303 | 0x01 -> execRLC C 304 | 0x02 -> execRLC D 305 | 0x03 -> execRLC E 306 | 0x04 -> execRLC H 307 | 0x05 -> execRLC L 308 | 0x06 -> execRLCHL 309 | 0x07 -> execRLC A 310 | 0x08 -> execRRC B 311 | 0x09 -> execRRC C 312 | 0x0A -> execRRC D 313 | 0x0B -> execRRC E 314 | 0x0C -> execRRC H 315 | 0x0D -> execRRC L 316 | 0x0E -> execRRCHL 317 | 0x0F -> execRRC A 318 | 319 | 0x10 -> execRL B 320 | 0x11 -> execRL C 321 | 0x12 -> execRL D 322 | 0x13 -> execRL E 323 | 0x14 -> execRL H 324 | 0x15 -> execRL L 325 | 0x16 -> execRLHL 326 | 0x17 -> execRL A 327 | 0x18 -> execRR B 328 | 0x19 -> execRR C 329 | 0x1A -> execRR D 330 | 0x1B -> execRR E 331 | 0x1C -> execRR H 332 | 0x1D -> execRR L 333 | 0x1E -> execRRHL 334 | 0x1F -> execRR A 335 | 336 | 0x20 -> execSLA B 337 | 0x21 -> execSLA C 338 | 0x22 -> execSLA D 339 | 0x23 -> execSLA E 340 | 0x24 -> execSLA H 341 | 0x25 -> execSLA L 342 | 0x26 -> execSLAHL 343 | 0x27 -> execSLA A 344 | 0x28 -> execSRA B 345 | 0x29 -> execSRA C 346 | 0x2A -> execSRA D 347 | 0x2B -> execSRA E 348 | 0x2C -> execSRA H 349 | 0x2D -> execSRA L 350 | 0x2E -> execSRAHL 351 | 0x2F -> execSRA A 352 | 353 | 0x30 -> execSWAP B 354 | 0x31 -> execSWAP C 355 | 0x32 -> execSWAP D 356 | 0x33 -> execSWAP E 357 | 0x34 -> execSWAP H 358 | 0x35 -> execSWAP L 359 | 0x36 -> execSWAPHL 360 | 0x37 -> execSWAP A 361 | 0x38 -> execSRL B 362 | 0x39 -> execSRL C 363 | 0x3A -> execSRL D 364 | 0x3B -> execSRL E 365 | 0x3C -> execSRL H 366 | 0x3D -> execSRL L 367 | 0x3E -> execSRLHL 368 | 0x3F -> execSRL A 369 | 370 | 0x40 -> execBIT Bit0 B 371 | 0x41 -> execBIT Bit0 C 372 | 0x42 -> execBIT Bit0 D 373 | 0x43 -> execBIT Bit0 E 374 | 0x44 -> execBIT Bit0 H 375 | 0x45 -> execBIT Bit0 L 376 | 0x46 -> execBITHL Bit0 377 | 0x47 -> execBIT Bit0 A 378 | 0x48 -> execBIT Bit1 B 379 | 0x49 -> execBIT Bit1 C 380 | 0x4A -> execBIT Bit1 D 381 | 0x4B -> execBIT Bit1 E 382 | 0x4C -> execBIT Bit1 H 383 | 0x4D -> execBIT Bit1 L 384 | 0x4E -> execBITHL Bit1 385 | 0x4F -> execBIT Bit1 A 386 | 387 | 0x50 -> execBIT Bit2 B 388 | 0x51 -> execBIT Bit2 C 389 | 0x52 -> execBIT Bit2 D 390 | 0x53 -> execBIT Bit2 E 391 | 0x54 -> execBIT Bit2 H 392 | 0x55 -> execBIT Bit2 L 393 | 0x56 -> execBITHL Bit2 394 | 0x57 -> execBIT Bit2 A 395 | 0x58 -> execBIT Bit3 B 396 | 0x59 -> execBIT Bit3 C 397 | 0x5A -> execBIT Bit3 D 398 | 0x5B -> execBIT Bit3 E 399 | 0x5C -> execBIT Bit3 H 400 | 0x5D -> execBIT Bit3 L 401 | 0x5E -> execBITHL Bit3 402 | 0x5F -> execBIT Bit3 A 403 | 404 | 0x60 -> execBIT Bit4 B 405 | 0x61 -> execBIT Bit4 C 406 | 0x62 -> execBIT Bit4 D 407 | 0x63 -> execBIT Bit4 E 408 | 0x64 -> execBIT Bit4 H 409 | 0x65 -> execBIT Bit4 L 410 | 0x66 -> execBITHL Bit4 411 | 0x67 -> execBIT Bit4 A 412 | 0x68 -> execBIT Bit5 B 413 | 0x69 -> execBIT Bit5 C 414 | 0x6A -> execBIT Bit5 D 415 | 0x6B -> execBIT Bit5 E 416 | 0x6C -> execBIT Bit5 H 417 | 0x6D -> execBIT Bit5 L 418 | 0x6E -> execBITHL Bit5 419 | 0x6F -> execBIT Bit5 A 420 | 421 | 0x70 -> execBIT Bit6 B 422 | 0x71 -> execBIT Bit6 C 423 | 0x72 -> execBIT Bit6 D 424 | 0x73 -> execBIT Bit6 E 425 | 0x74 -> execBIT Bit6 H 426 | 0x75 -> execBIT Bit6 L 427 | 0x76 -> execBITHL Bit6 428 | 0x77 -> execBIT Bit6 A 429 | 0x78 -> execBIT Bit7 B 430 | 0x79 -> execBIT Bit7 C 431 | 0x7A -> execBIT Bit7 D 432 | 0x7B -> execBIT Bit7 E 433 | 0x7C -> execBIT Bit7 H 434 | 0x7D -> execBIT Bit7 L 435 | 0x7E -> execBITHL Bit7 436 | 0x7F -> execBIT Bit7 A 437 | 438 | 0x80 -> execRES Bit0 B 439 | 0x81 -> execRES Bit0 C 440 | 0x82 -> execRES Bit0 D 441 | 0x83 -> execRES Bit0 E 442 | 0x84 -> execRES Bit0 H 443 | 0x85 -> execRES Bit0 L 444 | 0x86 -> execRESHL Bit0 445 | 0x87 -> execRES Bit0 A 446 | 0x88 -> execRES Bit1 B 447 | 0x89 -> execRES Bit1 C 448 | 0x8A -> execRES Bit1 D 449 | 0x8B -> execRES Bit1 E 450 | 0x8C -> execRES Bit1 H 451 | 0x8D -> execRES Bit1 L 452 | 0x8E -> execRESHL Bit1 453 | 0x8F -> execRES Bit1 A 454 | 455 | 0x90 -> execRES Bit2 B 456 | 0x91 -> execRES Bit2 C 457 | 0x92 -> execRES Bit2 D 458 | 0x93 -> execRES Bit2 E 459 | 0x94 -> execRES Bit2 H 460 | 0x95 -> execRES Bit2 L 461 | 0x96 -> execRESHL Bit2 462 | 0x97 -> execRES Bit2 A 463 | 0x98 -> execRES Bit3 B 464 | 0x99 -> execRES Bit3 C 465 | 0x9A -> execRES Bit3 D 466 | 0x9B -> execRES Bit3 E 467 | 0x9C -> execRES Bit3 H 468 | 0x9D -> execRES Bit3 L 469 | 0x9E -> execRESHL Bit3 470 | 0x9F -> execRES Bit3 A 471 | 472 | 0xA0 -> execRES Bit4 B 473 | 0xA1 -> execRES Bit4 C 474 | 0xA2 -> execRES Bit4 D 475 | 0xA3 -> execRES Bit4 E 476 | 0xA4 -> execRES Bit4 H 477 | 0xA5 -> execRES Bit4 L 478 | 0xA6 -> execRESHL Bit4 479 | 0xA7 -> execRES Bit4 A 480 | 0xA8 -> execRES Bit5 B 481 | 0xA9 -> execRES Bit5 C 482 | 0xAA -> execRES Bit5 D 483 | 0xAB -> execRES Bit5 E 484 | 0xAC -> execRES Bit5 H 485 | 0xAD -> execRES Bit5 L 486 | 0xAE -> execRESHL Bit5 487 | 0xAF -> execRES Bit5 A 488 | 489 | 0xB0 -> execRES Bit6 B 490 | 0xB1 -> execRES Bit6 C 491 | 0xB2 -> execRES Bit6 D 492 | 0xB3 -> execRES Bit6 E 493 | 0xB4 -> execRES Bit6 H 494 | 0xB5 -> execRES Bit6 L 495 | 0xB6 -> execRESHL Bit6 496 | 0xB7 -> execRES Bit6 A 497 | 0xB8 -> execRES Bit7 B 498 | 0xB9 -> execRES Bit7 C 499 | 0xBA -> execRES Bit7 D 500 | 0xBB -> execRES Bit7 E 501 | 0xBC -> execRES Bit7 H 502 | 0xBD -> execRES Bit7 L 503 | 0xBE -> execRESHL Bit7 504 | 0xBF -> execRES Bit7 A 505 | 506 | 0xC0 -> execSET Bit0 B 507 | 0xC1 -> execSET Bit0 C 508 | 0xC2 -> execSET Bit0 D 509 | 0xC3 -> execSET Bit0 E 510 | 0xC4 -> execSET Bit0 H 511 | 0xC5 -> execSET Bit0 L 512 | 0xC6 -> execSETHL Bit0 513 | 0xC7 -> execSET Bit0 A 514 | 0xC8 -> execSET Bit1 B 515 | 0xC9 -> execSET Bit1 C 516 | 0xCA -> execSET Bit1 D 517 | 0xCB -> execSET Bit1 E 518 | 0xCC -> execSET Bit1 H 519 | 0xCD -> execSET Bit1 L 520 | 0xCE -> execSETHL Bit1 521 | 0xCF -> execSET Bit1 A 522 | 523 | 0xD0 -> execSET Bit2 B 524 | 0xD1 -> execSET Bit2 C 525 | 0xD2 -> execSET Bit2 D 526 | 0xD3 -> execSET Bit2 E 527 | 0xD4 -> execSET Bit2 H 528 | 0xD5 -> execSET Bit2 L 529 | 0xD6 -> execSETHL Bit2 530 | 0xD7 -> execSET Bit2 A 531 | 0xD8 -> execSET Bit3 B 532 | 0xD9 -> execSET Bit3 C 533 | 0xDA -> execSET Bit3 D 534 | 0xDB -> execSET Bit3 E 535 | 0xDC -> execSET Bit3 H 536 | 0xDD -> execSET Bit3 L 537 | 0xDE -> execSETHL Bit3 538 | 0xDF -> execSET Bit3 A 539 | 540 | 0xE0 -> execSET Bit4 B 541 | 0xE1 -> execSET Bit4 C 542 | 0xE2 -> execSET Bit4 D 543 | 0xE3 -> execSET Bit4 E 544 | 0xE4 -> execSET Bit4 H 545 | 0xE5 -> execSET Bit4 L 546 | 0xE6 -> execSETHL Bit4 547 | 0xE7 -> execSET Bit4 A 548 | 0xE8 -> execSET Bit5 B 549 | 0xE9 -> execSET Bit5 C 550 | 0xEA -> execSET Bit5 D 551 | 0xEB -> execSET Bit5 E 552 | 0xEC -> execSET Bit5 H 553 | 0xED -> execSET Bit5 L 554 | 0xEE -> execSETHL Bit5 555 | 0xEF -> execSET Bit5 A 556 | 557 | 0xF0 -> execSET Bit6 B 558 | 0xF1 -> execSET Bit6 C 559 | 0xF2 -> execSET Bit6 D 560 | 0xF3 -> execSET Bit6 E 561 | 0xF4 -> execSET Bit6 H 562 | 0xF5 -> execSET Bit6 L 563 | 0xF6 -> execSETHL Bit6 564 | 0xF7 -> execSET Bit6 A 565 | 0xF8 -> execSET Bit7 B 566 | 0xF9 -> execSET Bit7 C 567 | 0xFA -> execSET Bit7 D 568 | 0xFB -> execSET Bit7 E 569 | 0xFC -> execSET Bit7 H 570 | 0xFD -> execSET Bit7 L 571 | 0xFE -> execSETHL Bit7 572 | 0xFF -> execSET Bit7 A 573 | 574 | 0xCC -> execCALL (Just FlagZ) nn 575 | 0xCD -> execCALL Nothing nn 576 | 0xCE -> execADCN n 577 | 0xCF -> execRST RST_08H 578 | 579 | 0xD0 -> execRET (Just FlagNC) 580 | 0xD1 -> execPOP StackRegDE 581 | 0xD2 -> execJP (Just FlagNC) nn 582 | 0xD3 -> error "$D3 Invalid Opcode" 583 | 0xD4 -> execCALL (Just FlagNC) nn 584 | 0xD5 -> execPUSH StackRegDE 585 | 0xD6 -> execSUBN n 586 | 0xD7 -> execRST RST_10H 587 | 0xD8 -> execRET (Just FlagC) 588 | 0xD9 -> execRETI 589 | 0xDA -> execJP (Just FlagC) nn 590 | 0xDB -> error "$DB Invalid Opcode" 591 | 0xDC -> execCALL (Just FlagC) nn 592 | 0xDD -> error "$DD Invalid Opcode" 593 | 0xDE -> execSBCN n 594 | 0xDF -> execRST RST_18H 595 | 596 | 0xE0 -> execLDH True n 597 | 0xE1 -> execPOP StackRegHL 598 | 0xE2 -> execLDPC 599 | 0xE3 -> error "$E3 Invalid Opcode" 600 | 0xE4 -> error "$E4 Invalid Opcode" 601 | 0xE5 -> execPUSH StackRegHL 602 | 0xE6 -> execANDN n 603 | 0xE7 -> execRST RST_20H 604 | 0xE8 -> execADD2SP (fromIntegral n) 605 | 0xE9 -> execJPHL 606 | 0xEA -> execLDPN nn 607 | 0xEB -> error "$EB Invalid Opcode" 608 | 0xEC -> error "$EC Invalid Opcode" 609 | 0xED -> error "$ED Invalid Opcode" 610 | 0xEE -> execXORN n 611 | 0xEF -> execRST RST_28H 612 | 613 | 0xF0 -> execLDH False n 614 | 0xF1 -> execPOP StackRegAF 615 | 0xF2 -> execLDAC 616 | 0xF3 -> execDI 617 | 0xF4 -> error "$F4 Invalid Opcode" 618 | 0xF5 -> execPUSH StackRegAF 619 | 0xF6 -> execORN n 620 | 0xF7 -> execRST RST_30H 621 | 0xF8 -> execLDHL2 (fromIntegral n) 622 | 0xF9 -> execLDSP2 623 | 0xFA -> execLDAPN nn 624 | 0xFB -> execEI 625 | 0xFC -> error "$FC Invalid Opcode" 626 | 0xFD -> error "$FD Invalid Opcode" 627 | 0xFE -> execCPN n 628 | 0xFF -> execRST RST_38H 629 | 630 | where 631 | regIORef r = case r of 632 | A -> msRegA s 633 | B -> msRegB s 634 | C -> msRegC s 635 | D -> msRegD s 636 | E -> msRegE s 637 | H -> msRegE s 638 | L -> msRegE s 639 | 640 | writeIORegister2 rp nn = 641 | let (hi, lo) = splitWord16 nn in 642 | case rp of 643 | BC -> writeIORef (msRegB s) hi >> 644 | writeIORef (msRegC s) lo 645 | DE -> writeIORef (msRegD s) hi >> 646 | writeIORef (msRegE s) lo 647 | HL -> writeIORef (msRegH s) hi >> 648 | writeIORef (msRegL s) lo 649 | SP -> writeIORef (msRegSP s) nn 650 | 651 | readIORegister2 rp = 652 | case rp of 653 | BC -> do hi <- readIORef (msRegB s) 654 | lo <- readIORef (msRegC s) 655 | return (joinWord16 hi lo) 656 | DE -> do hi <- readIORef (msRegD s) 657 | lo <- readIORef (msRegE s) 658 | return (joinWord16 hi lo) 659 | HL -> do hi <- readIORef (msRegH s) 660 | lo <- readIORef (msRegL s) 661 | return (joinWord16 hi lo) 662 | 663 | writeFlagsIO z n h c = do 664 | v0 <- readIORef (msRegF s) 665 | let v1 = case z of 666 | Nothing -> v0 667 | Just True -> setBit v0 7 668 | Just False -> clearBit v0 7 669 | let v2 = case n of 670 | Nothing -> v1 671 | Just True -> setBit v1 6 672 | Just False -> clearBit v1 6 673 | let v3 = case h of 674 | Nothing -> v2 675 | Just True -> setBit v2 5 676 | Just False -> clearBit v2 5 677 | let v4 = case c of 678 | Nothing -> v3 679 | Just True -> setBit v3 4 680 | Just False -> clearBit v3 4 681 | writeIORef (msRegF s) v4 682 | 683 | 684 | execLDR r1 r2 = do 685 | a <- readIORef (regIORef r1) 686 | writeIORef (regIORef r2) a 687 | incPC1 688 | execLDRN r n = do 689 | writeIORef (regIORef r) n 690 | incPC2 691 | execLDRHL r = do 692 | a <- readIORegister2 HL 693 | v <- readMemoryIO s a 694 | writeIORef (regIORef r) v 695 | incPC1 696 | execLDHL r = do 697 | a <- readIORegister2 HL 698 | v <- readIORef (regIORef r) 699 | writeMemoryIO s a v 700 | incPC1 701 | execLDHLN n = do 702 | a <- readIORegister2 HL 703 | writeMemoryIO s a n 704 | incPC2 705 | execLDAP True = do 706 | a <- readIORegister2 BC 707 | v <- readMemoryIO s a 708 | writeIORef (msRegA s) v 709 | incPC1 710 | execLDAP False = do 711 | a <- readIORegister2 DE 712 | v <- readMemoryIO s a 713 | writeIORef (msRegA s) v 714 | incPC1 715 | execLDAPN nn = do 716 | v <- readMemoryIO s nn 717 | writeIORef (msRegA s) v 718 | incPC3 719 | execLDAC = do 720 | o <- readIORef (msRegC s) 721 | let a = 0xFF00 + (fromIntegral o) 722 | v <- readMemoryIO s a 723 | writeIORef (msRegA s) v 724 | incPC1 725 | execLDPR True = do 726 | a <- readIORegister2 BC 727 | v <- readIORef (msRegA s) 728 | writeMemoryIO s a v 729 | incPC1 730 | execLDPR False = do 731 | a <- readIORegister2 DE 732 | v <- readIORef (msRegA s) 733 | writeMemoryIO s a v 734 | incPC1 735 | execLDPN a = do 736 | v <- readIORef (msRegA s) 737 | writeMemoryIO s a v 738 | incPC3 739 | execLDPC = do 740 | o <- readIORef (msRegC s) 741 | let a = 0xFF00 + (fromIntegral o)::Word16 742 | v <- readIORef (msRegA s) 743 | writeMemoryIO s a v 744 | incPC1 745 | execLD2 rp nn = do 746 | writeIORegister2 rp nn 747 | incPC3 748 | execLDSP2 = do 749 | v <- readIORegister2 HL 750 | writeIORegister2 SP v 751 | incPC1 752 | execLDP2 nn = do 753 | v <- readIORegister2 SP 754 | let (v', v'') = splitWord16 v 755 | let nn' = nn + 1 756 | writeMemoryIO s nn v' 757 | writeMemoryIO s nn' v'' 758 | incPC3 759 | execLDI True = do 760 | a <- readIORegister2 HL 761 | v <- readIORef (msRegA s) 762 | writeMemoryIO s a v 763 | let a' = a + 1 764 | writeIORegister2 HL a' 765 | incPC1 766 | execLDI False = do 767 | a <- readIORegister2 HL 768 | v <- readMemoryIO s a 769 | writeIORef (msRegA s) v 770 | let a' = a + 1 771 | writeIORegister2 HL a' 772 | incPC1 773 | execLDD True = do 774 | a <- readIORegister2 HL 775 | v <- readIORef (msRegA s) 776 | writeMemoryIO s a v 777 | let a' = a - 1 778 | writeIORegister2 HL a' 779 | incPC1 780 | execLDD False = do 781 | a <- readIORegister2 HL 782 | v <- readMemoryIO s a 783 | writeIORef (msRegA s) v 784 | let a' = a - 1 785 | writeIORegister2 HL a' 786 | incPC1 787 | execLDH True n = do 788 | let a = 0xFF00 + (fromIntegral n) 789 | v <- readIORef (msRegA s) 790 | writeMemoryIO s a v 791 | incPC2 792 | execLDH False n = do 793 | let a = 0xFF00 + (fromIntegral n) 794 | v <- readMemoryIO s a 795 | writeIORef (msRegA s) v 796 | incPC2 797 | execLDHL2 d = do 798 | v <- readIORegister2 SP 799 | let v' = v + (fromIntegral d) 800 | writeIORegister2 HL v' 801 | writeFlagsIO (Just False) (Just False) (Just (v'.&.0x000F < v.&.0x000F)) (Just (v' < v)) 802 | incPC2 803 | execPUSH :: StackRegister -> IO () 804 | execPUSH sr = do 805 | a <- readIORegister2 SP 806 | let a' = a - 1 807 | let a'' = a - 2 808 | (hi, lo) <- case sr of 809 | StackRegAF -> do hi <- readIORef (msRegA s) 810 | lo <- readIORef (msRegF s) 811 | return (hi, lo) 812 | StackRegBC -> do hi <- readIORef (msRegB s) 813 | lo <- readIORef (msRegC s) 814 | return (hi, lo) 815 | StackRegDE -> do hi <- readIORef (msRegD s) 816 | lo <- readIORef (msRegE s) 817 | return (hi, lo) 818 | StackRegHL -> do hi <- readIORef (msRegH s) 819 | lo <- readIORef (msRegL s) 820 | return (hi, lo) 821 | writeMemoryIO s a' hi 822 | writeMemoryIO s a'' lo 823 | writeIORegister2 SP a'' 824 | incPC1 825 | execPOP :: StackRegister -> IO () 826 | execPOP sr = do 827 | a <- readIORegister2 SP 828 | let a' = a + 1 829 | lo <- readMemoryIO s a 830 | hi <- readMemoryIO s a' 831 | case sr of 832 | StackRegAF -> writeIORef (msRegA s) hi >> 833 | writeIORef (msRegF s) lo 834 | StackRegBC -> writeIORef (msRegB s) hi >> 835 | writeIORef (msRegC s) lo 836 | StackRegDE -> writeIORef (msRegD s) hi >> 837 | writeIORef (msRegE s) lo 838 | StackRegHL -> writeIORef (msRegH s) hi >> 839 | writeIORef (msRegL s) lo 840 | let a'' = a + 2 841 | writeIORegister2 SP a'' 842 | incPC1 843 | execADD r = return () 844 | execADDN n = return () 845 | execADDHL = return () 846 | execADC r = return () 847 | execADCN n = return () 848 | execADCHL = return () 849 | execSUB r = return () 850 | execSUBN n = return () 851 | execSUBHL = return () 852 | execSBC r = return () 853 | execSBCN n = return () 854 | execSBCHL = return () 855 | execAND r = return () 856 | execANDN n = return () 857 | execANDHL = return () 858 | execOR r = return () 859 | execORN n = return () 860 | execORHL = return () 861 | execXOR r = return () 862 | execXORN n = return () 863 | execXORHL = return () 864 | execCP r = return () 865 | execCPN n = return () 866 | execCPHL = return () 867 | execINC r = return () 868 | execINC2 rp = return () 869 | execINCHL = return () 870 | execDEC r = return () 871 | execDEC2 rp = return () 872 | execDECHL = return () 873 | execADD2HL rp = return () 874 | execADD2SP n = return () 875 | execSWAP r = return () 876 | execSWAPHL = return () 877 | execDAA = error "DAA | NOT IMPLEMENTED" 878 | execCPL = return () 879 | execCCF = return () 880 | execSCF = return () 881 | execNOP = incPC1 882 | execHALT = incPC2 883 | execSTOP = incPC2 884 | execDI = incPC1 885 | execEI = incPC1 886 | execRLCA = return () 887 | execRLA = return () 888 | execRRCA = return () 889 | execRRA = return () 890 | execRLC r = return () 891 | execRLCHL = return () 892 | execRL r = return () 893 | execRLHL = return () 894 | execRRC r = return () 895 | execRRCHL = return () 896 | execRR r = return () 897 | execRRHL = return () 898 | execSLA r = return () 899 | execSLAHL = return () 900 | execSRA r = error "SRA r | NOT IMPLEMENTED" 901 | execSRAHL = error "SRA (HL) | NOT IMPLEMENTED" 902 | execSRL r = return () 903 | execSRLHL = return () 904 | execBIT bi r = return () 905 | execBITHL bi = return () 906 | execSET bi r = return () 907 | execSETHL bi = return () 908 | execRES bi r = return () 909 | execRESHL bi = return () 910 | execJP Nothing nn = return () 911 | execJP (Just cc) nn = return () 912 | execJPHL = return () 913 | execJR Nothing n = return () 914 | execJR (Just cc) n = return () 915 | execCALL Nothing nn = return () 916 | execCALL (Just cc) nn = return () 917 | execRST ra = return () 918 | execRET Nothing = return () 919 | execRET (Just cc) = return () 920 | execRETI = return () 921 | 922 | incPC1 = modifyIORef (msRegPC s) (+1) 923 | incPC2 = modifyIORef (msRegPC s) (+2) 924 | incPC3 = modifyIORef (msRegPC s) (+3) 925 | 926 | --------------------------------------------------------------------------------