├── assets ├── nestest.nes ├── mariobros.png ├── instr_test-v5 │ ├── 13-rts.nes │ ├── 14-rti.nes │ ├── 15-brk.nes │ ├── 01-basics.nes │ ├── 05-zp_xy.nes │ ├── 07-abs_xy.nes │ ├── 08-ind_x.nes │ ├── 09-ind_y.nes │ ├── 11-stack.nes │ ├── 02-implied.nes │ ├── 03-immediate.nes │ ├── 04-zero_page.nes │ ├── 06-absolute.nes │ ├── 10-branches.nes │ ├── 12-jmp_jsr.nes │ └── 16-special.nes └── instr_misc │ ├── 01-abs_x_wrap.nes │ ├── 02-branch_wrap.nes │ ├── 03-dummy_reads.nes │ └── 04-dummy_reads_apu.nes ├── .gitignore ├── src └── clones │ ├── nes │ ├── mappers.clj │ ├── blargg.clj │ ├── nestest.clj │ ├── mappers │ │ └── nrom.clj │ ├── memory.clj │ └── rom.clj │ ├── byte.clj │ ├── device.clj │ ├── fps.clj │ ├── cpu │ ├── memory.clj │ ├── debug.clj │ └── addressing.clj │ ├── ppu │ ├── debug.clj │ ├── nametable.clj │ └── memory.clj │ ├── nes.clj │ ├── gui.clj │ ├── ppu.clj │ └── cpu.clj ├── spec └── clones │ ├── byte_spec.clj │ ├── ppu │ ├── nametable_spec.clj │ └── memory_spec.clj │ ├── nes │ ├── mappers │ │ └── nrom_spec.clj │ ├── rom_spec.clj │ └── memory_spec.clj │ ├── cpu_timing_spec.clj │ ├── cpu │ └── addressing_spec.clj │ ├── ppu_spec.clj │ └── cpu_spec.clj ├── project.clj └── README.md /assets/nestest.nes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samfoo/clones/HEAD/assets/nestest.nes -------------------------------------------------------------------------------- /assets/mariobros.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samfoo/clones/HEAD/assets/mariobros.png -------------------------------------------------------------------------------- /assets/instr_test-v5/13-rts.nes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samfoo/clones/HEAD/assets/instr_test-v5/13-rts.nes -------------------------------------------------------------------------------- /assets/instr_test-v5/14-rti.nes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samfoo/clones/HEAD/assets/instr_test-v5/14-rti.nes -------------------------------------------------------------------------------- /assets/instr_test-v5/15-brk.nes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samfoo/clones/HEAD/assets/instr_test-v5/15-brk.nes -------------------------------------------------------------------------------- /assets/instr_test-v5/01-basics.nes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samfoo/clones/HEAD/assets/instr_test-v5/01-basics.nes -------------------------------------------------------------------------------- /assets/instr_test-v5/05-zp_xy.nes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samfoo/clones/HEAD/assets/instr_test-v5/05-zp_xy.nes -------------------------------------------------------------------------------- /assets/instr_test-v5/07-abs_xy.nes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samfoo/clones/HEAD/assets/instr_test-v5/07-abs_xy.nes -------------------------------------------------------------------------------- /assets/instr_test-v5/08-ind_x.nes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samfoo/clones/HEAD/assets/instr_test-v5/08-ind_x.nes -------------------------------------------------------------------------------- /assets/instr_test-v5/09-ind_y.nes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samfoo/clones/HEAD/assets/instr_test-v5/09-ind_y.nes -------------------------------------------------------------------------------- /assets/instr_test-v5/11-stack.nes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samfoo/clones/HEAD/assets/instr_test-v5/11-stack.nes -------------------------------------------------------------------------------- /assets/instr_misc/01-abs_x_wrap.nes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samfoo/clones/HEAD/assets/instr_misc/01-abs_x_wrap.nes -------------------------------------------------------------------------------- /assets/instr_misc/02-branch_wrap.nes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samfoo/clones/HEAD/assets/instr_misc/02-branch_wrap.nes -------------------------------------------------------------------------------- /assets/instr_misc/03-dummy_reads.nes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samfoo/clones/HEAD/assets/instr_misc/03-dummy_reads.nes -------------------------------------------------------------------------------- /assets/instr_test-v5/02-implied.nes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samfoo/clones/HEAD/assets/instr_test-v5/02-implied.nes -------------------------------------------------------------------------------- /assets/instr_test-v5/03-immediate.nes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samfoo/clones/HEAD/assets/instr_test-v5/03-immediate.nes -------------------------------------------------------------------------------- /assets/instr_test-v5/04-zero_page.nes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samfoo/clones/HEAD/assets/instr_test-v5/04-zero_page.nes -------------------------------------------------------------------------------- /assets/instr_test-v5/06-absolute.nes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samfoo/clones/HEAD/assets/instr_test-v5/06-absolute.nes -------------------------------------------------------------------------------- /assets/instr_test-v5/10-branches.nes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samfoo/clones/HEAD/assets/instr_test-v5/10-branches.nes -------------------------------------------------------------------------------- /assets/instr_test-v5/12-jmp_jsr.nes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samfoo/clones/HEAD/assets/instr_test-v5/12-jmp_jsr.nes -------------------------------------------------------------------------------- /assets/instr_test-v5/16-special.nes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samfoo/clones/HEAD/assets/instr_test-v5/16-special.nes -------------------------------------------------------------------------------- /assets/instr_misc/04-dummy_reads_apu.nes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samfoo/clones/HEAD/assets/instr_misc/04-dummy_reads_apu.nes -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | /lib 3 | /classes 4 | /checkouts 5 | pom.xml 6 | *.jar 7 | *.class 8 | *.swp 9 | *.swo 10 | .lein-repl-history 11 | .lein-deps-sum 12 | .lein-failures 13 | .lein-plugins 14 | .DS_Store 15 | -------------------------------------------------------------------------------- /src/clones/nes/mappers.clj: -------------------------------------------------------------------------------- 1 | (ns clones.nes.mappers) 2 | 3 | (defprotocol Mapper 4 | "A mapper is a cartridge" 5 | (prg-read [this addr] "Read program data on the mapper") 6 | (prg-write [this v addr] "Write program data on the mapper") 7 | (chr-read [this addr] "Read graphics data on the mapper") 8 | (chr-write [this v addr] "Write graphics data on the mapper")) 9 | 10 | -------------------------------------------------------------------------------- /spec/clones/byte_spec.clj: -------------------------------------------------------------------------------- 1 | (ns clones.byte-spec 2 | (:require [speclj.core :refer :all] 3 | [clones.byte :refer :all])) 4 | 5 | (describe "Unsigned bits, bytes and words" 6 | (describe "low-byte" 7 | (it "should return the lower byte of a 2 byte word" 8 | (should= 0xee (low-byte 0xffee)))) 9 | 10 | (describe "high-byte" 11 | (it "should return the upper byte of a 2 byte word" 12 | (should= 0xff (high-byte 0xff00))))) 13 | -------------------------------------------------------------------------------- /src/clones/byte.clj: -------------------------------------------------------------------------------- 1 | (ns clones.byte) 2 | 3 | (defn unsigned-byte [b] (bit-and 0xff b)) 4 | (defn unsigned-word [w] (bit-and 0xffff w)) 5 | (defn bit-set? [x bit-idx] (= 6 | 1 7 | (bit-and 8 | 1 9 | (bit-shift-right x bit-idx)))) 10 | 11 | (defn high-byte [word] (unsigned-byte (bit-shift-right word 8))) 12 | (defn low-byte [word] (unsigned-byte word)) 13 | -------------------------------------------------------------------------------- /src/clones/device.clj: -------------------------------------------------------------------------------- 1 | (ns clones.device) 2 | 3 | (defprotocol Device 4 | "A memory mapped I/O device that can be read from or written to." 5 | (device-read [m addr] "Reads a single byte from the device") 6 | (device-write [m v addr] "Writes a single byte to the device and returns the 7 | mutated device (or a new instance)")) 8 | 9 | (extend-protocol Device 10 | clojure.lang.Associative 11 | (device-read [this addr] [(get this addr 0) this]) 12 | (device-write [this v addr] [v (assoc this addr v)])) 13 | 14 | -------------------------------------------------------------------------------- /src/clones/fps.clj: -------------------------------------------------------------------------------- 1 | (ns clones.fps 2 | (:gen-class :main true) 3 | (:require [clones.nes :refer :all])) 4 | 5 | ;; (defn- run-to-frame [current last-frame] 6 | ;; (let [rendered-frame (get-in last-frame [:ppu :frame-count]) 7 | ;; current-frame (get-in current [:ppu :frame-count])] 8 | ;; (if (= rendered-frame current-frame) 9 | ;; (recur (system-step current) last-frame) 10 | ;; current))) 11 | 12 | (defmacro now [] 13 | `(System/currentTimeMillis)) 14 | 15 | (defn- run-and-display-fps [nes] 16 | (let [start (now) 17 | next-frame (step-frame nes) 18 | elapsed (- (now) start) 19 | fps (* 1000 (/ 1 elapsed))] 20 | (print (format "\r%-8.2f fps" (float fps))) 21 | (flush) 22 | (recur next-frame))) 23 | 24 | (defn -main [& args] 25 | (let [rom (first args) 26 | nes (init-nes rom)] 27 | (run-and-display-fps nes))) 28 | 29 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject clones "0.1" 2 | :description "An NES emulator with style" 3 | :url "http://github.com/samfoo/clones" 4 | :global-vars {*warn-on-reflection* true} 5 | :license {:name "GPLv3" 6 | :url "http://www.gnu.org/copyleft/gpl.html"} 7 | :dependencies [[org.clojure/clojure "1.5.1"] 8 | [org.clojure/algo.monads "0.1.4"] 9 | [seesaw "1.4.4"] 10 | [clansi "1.0.0"]] 11 | :profiles {:dev {:dependencies [[speclj "2.5.0"]]} 12 | 13 | :nestest {:main clones.nes.nestest 14 | :uberjar-name "nestest.jar"} 15 | 16 | :blargg {:main clones.nes.blargg 17 | :aot :all 18 | :uberjar-name "blargg-tester.jar"} 19 | 20 | :fps {:main clones.fps 21 | :aot :all 22 | :uberjar-name "fps.jar"} 23 | 24 | :gui {:main clones.gui 25 | :aot :all 26 | :uberjar-name "gui.jar"}} 27 | :plugins [[speclj "2.7.0"]] 28 | :test-paths ["spec"]) 29 | 30 | -------------------------------------------------------------------------------- /src/clones/cpu/memory.clj: -------------------------------------------------------------------------------- 1 | (ns clones.cpu.memory 2 | (:require [clojure.algo.monads :refer :all] 3 | [clones.nes.memory :refer :all] 4 | [clones.byte :refer :all])) 5 | 6 | (defn io-read [addr] 7 | (fn [machine] 8 | (mem-read machine addr))) 9 | 10 | (defn io-write [v addr] 11 | (fn [machine] 12 | (mem-write machine v addr))) 13 | 14 | (defn io-write-word [v addr] 15 | (let [high (high-byte v) 16 | low (low-byte v)] 17 | (domonad state-m 18 | [a (io-write high (inc addr)) 19 | b (io-write low addr)] 20 | b))) 21 | 22 | (defn io-read-word [addr] 23 | (domonad state-m 24 | [high (io-read (inc addr)) 25 | low (io-read addr)] 26 | (bit-or (bit-shift-left high 8) low))) 27 | 28 | (defmacro with-io-> [steps expr] 29 | `(domonad state-m ~steps ~expr)) 30 | 31 | 32 | (defmacro io-> [machine & steps] 33 | `(reduce 34 | (fn [~'mem ~'step] 35 | (~'step (second ~'mem))) 36 | [nil ~machine] 37 | [~@steps])) 38 | 39 | (defmacro io-debug-> [machine & steps] 40 | `(first 41 | (reduce 42 | (fn [~'mem ~'step] 43 | (~'step (second ~'mem))) 44 | [nil ~machine] 45 | [~@steps]))) 46 | 47 | -------------------------------------------------------------------------------- /src/clones/nes/blargg.clj: -------------------------------------------------------------------------------- 1 | (ns clones.nes.blargg 2 | (:gen-class :main true) 3 | (:require [clojure.java.io :refer :all] 4 | [clones.cpu :refer :all] 5 | [clones.nes :refer :all] 6 | [clones.nes.rom :refer :all] 7 | [clones.cpu.debug :refer :all] 8 | [clones.cpu.memory :refer :all])) 9 | 10 | (defn- await-test-start [nes] 11 | (if (= 0x80 (io-debug-> nes (io-read 0x6000))) 12 | nes 13 | (recur (system-step nes)))) 14 | 15 | (defn- read-null-term-str-from [nes addr] 16 | (let [b (io-debug-> nes (io-read addr)) 17 | c (when-not (zero? b) 18 | (char b))] 19 | (if (nil? c) 20 | "" 21 | (str c (read-null-term-str-from nes (inc addr)))))) 22 | 23 | (defn- current-result-text [nes] 24 | (read-null-term-str-from nes 0x6004)) 25 | 26 | (defn- await-test-finish [nes] 27 | (let [status (io-debug-> nes (io-read 0x6000))] 28 | (if (= status 0x80) 29 | (recur (system-step nes)) 30 | nes))) 31 | 32 | (defn -main [& args] 33 | (doseq [rom args] 34 | (time 35 | (let [nes (init-nes rom) 36 | pre-test-nes (await-test-start nes) 37 | result-state (await-test-finish pre-test-nes)] 38 | (println (current-result-text result-state)))))) 39 | 40 | -------------------------------------------------------------------------------- /src/clones/ppu/debug.clj: -------------------------------------------------------------------------------- 1 | (ns clones.ppu.debug 2 | (:require [clones.device :refer :all])) 3 | 4 | (defn- pattern-table-tile-row-at [ppu pattern-table-addr i row] 5 | (let [start (-> i 6 | (bit-shift-left 4) 7 | (bit-and 0x0ff0) 8 | (bit-or pattern-table-addr) 9 | (bit-or row)) 10 | memory (:memory ppu) 11 | pixel-row-low (first (device-read memory start)) 12 | pixel-row-high (first (device-read memory (+ start 8)))] 13 | (reduce (fn [palette-indices i] 14 | (let [low-bit (-> pixel-row-low 15 | (bit-shift-right i) 16 | (bit-and 1)) 17 | high-bit (-> pixel-row-high 18 | (bit-shift-right i) 19 | (bit-and 1) 20 | (bit-shift-left 1)) 21 | palette-index (bit-or low-bit high-bit)] 22 | (cons palette-index palette-indices))) 23 | [] 24 | (range 8)))) 25 | 26 | (defn- pattern-table-tile-at [ppu pattern-table-addr i] 27 | (map 28 | (fn [row] 29 | (pattern-table-tile-row-at ppu pattern-table-addr i row)) 30 | (range 8))) 31 | 32 | (defn pattern-table-tiles [ppu table] 33 | (let [pattern-table-addr (condp = table 34 | :left 0x0000 35 | :right 0x1000)] 36 | (map 37 | (fn [i] 38 | (pattern-table-tile-at ppu pattern-table-addr i)) 39 | (range 256)))) 40 | -------------------------------------------------------------------------------- /src/clones/ppu/nametable.clj: -------------------------------------------------------------------------------- 1 | (ns clones.ppu.nametable 2 | (:require [clones.device :refer :all])) 3 | 4 | (defn- nametable-with-horizontal-mirroring [logical-table] 5 | (condp = logical-table 6 | 0 :nametable-0 7 | 1 :nametable-0 8 | 2 :nametable-1 9 | 3 :nametable-1)) 10 | 11 | (defn- nametable-with-vertical-mirroring [logical-table] 12 | (condp = logical-table 13 | 0 :nametable-0 14 | 1 :nametable-1 15 | 2 :nametable-0 16 | 3 :nametable-1)) 17 | 18 | (defn- nametable-for-addr [nametables addr] 19 | (let [logical-table (bit-shift-right (bit-and 0xc00 addr) 10)] 20 | (condp = (:mirroring nametables) 21 | :horizontal (nametable-with-horizontal-mirroring logical-table) 22 | :vertical (nametable-with-vertical-mirroring logical-table)))) 23 | 24 | (defn- nametable-read [nametables addr] 25 | (let [relative-addr (bit-and addr 0x3ff) 26 | nametable-n (nametable-for-addr nametables addr)] 27 | (get (nametable-n nametables) relative-addr 0))) 28 | 29 | (defn- nametable-write [nametables v addr] 30 | (let [relative-addr (bit-and addr 0x3ff) 31 | nametable-n (nametable-for-addr nametables addr) 32 | after-write (assoc (nametable-n nametables) relative-addr v)] 33 | (assoc nametables nametable-n after-write))) 34 | 35 | (defrecord Nametables [mirroring 36 | nametable-0 37 | nametable-1] 38 | Device 39 | (device-read [this addr] [(nametable-read this addr) this]) 40 | (device-write [this v addr] [v (nametable-write this v addr)])) 41 | 42 | (defn make-nametables [mirroring] 43 | (Nametables. mirroring {} {})) 44 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Clojure and the Immutable Emulator 2 | 3 | *Clones* is an 4 | [NES](https://en.wikipedia.org/wiki/Nintendo_Entertainment_System) emulator for 5 | the gentlman (or woman) of distinguished immutable character. A core design 6 | goal is to build an entirely functional emulator. 7 | 8 | Is this madness? **Yes**. 9 | 10 | But how many cools would it be to be able to rewind and fast forward a game 11 | through states? Eleventy. 12 | 13 | ### Why would you do such a thing? 14 | 15 | > Mallory is famously quoted as having replied to the question **"Why do you 16 | > want to climb Mount Everest?"** with the retort **"Because it's there"** 17 | > 18 | > [- quoteth the 'pedes](https://en.wikipedia.org/wiki/George_Mallory) 19 | 20 | ### So... you want to join the immutability cult? 21 | 22 | Be advised that the current performance is about 1 frame per second on a new 23 | 15" Macbook Retina. Totally playable speed. 24 | 25 | $ lein with-profile gui run [rom] 26 | 27 | ![Super Awesome Cool Screenshot](https://raw.github.com/samfoo/clones/master/assets/mariobros.png) 28 | 29 | ### How do I test this monstrosity? 30 | 31 | The specs test *clones'* internal API, state and functioning: 32 | 33 | $ lein spec 34 | 35 | There are also [test ROMs](http://wiki.nesdev.com/w/index.php/Emulator_tests) 36 | that exercise the entire machine. 37 | 38 | The nestest binary can be run and verified against the known-good 39 | [Nintendulator](http://www.qmtpro.com/~nes/nintendulator/) debug log: 40 | 41 | $ lein with-profile nestest run 42 | 43 | [Blargg's](http://blargg.8bitalley.com/nes-tests/) CPU tests can be run 44 | headlessly and report results: 45 | 46 | $ lein with-profile blargg run [rom] 47 | 48 | -------------------------------------------------------------------------------- /spec/clones/ppu/nametable_spec.clj: -------------------------------------------------------------------------------- 1 | (ns clones.ppu.nametable-spec 2 | (:require [speclj.core :refer :all] 3 | [clones.device :refer :all] 4 | [clones.ppu.nametable :refer :all])) 5 | 6 | (def horizontal (make-nametables :horizontal)) 7 | (def vertical (make-nametables :vertical)) 8 | 9 | (describe "PPU nametables" 10 | (defn check-mirroring [mirrored addr-tables] 11 | (describe "nametable I/O" 12 | (describe "device-write" 13 | (for [[addr table] addr-tables] 14 | (it (str "should write to nametable " table " when the address is " 15 | "between $" (format "%04x" addr) " and $" 16 | (format "%04x" (+ 0x400 addr -1))) 17 | (let [after-write (second (device-write mirrored 0xbe addr))] 18 | (should= 0xbe (get (table after-write) 0 0)))))) 19 | 20 | (describe "device-read" 21 | (for [[addr table] addr-tables] 22 | (it (str "should read from nametable " table " when the address is " 23 | "between $" (format "%04x" addr) " and $" 24 | (format "%04x" (+ 0x400 addr -1))) 25 | (let [nametable-w-data (assoc mirrored table {0 0xbe}) 26 | v (first (device-read nametable-w-data addr))] 27 | (should= 0xbe v))))))) 28 | 29 | (describe "with vertical mirroring" 30 | (def addr-tables {0xc00 :nametable-1 31 | 0x800 :nametable-0 32 | 0x400 :nametable-1 33 | 0x000 :nametable-0}) 34 | 35 | (check-mirroring vertical addr-tables)) 36 | 37 | (describe "with horizontal mirroring" 38 | (def addr-tables {0xc00 :nametable-1 39 | 0x800 :nametable-1 40 | 0x400 :nametable-0 41 | 0x000 :nametable-0}) 42 | (check-mirroring horizontal addr-tables))) 43 | 44 | -------------------------------------------------------------------------------- /src/clones/nes.clj: -------------------------------------------------------------------------------- 1 | (ns clones.nes 2 | (:require [clones.cpu :refer :all] 3 | [clones.ppu :refer :all] 4 | [clones.nes.rom :refer :all] 5 | [clones.cpu.debug :refer :all] 6 | [clojure.pprint :refer :all] 7 | [clones.nes.memory :refer :all]) 8 | (:use [clones.ppu.memory :only [make-ppu-memory]])) 9 | 10 | (defn- catch-ppu-up [nes cycles] 11 | (loop [system nes 12 | remaining-cycles cycles] 13 | (if (zero? remaining-cycles) 14 | system 15 | (recur (transient-ppu-step system) (- remaining-cycles 1))))) 16 | 17 | (defn- handle-interrupts [nes] 18 | (condp = (:interrupt nes) 19 | :nmi (perform-nmi nes) 20 | nes)) 21 | 22 | (defn system-step [nes] 23 | (let [after-interrupts (handle-interrupts nes) 24 | [cpu-cycles machine-after-cpu] (cpu-step after-interrupts) 25 | with-updated-ppu (catch-ppu-up machine-after-cpu (* 3 cpu-cycles))] 26 | with-updated-ppu)) 27 | 28 | (defn- transient-machine [nes] 29 | (let [ppu (:ppu nes)] 30 | (assoc nes :ppu (transient ppu)))) 31 | 32 | (defn- persistent-machine! [nes] 33 | (let [ppu (:ppu nes)] 34 | (assoc nes :ppu (persistent! ppu)))) 35 | 36 | (defn step-frame [nes] 37 | (let [current-frame (get-in nes [:ppu :frame-count])] 38 | (loop [rendered-frame current-frame 39 | transient-state (transient-machine nes)] 40 | (if (== current-frame rendered-frame) 41 | (recur (get-in transient-state [:ppu :frame-count]) 42 | (system-step transient-state)) 43 | (persistent-machine! transient-state))))) 44 | 45 | (defn- make-nes [cpu ppu apu mapper] 46 | (merge cpu {:ppu ppu 47 | :apu apu 48 | :internal-ram {} 49 | :mapper mapper 50 | :interrupt nil})) 51 | 52 | (defn init-nes [rom-file] 53 | (let [rom (read-rom rom-file) 54 | mapper (make-mapper rom) 55 | ppu (make-ppu (make-ppu-memory mapper)) 56 | apu {0x04 0xff 57 | 0x05 0xff 58 | 0x06 0xff 59 | 0x07 0xff 60 | 0x15 0xff} 61 | cpu (make-cpu) 62 | machine (make-nes cpu ppu apu mapper) 63 | reset-vector (first (mem-read-word machine 0xfffc)) 64 | machine-ready (assoc machine :pc reset-vector)] 65 | machine-ready)) 66 | 67 | -------------------------------------------------------------------------------- /src/clones/ppu/memory.clj: -------------------------------------------------------------------------------- 1 | (ns clones.ppu.memory 2 | (:require [clones.device :refer :all] 3 | [clones.nes.mappers :refer :all] 4 | [clones.ppu.nametable :refer :all])) 5 | 6 | (defn- bus-read-device [bus device-name addr] 7 | (let [[v new-device] (device-read (device-name bus) addr)] 8 | [v (assoc bus device-name new-device)])) 9 | 10 | (defn- bus-write-device [bus device-name v addr] 11 | (let [[_ new-device] (device-write (device-name bus) v addr)] 12 | [v (assoc bus device-name new-device)])) 13 | 14 | (defn- bus-read-pattern-tables [bus addr] 15 | (let [[v new-device] (chr-read (:mapper bus) addr)] 16 | [v (assoc bus :mapper new-device)])) 17 | 18 | (defn- bus-write-pattern-tables [bus v addr] 19 | (let [[_ new-device] (chr-write (:mapper bus) v addr)] 20 | [v (assoc bus :mapper new-device)])) 21 | 22 | (defn- bus-read-nametables [bus addr] 23 | (let [relative-addr (bit-and 0xfff addr)] 24 | (bus-read-device bus :nametables relative-addr))) 25 | 26 | (defn- bus-write-nametables [bus v addr] 27 | (let [relative-addr (bit-and 0xfff addr)] 28 | (bus-write-device bus :nametables v relative-addr))) 29 | 30 | (defn- palette-mirrored-addr [addr] 31 | (if (mod addr 4) 32 | (bit-and 0xf addr) 33 | (bit-and 0x1f addr))) 34 | 35 | (defn- bus-read-palette-ram [bus addr] 36 | (let [relative-addr (palette-mirrored-addr addr)] 37 | (bus-read-device bus :palette-ram relative-addr))) 38 | 39 | (defn- bus-write-palette-ram [bus v addr] 40 | (let [relative-addr (palette-mirrored-addr addr)] 41 | (bus-write-device bus :palette-ram v relative-addr))) 42 | 43 | (defn- bus-read [bus addr] 44 | (cond 45 | (< addr 0x2000) (bus-read-pattern-tables bus addr) 46 | (< addr 0x3eff) (bus-read-nametables bus addr) 47 | :else (bus-read-palette-ram bus addr))) 48 | 49 | (defn- bus-write [bus v addr] 50 | (cond 51 | (< addr 0x2000) (bus-write-pattern-tables bus v addr) 52 | (< addr 0x3eff) (bus-write-nametables bus v addr) 53 | :else (bus-write-palette-ram bus v addr))) 54 | 55 | (defrecord Bus [mapper 56 | nametables 57 | palette-ram] 58 | Device 59 | (device-read [this addr] (bus-read this addr)) 60 | (device-write [this v addr] (bus-write this v addr))) 61 | 62 | (defn make-ppu-memory [mapper] 63 | (Bus. mapper (make-nametables (:mirroring mapper)) {})) 64 | -------------------------------------------------------------------------------- /src/clones/nes/nestest.clj: -------------------------------------------------------------------------------- 1 | (ns clones.nes.nestest 2 | (:gen-class :main true) 3 | (:require [clojure.java.io :refer :all] 4 | [clansi :refer :all] 5 | [clones.cpu :refer :all] 6 | [clones.nes :refer :all] 7 | [clones.nes.rom :refer :all] 8 | [clones.cpu.debug :refer :all] 9 | [clones.cpu.memory :refer :all])) 10 | 11 | (defn- lazy-debug-w-cycles [nes total-cycles] 12 | (let [cycles (mod (* 3 total-cycles) 341)] 13 | (cons 14 | (format "%s CYC:%3d" (debug-step nes) cycles) 15 | (lazy-seq 16 | (let [[cs new-nes] (cpu-step nes)] 17 | (lazy-debug-w-cycles new-nes (+ total-cycles cs))))))) 18 | 19 | (defn- lazy-debug [nes] 20 | (lazy-debug-w-cycles nes 0)) 21 | 22 | (defn read-nintendulator-log [f] 23 | (with-open [rdr (reader f)] 24 | (doall (map #(clojure.string/join "" (take 81 %)) (line-seq rdr))))) 25 | 26 | (defn pad-lengths [a b] 27 | (let [expected-size (max (count a) (count b)) 28 | padded-a (str a (clojure.string/join "" (repeat (- expected-size (count a)) " "))) 29 | padded-b (str b (clojure.string/join "" (repeat (- expected-size (count b)) " ")))] 30 | [padded-a padded-b])) 31 | 32 | 33 | (defn color-diff [a b color] 34 | (let [[padded-a padded-b] (pad-lengths a b)] 35 | (clojure.string/join "" (map 36 | (fn [achar bchar] 37 | (if (not= achar bchar) 38 | (style (str achar) color) 39 | achar)) 40 | padded-a padded-b)))) 41 | 42 | (defn pretty-diff [expected actual] 43 | [(color-diff expected actual :green) (color-diff actual expected :red)]) 44 | 45 | (defn- get-context [line-no] 46 | (let [log (read-nintendulator-log "assets/nestest.log") 47 | context (take (min line-no 15) (drop (- line-no 15) log))] 48 | (map #(str " " %) context))) 49 | 50 | (defn -main [& args] 51 | (let [machine (-> (init-nes "assets/nestest.nes") 52 | (assoc :pc 0xc000))] 53 | (doseq [[expected actual line] (map vector 54 | (read-nintendulator-log "assets/nestest.log") 55 | (lazy-debug machine) 56 | (range))] 57 | (when (not= expected actual) 58 | (let [[e a] (pretty-diff expected actual)] 59 | (println (clojure.string/join "\n" (get-context line))) 60 | (println (format "%-5d expected: %s" line e)) 61 | (println (format "%-5d actual : %s" line a)) 62 | (System/exit 1)))) 63 | (println "All systems nominal"))) 64 | -------------------------------------------------------------------------------- /src/clones/nes/mappers/nrom.clj: -------------------------------------------------------------------------------- 1 | (ns clones.nes.mappers.nrom 2 | (:require [clones.device :refer :all] 3 | [clones.nes.mappers :refer :all])) 4 | 5 | (defn- nrom-read-ram [nrom addr] 6 | [(get (:prg-ram nrom) addr 0) nrom]) 7 | 8 | (defn- nrom-write-ram [nrom v addr] 9 | (let [ram (:prg-ram nrom)] 10 | [v (assoc nrom 11 | :prg-ram 12 | (assoc ram addr v))])) 13 | 14 | (defn- nrom-read-prg-rom [nrom addr] 15 | (let [^int num-banks (:prg-banks nrom) 16 | ^ints prg-rom (:prg-rom nrom)] 17 | (if (>= addr 0xc000) 18 | [(aget ^ints prg-rom (+ (* 0x4000 (- num-banks 1)) (bit-and addr 0x3fff))) nrom] 19 | [(aget ^ints prg-rom (bit-and addr 0x3fff)) nrom]))) 20 | 21 | (defn- nrom-read-chr-ram [nrom addr] 22 | (let [chr-data (:chr-data nrom)] 23 | [(get chr-data addr 0) nrom])) 24 | 25 | (defn- nrom-write-chr-ram [nrom v addr] 26 | [v (assoc-in nrom [:chr-data addr] v)]) 27 | 28 | (defn- nrom-read-chr-rom [nrom addr] 29 | (let [^ints chr-data (:chr-data nrom)] 30 | (if (and (> 0xfff addr) (> (:chr-banks nrom) 1)) 31 | [(aget ^ints chr-data addr) nrom] 32 | [(aget ^ints chr-data addr) nrom]))) 33 | 34 | (defrecord NROM [^int prg-banks 35 | ^ints prg-rom 36 | 37 | prg-ram 38 | 39 | ^int chr-banks 40 | ^ints chr-data 41 | ^boolean chr-ram? 42 | 43 | mirroring] 44 | Mapper 45 | (chr-read [this addr] 46 | (if chr-ram? 47 | (nrom-read-chr-ram this addr) 48 | (nrom-read-chr-rom this addr))) 49 | 50 | (chr-write [this v addr] 51 | (if chr-ram? 52 | (nrom-write-chr-ram this v addr) 53 | (throw (ex-info 54 | "Invalid memory access on NROM cartidge" 55 | {:addr addr :type :write})))) 56 | 57 | (prg-read [this addr] 58 | (cond 59 | (< addr 0x6000) (throw (ex-info 60 | "Invalid memory access on NROM cartridge" 61 | {:addr addr :type :read})) 62 | (< addr 0x8000) (nrom-read-ram this addr) 63 | :else (nrom-read-prg-rom this addr))) 64 | 65 | (prg-write [this v addr] 66 | (cond 67 | (< addr 0x6000) (throw (ex-info 68 | "Invalid memory access on NROM cartridge" 69 | {:addr addr :type :write})) 70 | (< addr 0x8000) (nrom-write-ram this v addr) 71 | :else [v this]))) 72 | 73 | (defn nrom [rom] 74 | (let [chr-data (if (:chr-ram? rom) 75 | {} 76 | (int-array (:chr-data rom)))] 77 | (NROM. (:prg-banks rom) (int-array (:prg-data rom)) 78 | {} 79 | (:chr-banks rom) chr-data 80 | (:chr-ram? rom) 81 | (:mirroring rom)))) 82 | 83 | -------------------------------------------------------------------------------- /src/clones/nes/memory.clj: -------------------------------------------------------------------------------- 1 | (ns clones.nes.memory 2 | (:require [clones.device :refer :all] 3 | [clones.ppu :refer :all] 4 | [clones.nes.mappers :refer :all])) 5 | 6 | (declare mem-read) 7 | (declare mem-write) 8 | 9 | (defn- mem-read-internal-ram [bus addr] 10 | (let [mirrored-addr (bit-and 0x7ff addr)] 11 | [(get (:internal-ram bus) mirrored-addr 0) bus])) 12 | 13 | (defn- mem-write-internal-ram [bus v addr] 14 | (let [mirrored-addr (bit-and 0x7ff addr) 15 | ram (:internal-ram bus) 16 | after-write (assoc ram mirrored-addr v)] 17 | [v (assoc bus :internal-ram after-write)])) 18 | 19 | (defn- mem-read-device [bus device-name addr] 20 | (let [[v new-device] (device-read (device-name bus) addr)] 21 | [v (assoc bus device-name new-device)])) 22 | 23 | (defn- mem-write-device [bus device-name v addr] 24 | (let [[_ new-device] (device-write (device-name bus) v addr)] 25 | [v (assoc bus device-name new-device)])) 26 | 27 | (defn- mem-read-ppu [bus addr] 28 | (let [relative-addr (bit-and 7 addr)] 29 | (ppu-register-read bus relative-addr))) 30 | 31 | (defn- mem-write-ppu [bus v addr] 32 | (let [relative-addr (bit-and 7 addr)] 33 | (ppu-register-write bus v relative-addr))) 34 | 35 | (defn- mem-read-apu [bus addr] 36 | (let [relative-addr (bit-and 0x1f addr)] 37 | (mem-read-device bus :apu relative-addr))) 38 | 39 | (defn- mem-write-apu [bus v addr] 40 | (let [relative-addr (bit-and 0x1f addr)] 41 | (mem-write-device bus :apu v relative-addr))) 42 | 43 | (defn- mem-read-mapper [bus addr] 44 | (let [[v new-device] (prg-read (:mapper bus) addr)] 45 | [v (assoc bus :mapper new-device)])) 46 | 47 | (defn- mem-write-mapper [bus v addr] 48 | (let [[_ new-device] (prg-write (:mapper bus) v addr)] 49 | [v (assoc bus :mapper new-device)])) 50 | 51 | (defn- mem-write-dma-at [bus addr] 52 | (let [[v after-read] (mem-read bus addr) 53 | [_ after-write] (mem-write bus v 0x2004)] 54 | after-write)) 55 | 56 | (defn- mem-write-dma [bus v addr] 57 | (let [start-addr (bit-shift-left v 8) 58 | end-addr (+ 0x100 start-addr) 59 | addrs (range start-addr end-addr) 60 | after-dma (reduce mem-write-dma-at bus addrs)] 61 | [v after-dma])) 62 | 63 | (defn mem-read [bus addr] 64 | (cond 65 | (< addr 0x2000) (mem-read-internal-ram bus addr) 66 | (< addr 0x4000) (mem-read-ppu bus addr) 67 | (< addr 0x4020) (mem-read-apu bus addr) 68 | :else (mem-read-mapper bus addr))) 69 | 70 | (defn mem-read-word [bus addr] 71 | (let [[high bus] (mem-read bus (+ 1 addr)) 72 | [low bus] (mem-read bus addr)] 73 | [(bit-or (bit-shift-left high 8) low) bus])) 74 | 75 | (defn mem-write [bus v addr] 76 | (cond 77 | (< addr 0x2000) (mem-write-internal-ram bus v addr) 78 | (< addr 0x4000) (mem-write-ppu bus v addr) 79 | (< addr 0x4014) (mem-write-apu bus v addr) 80 | (= addr 0x4014) (mem-write-dma bus v addr) 81 | (< addr 0x4020) (mem-write-apu bus v addr) 82 | :else (mem-write-mapper bus v addr))) 83 | -------------------------------------------------------------------------------- /src/clones/cpu/debug.clj: -------------------------------------------------------------------------------- 1 | (ns clones.cpu.debug 2 | (:require [clones.cpu.memory :refer :all] 3 | [clones.cpu :refer :all] 4 | [clones.byte :refer :all] 5 | [clones.cpu.addressing :refer :all])) 6 | 7 | (defn- inc-pc [cpu] 8 | (update-in cpu [:pc] inc)) 9 | 10 | (defn- op-code-arg [cpu mode] 11 | (let [c (inc-pc cpu)] 12 | (condp = (mode-size mode) 13 | 0 nil 14 | 1 (io-debug-> c (io-read (:pc c))) 15 | 2 (io-debug-> c (io-read-word (:pc c)))))) 16 | 17 | (defn debug-ops-argument [cpu mode] 18 | (condp = (mode-size mode) 19 | 0 (format "%-5s" " ") 20 | 1 (format "%02X " (op-code-arg cpu mode)) 21 | 2 (format "%02X %02X" 22 | (io-debug-> cpu (io-read (inc (:pc cpu)))) 23 | (io-debug-> cpu (io-read (+ 2 (:pc cpu))))))) 24 | 25 | (defn debug-cpu-state [cpu] 26 | (format "A:%02X X:%02X Y:%02X P:%02X SP:%02X" 27 | (:a cpu) 28 | (:x cpu) 29 | (:y cpu) 30 | (:p cpu) 31 | (:sp cpu))) 32 | 33 | (defn debug-address-mode [cpu mode op-name] 34 | (let [arg (op-code-arg cpu mode) 35 | location (when (not= mode implied) 36 | (io-debug-> (inc-pc cpu) (mode))) 37 | value (when (not= mode implied) 38 | (io-debug-> (inc-pc cpu) (mode-read mode)))] 39 | (condp = mode 40 | immediate (format "#$%02X" arg) 41 | zero-page (format "$%02X = %02X" 42 | arg 43 | value) 44 | zero-page-x (format "$%02X,X @ %02X = %02X" 45 | arg 46 | (unsigned-byte location) 47 | value) 48 | zero-page-y (format "$%02X,Y @ %02X = %02X" 49 | arg 50 | (unsigned-byte location) 51 | value) 52 | indirect (let [abs (io-debug-> (inc-pc cpu) (absolute))] 53 | (format "($%04X) = %04X" 54 | abs 55 | (io-debug-> (inc-pc cpu) (io-read-word abs)))) 56 | absolute (case op-name 57 | ("jmp" "jsr") (format "$%04X" location) 58 | (format "$%04X = %02X" location value)) 59 | absolute-x (format "$%04X,X @ %04X = %02X" 60 | (io-debug-> (inc-pc cpu) (absolute)) 61 | location 62 | value) 63 | absolute-y (format "$%04X,Y @ %04X = %02X" 64 | (io-debug-> (inc-pc cpu) (absolute)) 65 | location 66 | value) 67 | indexed-indirect (format "($%02X,X) @ %02X = %04X = %02X" 68 | arg 69 | (unsigned-byte (+ arg (:x (inc-pc cpu)))) 70 | location 71 | value) 72 | indirect-indexed (format "($%02X),Y = %04X @ %04X = %02X" 73 | arg 74 | (unsigned-word (- location (:y (inc-pc cpu)))) 75 | location 76 | value) 77 | relative (format "$%04X" location) 78 | accumulator (format "%s" "A") 79 | implied ""))) 80 | 81 | (defn debug-step [cpu] 82 | (let [[op-code after-read] (io-> cpu (io-read (:pc cpu))) 83 | op (op-by-opcode op-code) 84 | {:keys [address-mode name]} (meta op)] 85 | (format "%04X %02X %s %4s %-27s %s" 86 | (:pc cpu) 87 | op-code 88 | (debug-ops-argument cpu address-mode) 89 | (if (nil? name) 90 | "???" 91 | (clojure.string/upper-case name)) 92 | (if (nil? name) 93 | "" 94 | (debug-address-mode cpu address-mode name)) 95 | (debug-cpu-state cpu)))) 96 | 97 | -------------------------------------------------------------------------------- /src/clones/cpu/addressing.clj: -------------------------------------------------------------------------------- 1 | (ns clones.cpu.addressing 2 | (:require [clones.cpu.memory :refer :all] 3 | [clones.byte :refer :all] 4 | [clojure.algo.monads :refer :all])) 5 | 6 | (defn accumulator [] (fn [cpu] [(:a cpu) cpu])) 7 | 8 | (defn immediate [] (fn [cpu] [(:pc cpu) cpu])) 9 | 10 | (defn implied [] 11 | (fn [_] 12 | (throw (Error. "Can't read/write to the implied address mode")))) 13 | 14 | (defn zero-page [] 15 | (with-io-> [cpu (fetch-state) 16 | addr (io-read (:pc cpu))] 17 | addr)) 18 | 19 | (defn zero-page-reg [reg] 20 | (with-io-> [zp-addr (zero-page) 21 | cpu (fetch-state)] 22 | (unsigned-byte (+ (reg cpu) zp-addr)))) 23 | 24 | (defn zero-page-x [] (zero-page-reg :x)) 25 | (defn zero-page-y [] (zero-page-reg :y)) 26 | 27 | (defn relative [] 28 | (with-io-> [cpu (fetch-state) 29 | offset (io-read (:pc cpu))] 30 | (unsigned-word 31 | (if (< offset 0x80) 32 | (+ 1 (:pc cpu) offset) 33 | (+ 1 (- (:pc cpu) 0x100) offset))))) 34 | 35 | (defn absolute [] 36 | (with-io-> [cpu (fetch-state) 37 | addr (io-read-word (:pc cpu))] 38 | addr)) 39 | 40 | (defn absolute-x [] 41 | (with-io-> [cpu (fetch-state) 42 | abs-addr (absolute)] 43 | (unsigned-word (+ (:x cpu) abs-addr)))) 44 | 45 | (defn absolute-y [] 46 | (with-io-> [cpu (fetch-state) 47 | abs-addr (absolute)] 48 | (unsigned-word (+ (:y cpu) abs-addr)))) 49 | 50 | (defn- indirect-high-addr [abs-addr] 51 | (if (= 0xff (bit-and 0xff abs-addr)) 52 | (bit-and abs-addr 0xff00) 53 | (inc abs-addr))) 54 | 55 | (defn indirect [] 56 | (with-io-> [abs-addr (absolute) 57 | high (io-read (indirect-high-addr abs-addr)) 58 | low (io-read abs-addr)] 59 | (bit-or (bit-shift-left high 8) low))) 60 | 61 | (defn indexed-indirect [] 62 | (with-io-> [cpu (fetch-state) 63 | pointer (io-read (:pc cpu)) 64 | high (io-read (unsigned-byte (+ pointer (:x cpu) 1))) 65 | low (io-read (unsigned-byte (+ pointer (:x cpu))))] 66 | (bit-or (bit-shift-left high 8) low))) 67 | 68 | (defn indirect-indexed-addr [] 69 | (with-io-> [cpu (fetch-state) 70 | pointer (io-read (:pc cpu)) 71 | high (io-read (unsigned-byte (inc pointer))) 72 | low (io-read (unsigned-byte pointer))] 73 | (bit-or (bit-shift-left high 8) low))) 74 | 75 | (defn indirect-indexed [] 76 | (with-io-> [cpu (fetch-state) 77 | ind-addr (indirect-indexed-addr)] 78 | (unsigned-word (+ ind-addr (:y cpu))))) 79 | 80 | (defn mode-by-name [n] 81 | (n {:zero-page zero-page 82 | :zero-page-x zero-page-x 83 | :zero-page-y zero-page-y 84 | :accumulator accumulator 85 | :implied implied 86 | :immediate immediate 87 | :absolute absolute 88 | :absolute-y absolute-y 89 | :absolute-x absolute-x 90 | :indirect indirect 91 | :relative relative 92 | :indexed-indirect indexed-indirect 93 | :indirect-indexed indirect-indexed})) 94 | 95 | (defn mode-write-mem [mode v] 96 | (with-io-> [addr (mode) 97 | result (io-write v addr)] 98 | result)) 99 | 100 | (defn mode-read-mem [mode] 101 | (with-io-> [addr (mode) 102 | result (io-read addr)] 103 | result)) 104 | 105 | (defn mode-write-reg [reg v] 106 | (fn [cpu] [v (assoc cpu reg v)])) 107 | 108 | (defn mode-read-reg [reg] 109 | (fn [cpu] [(reg cpu) cpu])) 110 | 111 | (defn mode-read [mode] 112 | (if (= mode accumulator) 113 | (mode-read-reg :a) 114 | (mode-read-mem mode))) 115 | 116 | (defn mode-write [mode v] 117 | (if (= mode accumulator) 118 | (mode-write-reg :a v) 119 | (mode-write-mem mode v))) 120 | 121 | (defn mode-size [mode] 122 | (condp = mode 123 | immediate 1 124 | zero-page 1 125 | zero-page-x 1 126 | zero-page-y 1 127 | indexed-indirect 1 128 | indirect-indexed 1 129 | relative 1 130 | absolute 2 131 | absolute-x 2 132 | absolute-y 2 133 | indirect 2 134 | 0)) 135 | 136 | -------------------------------------------------------------------------------- /spec/clones/nes/mappers/nrom_spec.clj: -------------------------------------------------------------------------------- 1 | (ns clones.nes.mappers.nrom-spec 2 | (:require [speclj.core :refer :all] 3 | [clones.device :refer :all] 4 | [clones.nes.mappers :refer :all] 5 | [clones.nes.mappers.nrom :refer :all])) 6 | 7 | (def rom-defaults {:mirroring :horizontal 8 | :prg-banks 1 9 | :prg-data (vec (repeat 0x8000 0)) 10 | :chr-banks 1 11 | :chr-ram? false 12 | :chr-data (vec (repeat 0x2000 0))}) 13 | 14 | (def rom (nrom rom-defaults)) 15 | 16 | (describe "The NROM mapper" (tags :nrom) 17 | (describe "graphics ROM" 18 | (describe "$0000 - $0fff" 19 | (describe "when there is chr RAM instead of ROM" 20 | (it "should read from chr RAM" 21 | (let [nrom-w-ram (nrom (merge rom-defaults {:chr-ram? true 22 | :chr-banks 0})) 23 | nrom-w-ram-val (assoc-in nrom-w-ram [:chr-data 0x100] 0xbe)] 24 | (should= 0xbe (first (chr-read nrom-w-ram-val 0x100))))) 25 | 26 | (it "should write to chr RAM" 27 | (let [nrom-w-ram (nrom (merge rom-defaults {:chr-ram? true 28 | :chr-banks 0})) 29 | [_ after-write] (chr-write nrom-w-ram 0xbe 0)] 30 | (should= 0xbe (first (chr-read after-write 0)))))) 31 | 32 | (let [single-bank (assoc (vec (repeat 0x2000 0)) 0 0xbe) 33 | rom-w-1-bank (nrom (merge rom-defaults {:chr-banks 1 34 | :chr-data single-bank}))] 35 | (it "should read from the first chr bank" 36 | (should= 0xbe (first (chr-read rom-w-1-bank 0))))))) 37 | 38 | (describe "program ROM" 39 | (describe "$c000 - $ffff" 40 | (it "should do nothing on writing" 41 | (let [after-write (second (prg-write rom 0xff 0xc000))] 42 | (should= 0 (first (prg-read after-write 0xc000))))) 43 | 44 | (let [single-bank (assoc (vec (repeat 0x8000 0)) 0 0xbe) 45 | rom-w-1-bank (nrom (merge rom-defaults {:prg-banks 1 46 | :prg-data single-bank}))] 47 | (describe "when there's only one bank of program ROM" 48 | (it "should read from the first bank of program ROM mirrored down" 49 | (should= 0xbe (first (prg-read rom-w-1-bank 0xc000)))))) 50 | 51 | (let [two-banks (assoc (vec (repeat 0x8000 0)) 0x4000 0xbe) 52 | rom-w-2-banks (nrom (merge rom-defaults {:prg-banks 2 53 | :prg-data two-banks}))] 54 | (describe "when there's two banks of program ROM" 55 | (it "should read from the second bank of program ROM" 56 | (should= 0xbe (first (prg-read rom-w-2-banks 0xc000))))))) 57 | 58 | (describe "$8000 - $bfff" 59 | (it "should do nothing on writing" 60 | (let [after-write (second (prg-write rom 0xff 0x8000))] 61 | (should= 0 (first (prg-read after-write 0x8000))))) 62 | 63 | (let [single-bank (assoc (vec (repeat 0x8000 0)) 0 0xbe) 64 | rom-w-1-bank (nrom (merge rom-defaults {:prg-banks 1 65 | :prg-data single-bank}))] 66 | (it "should read from the first bank of program ROM relative to $8000" 67 | (should= 0xbe (first (prg-read rom-w-1-bank 0x8000)))))) 68 | 69 | (describe "$6000 - $7fff" 70 | (it "should write to program RAM" 71 | (let [after-write (second (prg-write rom 0xff 0x6000))] 72 | (should= 0xff (first (prg-read after-write 0x6000))))) 73 | 74 | (it "should read from program RAM" 75 | (let [rom-w-ram (assoc rom :prg-ram {0x6000 0xbe})] 76 | (should= 0xbe (first (prg-read rom-w-ram 0x6000)))))) 77 | 78 | (describe "$4020 - $5fff (or anything less than $6000)" 79 | (it "should throw an exception on writing" 80 | (should-throw clojure.lang.ExceptionInfo "Invalid memory access on NROM cartridge" 81 | (prg-write rom 1 0x4020))) 82 | 83 | (it "should throw an exception on reading" 84 | (should-throw clojure.lang.ExceptionInfo "Invalid memory access on NROM cartridge" 85 | (prg-read rom 0x4020)))))) 86 | 87 | -------------------------------------------------------------------------------- /spec/clones/ppu/memory_spec.clj: -------------------------------------------------------------------------------- 1 | (ns clones.ppu.memory-spec 2 | (:require [speclj.core :refer :all] 3 | [clones.device :refer :all] 4 | [clones.nes.mappers :refer :all] 5 | [clones.ppu.memory :refer :all])) 6 | 7 | (defrecord MockMapper [prg chr] 8 | Mapper 9 | (prg-read [this addr] [(get prg addr 0) this]) 10 | (prg-write [this v addr] [v (assoc this :prg (assoc prg addr v))]) 11 | (chr-read [this addr] [(get chr addr 0) this]) 12 | (chr-write [this v addr] [v (assoc this :chr (assoc chr addr v))])) 13 | 14 | (defn stub-mapper [prg chr] (MockMapper. prg chr)) 15 | (def bus (make-ppu-memory {:mirroring :horizontal})) 16 | 17 | (describe 18 | "The PPU's memory bus mapped with devices like the pattern tables, nametables, etc" 19 | (tags :memory) 20 | 21 | (describe "$3f00 0 $3fff" 22 | (it "should write to palette RAM relative to $3f00" 23 | (let [after-write (second (device-write bus 0xff 0x3f00))] 24 | (should= 0xff (first (device-read after-write 0x3f00))))) 25 | 26 | (it "should mirror writes at $3F10/$3F14/$3F18/$3F1C to $3F00/$3F04/$3F08/$3F0C" 27 | (let [w (fn [b v addr] (second (device-write b v addr))) 28 | bus-with-value (-> bus 29 | (w 0xff 0x3f10) 30 | (w 0xf4 0x3f14) 31 | (w 0xf8 0x3f18) 32 | (w 0xfc 0x3f1c))] 33 | (should= 0xf4 (first (device-read bus-with-value 0x3f04))) 34 | (should= 0xf8 (first (device-read bus-with-value 0x3f08))) 35 | (should= 0xfc (first (device-read bus-with-value 0x3f0c))) 36 | (should= 0xff (first (device-read bus-with-value 0x3f00))))) 37 | 38 | (it "should mirror reads at $3F10/$3F14/$3F18/$3F1C to $3F00/$3F04/$3F08/$3F0C" 39 | (let [bus-with-value (assoc bus 40 | :palette-ram 41 | {0 0xff 42 | 4 0xf4 43 | 8 0xf8 44 | 0xc 0xfc})] 45 | (should= 0xf4 (first (device-read bus-with-value 0x3f14))) 46 | (should= 0xf8 (first (device-read bus-with-value 0x3f18))) 47 | (should= 0xfc (first (device-read bus-with-value 0x3f1c))) 48 | (should= 0xff (first (device-read bus-with-value 0x3f10))))) 49 | 50 | (it "should mirror every 32 bytes when reading" 51 | (let [bus-with-value (assoc bus 52 | :palette-ram 53 | {0 0xff})] 54 | (should= 0xff (first (device-read bus-with-value 0x3f20))) 55 | (should= 0xff (first (device-read bus-with-value 0x3f40))))) 56 | 57 | (it "should read from palette RAM relative to $3f00" 58 | (let [bus-with-value (assoc bus 59 | :palette-ram 60 | {0 0xff})] 61 | (should= 0xff (first (device-read bus-with-value 0x3f00)))))) 62 | 63 | (describe "$2000 - $3eff" 64 | (it "should write to the name tables relative to $2000" 65 | (let [after-write (second (device-write bus 0xff 0x2000))] 66 | (should= 0xff (first (device-read after-write 0x2000))))) 67 | 68 | (it "should mirror to $2xxx when reading from $3xxx" 69 | (let [bus-with-value (assoc bus 70 | :nametables 71 | {0 0xff})] 72 | (should= 0xff (first (device-read bus-with-value 0x3000))))) 73 | 74 | (it "should read from the name tables relative to $2000" 75 | (let [bus-with-value (assoc bus 76 | :nametables 77 | {0 0xff})] 78 | (should= 0xff (first (device-read bus-with-value 0x2000)))))) 79 | 80 | (describe "$0000 - $1fff" 81 | (it "should write to the pattern tables" 82 | (let [bus-with-mapper (assoc bus 83 | :mapper 84 | (stub-mapper {} {})) 85 | after-write (second (device-write bus-with-mapper 0xff 0))] 86 | (should= 0xff (first (device-read after-write 0))))) 87 | 88 | (it "should read from the pattern tables" 89 | (let [bus-with-value (assoc bus 90 | :mapper 91 | (stub-mapper {} {0 0xff}))] 92 | (should= 0xff (first (device-read bus-with-value 0))))))) 93 | 94 | -------------------------------------------------------------------------------- /src/clones/gui.clj: -------------------------------------------------------------------------------- 1 | (ns clones.gui 2 | (:gen-class :main true) 3 | (:require [clones.nes :refer :all] 4 | [clones.cpu.debug :refer :all] 5 | [clones.ppu.debug :refer :all] 6 | [seesaw.graphics :as graphics] 7 | [seesaw.core :refer :all] 8 | [seesaw.bind :as b]) 9 | (:import [java.awt Graphics2D RenderingHints])) 10 | 11 | (defn- run [nes-atom nes] 12 | (let [rendered-frame-id (get-in @nes-atom [:ppu :frame-count]) 13 | machine-frame-id (get-in nes [:ppu :frame-count])] 14 | (when (not= rendered-frame-id machine-frame-id) 15 | (reset! nes-atom nes)) 16 | (recur nes-atom (system-step nes)))) 17 | 18 | (defn- run-forever [nes] 19 | (fn [] 20 | (run nes @nes))) 21 | 22 | (defn- run-machine [nes] 23 | (let [thread (Thread. (run-forever nes))] 24 | (.start thread))) 25 | 26 | (defn- get-color [pixel] 27 | (condp = pixel 28 | 0 :white 29 | 1 :red 30 | 2 :green 31 | 3 :blue)) 32 | 33 | (defn render-buffer [g frame-buffer] 34 | (.drawImage g frame-buffer 0 0 256 240 nil)) 35 | 36 | (defn- paint [c g nes] 37 | (let [frame-buffer (get-in nes [:ppu :background-frame-buffer])] 38 | (render-buffer g frame-buffer))) 39 | 40 | (defn- paint-pattern-table-tile [c g tile x y] 41 | (doseq [row (range 8) 42 | col (range 8)] 43 | (let [pixel (nth (nth tile row) col)] 44 | (doto g 45 | (.setRenderingHint RenderingHints/KEY_ANTIALIASING RenderingHints/VALUE_ANTIALIAS_OFF)) 46 | 47 | (graphics/draw g 48 | (graphics/rect (+ x col) (+ y row) 1) 49 | (graphics/style :background (get-color pixel)))))) 50 | 51 | (defn- paint-pattern-table-tiles [c g tiles] 52 | (doseq [i (range 256)] 53 | (let [tile (nth tiles i) 54 | x (* 8 (mod i 16)) 55 | y (* 8 (int (/ i 16)))] 56 | (paint-pattern-table-tile c g tile x y)))) 57 | 58 | (defn- paint-pattern-table [c g nes which-table] 59 | (let [tiles (pattern-table-tiles (:ppu nes) which-table)] 60 | (paint-pattern-table-tiles c g tiles))) 61 | 62 | (defn- show-pattern-table-window! [nes] 63 | (let [pattern-table-left (canvas :id :pattern-table-left 64 | :preferred-size [(* 16 8 2) :by (* 16 8 2)] 65 | :paint (fn [c g] 66 | (graphics/scale g 2) 67 | (paint-pattern-table c g @nes :left))) 68 | 69 | pattern-table-right (canvas :id :pattern-table-right 70 | :preferred-size [(* 16 8 2) :by (* 16 8 2)] 71 | :paint (fn [c g] 72 | (graphics/scale g 2) 73 | (paint-pattern-table c g @nes :right))) 74 | 75 | pattern-tables (border-panel 76 | :hgap 5 77 | :east (border-panel 78 | :vgap 5 79 | :north (label 80 | :text "Left $0000" 81 | :halign :center) 82 | :south pattern-table-left) 83 | :west (border-panel 84 | :vgap 5 85 | :north (label 86 | :text "Right $1000" 87 | :halign :center) 88 | :south pattern-table-right)) 89 | 90 | pattern-tables-window (frame :title "Clones - Pattern Tables" 91 | :visible? true 92 | :resizable? false 93 | :content (border-panel 94 | :center pattern-tables 95 | :hgap 10 96 | :border 10))] 97 | (pack! pattern-tables-window))) 98 | 99 | 100 | (defn -main [& args] 101 | (native!) 102 | (let [rom (first args) 103 | nes (atom (init-nes rom)) 104 | 105 | screen (canvas :id :screen 106 | :paint (fn [c g] (paint c g @nes)) 107 | :background :black) 108 | 109 | screen-window (frame :title "Clones" 110 | :width 256 111 | :height 256 112 | :visible? true 113 | :on-close :dispose 114 | :content screen)] 115 | ;; (show-pattern-table-window! nes) 116 | (run-machine nes) 117 | (timer (fn [_] (repaint! screen) 20)))) 118 | -------------------------------------------------------------------------------- /spec/clones/nes/rom_spec.clj: -------------------------------------------------------------------------------- 1 | (ns clones.nes.rom-spec 2 | (:require [speclj.core :refer :all] 3 | [clones.nes.rom :refer :all])) 4 | 5 | (def invalid-header (repeat 16 0)) 6 | (def valid-header [78 69 83 26 1 1 0 0 0 0 0 0 0 0 0 0]) 7 | 8 | (def with-2-chr-banks [78 69 83 26 1 2 0 0 0 0 0 0 0 0 0 0]) 9 | (def with-chr-ram [78 69 83 26 1 0 0 0 0 0 0 0 0 0 0 0]) 10 | 11 | (def with-mapper-1 [78 69 83 26 1 1 16 0 0 0 0 0 0 0 0 0]) 12 | (def with-mapper-16 [78 69 83 26 1 1 0 16 0 0 0 0 0 0 0 0]) 13 | (def with-mapper-17 [78 69 83 26 1 1 16 16 0 0 0 0 0 0 0 0]) 14 | 15 | (def with-four-screen-mirroring [78 69 83 26 1 1 8 0 0 0 0 0 0 0 0 0]) 16 | (def with-horizontal-mirroring [78 69 83 26 1 1 0 0 0 0 0 0 0 0 0 0]) 17 | (def with-vertical-mirroring [78 69 83 26 1 1 1 0 0 0 0 0 0 0 0 0]) 18 | 19 | (def with-trainer [78 69 83 26 1 1 4 0 0 0 0 0 0 0 0 0 0]) 20 | (def with-battery [78 69 83 26 1 1 2 0 0 0 0 0 0 0 0 0 0]) 21 | 22 | (def with-playchoice [78 69 83 26 1 1 0 2 0 0 0 0 0 0 0 0 0]) 23 | (def with-vs-unisystem [78 69 83 26 1 1 0 1 0 0 0 0 0 0 0 0 0]) 24 | 25 | (def with-nes-2 [78 69 83 26 1 1 0 8 0 0 0 0 0 0 0 0 0]) 26 | 27 | (describe "Making a mapper from a ROM" 28 | (describe "make-mapper" 29 | (it "should throw and exception if the mapper is unsupported" 30 | (should-throw clojure.lang.ExceptionInfo "Unsupported mapper" 31 | (make-mapper {:mapper -1}))))) 32 | 33 | (describe "An iNES ROM parser" 34 | (describe "parse-ines-header" 35 | (it "should read that a ROM uses chr ROM when the 6th byte is not 0" 36 | (should-not (:chr-ram? (parse-ines-header valid-header)))) 37 | 38 | (it "should read that a ROM uses chr RAM when the 6th byte is 0" 39 | (should (:chr-ram? (parse-ines-header with-chr-ram)))) 40 | 41 | (it "should read the number of chr banks from the 6th byte" 42 | (should= 2 (:chr-banks (parse-ines-header with-2-chr-banks)))) 43 | 44 | (it "should read that it is not NES-2 format if bits 3 & 2 of the 7th byte aren't 10" 45 | (should-not (:nes-2? (parse-ines-header valid-header)))) 46 | 47 | (it "should read that it is NES-2 format if bits 3 & 2 of the 7th byte are 10" 48 | (should (:nes-2? (parse-ines-header with-nes-2)))) 49 | 50 | (it "should read that it is not a vs-unisystem if bit 0 of the 7th byte is 0" 51 | (should-not (:vs-unisystem? (parse-ines-header valid-header)))) 52 | 53 | (it "should read that it is a vs-unisystem if bit 0 of the 7th byte is 1" 54 | (should (:vs-unisystem? (parse-ines-header with-vs-unisystem)))) 55 | 56 | (it "should read that it is not a playchoice-10 if bit 1 of the 7th byte is 0" 57 | (should-not (:playchoice-10? (parse-ines-header valid-header)))) 58 | 59 | (it "should read that it is a playchoice-10 if bit 1 of the 7th byte is 1" 60 | (should (:playchoice-10? (parse-ines-header with-playchoice)))) 61 | 62 | (it "should read that there is no battery backing if bit 1 of the 6th byte is 0" 63 | (should-not (:battery-backed? (parse-ines-header valid-header)))) 64 | 65 | (it "should read that there is a battery backing if bit 1 of the 6th byte is 1" 66 | (should (:battery-backed? (parse-ines-header with-battery)))) 67 | 68 | (it "should read that there is no trainer if bit 2 of the 6th byte is 0" 69 | (should-not (:trainer-present? (parse-ines-header valid-header)))) 70 | 71 | (it "should read that there is a trainer if bit 2 of the 6th byte is 1" 72 | (should (:trainer-present? (parse-ines-header with-trainer)))) 73 | 74 | (it "should read the mirroring mode as the combination of the third and 75 | 0th bit in the 6th byte 76 | 77 | 0xx0 -> horizontal mirroring 78 | 0xx1 -> vertical mirroring 79 | 1xxx -> four-way mirroring" 80 | (should= :vertical (:mirroring (parse-ines-header with-vertical-mirroring))) 81 | (should= :horizontal (:mirroring (parse-ines-header with-horizontal-mirroring))) 82 | (should= :four-screen (:mirroring (parse-ines-header with-four-screen-mirroring)))) 83 | 84 | (it "should or both the lower and upper nibbles for the mapper together" 85 | (should= 17 86 | (:mapper (parse-ines-header with-mapper-17)))) 87 | 88 | (it "should read the mapper number upper nibble as the first four bits of 89 | the 7th byte" 90 | (should= 16 91 | (:mapper (parse-ines-header with-mapper-16)))) 92 | 93 | (it "should read the mapper number lower nibble as the first four bits of 94 | the 6th byte" 95 | (should= 1 96 | (:mapper (parse-ines-header with-mapper-1)))) 97 | 98 | (it "should read the 6th byte as the pattern table size in 8KB units converted to number of bytes" 99 | (should= 8192 100 | (:chr-rom-size (parse-ines-header valid-header)))) 101 | 102 | (it "should read the 5th byte as the program rom size in 16KB units converted to number of bytes" 103 | (should= 16384 104 | (:prg-rom-size (parse-ines-header valid-header)))) 105 | 106 | (it "should throw an error if the first four bytes don't match the expected signature" 107 | (should-throw Error "Invalid iNES file" 108 | (parse-ines-header invalid-header))))) 109 | -------------------------------------------------------------------------------- /spec/clones/nes/memory_spec.clj: -------------------------------------------------------------------------------- 1 | (ns clones.nes.memory-spec 2 | (:require [speclj.core :refer :all] 3 | [clones.nes.memory :refer :all] 4 | [clones.nes.mappers :refer :all] 5 | [clones.device :refer :all] 6 | [clojure.algo.monads :refer :all])) 7 | 8 | (defrecord MockMapper [prg chr] 9 | Mapper 10 | (prg-read [this addr] [(get prg addr 0) this]) 11 | (prg-write [this v addr] [v (assoc this :prg (assoc prg addr v))]) 12 | (chr-read [this addr] [(get chr addr 0) this]) 13 | (chr-write [this v addr] [v (assoc this :chr (assoc chr addr v))])) 14 | 15 | (defn mapper [] (MockMapper. {} {})) 16 | (defn stub-mapper [prg chr] (MockMapper. prg chr)) 17 | (def bus {:internal-ram {} 18 | :ppu {} 19 | :apu {} 20 | :mapper (mapper)}) 21 | 22 | (xit 23 | "The NES's memory bus, mapped with devices like APU, PPU, and cartridge" 24 | (tags :memory) 25 | 26 | (defn should-return-machine-after-reading [addr] 27 | (it "should return the bus after reading" 28 | (should= bus (second (mem-read bus addr))))) 29 | 30 | (describe "$4020 - $ffff" 31 | (should-return-machine-after-reading 0x6000) 32 | 33 | (it "should write to the mapper" 34 | (let [after-write (second (mem-write bus 0xff 0x4020))] 35 | (should= 0xff (first (mem-read after-write 0x4020))))) 36 | 37 | (it "should read from the mapper" 38 | (let [machine-with-value (assoc bus 39 | :mapper (stub-mapper {0x6000 0xbe} {}))] 40 | (should= 0xbe (first (mem-read machine-with-value 0x6000)))))) 41 | 42 | (describe "$4014 where the written value is $xx" 43 | (should-return-machine-after-reading 0x4014) 44 | 45 | (it "should read 256 bytes from $xx00 - $xxff and write them to $2014" 46 | (let [ppu {} ;; TODO: FIXME (dma-ppu) 47 | machine-with-oam (merge bus 48 | {:mapper (stub-mapper {0x4400 0x11 0x44ff 0xff} {}) 49 | :ppu ppu}) 50 | [_ after-dma] (mem-write machine-with-oam 0x44 0x4014)] 51 | (should= 256 (count (:writes (:ppu after-dma)))) 52 | (should= {4 0x11} (first (:writes (:ppu after-dma)))) 53 | (should= {4 0xff} (last (:writes (:ppu after-dma))))))) 54 | 55 | (describe "$4000 - $4013, $4015" 56 | (should-return-machine-after-reading 0x4000) 57 | 58 | (it "should write to the APU at $4015" 59 | (let [after-write (second (mem-write bus 0xff 0x4015))] 60 | (should= 0xff (first (mem-read after-write 0x4015))))) 61 | 62 | (it "should read from the APU at $4015, relative to $4000" 63 | (let [machine-with-value (assoc bus 64 | :apu 65 | {0x15 0xbe})] 66 | (should= 0xbe (first (mem-read machine-with-value 0x4015))))) 67 | 68 | (it "should write to the APU" 69 | (let [after-write (second (mem-write bus 0xff 0x4000))] 70 | (should= 0xff (first (mem-read after-write 0x4000))))) 71 | 72 | (it "should read from the APU relative to $4000" 73 | (let [machine-with-value (assoc bus 74 | :apu 75 | {0 0xbe})] 76 | (should= 0xbe (first (mem-read machine-with-value 0x4000)))))) 77 | 78 | (describe "$2000 - $3fff" 79 | (should-return-machine-after-reading 0x2000) 80 | 81 | (it "should mirror all addresses > $2007 to $2000 - $2007 when writing" 82 | (let [after-write (second (mem-write bus 0xff 0x2008))] 83 | (should= 0xff (first (mem-read after-write 0x2000))))) 84 | 85 | (it "should write to the PPU" 86 | (let [after-write (second (mem-write bus 0xff 0x2000))] 87 | (should= 0xff (first (mem-read after-write 0x2000))))) 88 | 89 | (it "should mirror all addresses > $2007 to $2000 - $2007 when reading" 90 | (let [machine-with-value (assoc bus 91 | :ppu 92 | {0 0xbe})] 93 | (should= 0xbe (first (mem-read machine-with-value 0x2008))))) 94 | 95 | (it "should read from the PPU relative to $2000" 96 | (let [machine-with-value (assoc bus 97 | :ppu 98 | {0 0xbe})] 99 | (should= 0xbe (first (mem-read machine-with-value 0x2000)))))) 100 | 101 | (describe "$0000 - $1fff" 102 | (should-return-machine-after-reading 0) 103 | 104 | (it "should mirror all addresses > $07ff to $0000 - $07ff when writing" 105 | (let [after-write (second (mem-write bus 0xff 0x800))] 106 | (should= 0xff (first (mem-read after-write 0))))) 107 | 108 | (it "should write to internal RAM" 109 | (let [after-write (second (mem-write bus 0xff 0))] 110 | (should= 0xff (first (mem-read after-write 0))))) 111 | 112 | (it "should mirror all addresses > $07ff to $0000 - $07ff when reading" 113 | (let [machine-with-value (assoc bus 114 | :internal-ram 115 | {0 0xbe})] 116 | (should= 0xbe (first (mem-read machine-with-value 0x800))))) 117 | 118 | (it "should read from internal RAM" 119 | (let [machine-with-value (assoc bus 120 | :internal-ram 121 | {0 0xbe})] 122 | (should= 0xbe (first (mem-read machine-with-value 0))))))) 123 | 124 | -------------------------------------------------------------------------------- /src/clones/nes/rom.clj: -------------------------------------------------------------------------------- 1 | (ns clones.nes.rom 2 | (:use [clones.byte :refer :all] 3 | [clones.nes.mappers.nrom :refer :all] 4 | [clojure.java.io :only [file input-stream]])) 5 | 6 | (def mapper-names { 7 | 0 "NROM", 8 | 1 "SxROM, MMC1", 9 | 2 "UxROM", 10 | 3 "CNROM", 11 | 4 "TxROM, MMC3, MMC6", 12 | 5 "ExROM, MMC5", 13 | 7 "AxROM", 14 | 9 "PxROM, MMC2", 15 | 10 "FxROM, MMC4", 16 | 11 "Color Dreams", 17 | 13 "CPROM", 18 | 15 "100-in-1 Contra Function 16", 19 | 16 "Bandai EPROM (24C02)", 20 | 18 "Jaleco SS8806", 21 | 19 "Namco 163", 22 | 21 "VRC4a, VRC4c", 23 | 22 "VRC2a", 24 | 23 "VRC2b, VRC4e", 25 | 24 "VRC6a", 26 | 25 "VRC4b, VRC4d", 27 | 26 "VRC6b", 28 | 34 "BNROM, NINA-001", 29 | 64 "RAMBO-1", 30 | 66 "GxROM, MxROM", 31 | 68 "After Burner", 32 | 69 "FME-7, Sunsoft 5B", 33 | 71 "Camerica/Codemasters", 34 | 73 "VRC3", 35 | 74 "Pirate MMC3 derivative", 36 | 75 "VRC1", 37 | 76 "Namco 109 variant", 38 | 79 "NINA-03/NINA-06", 39 | 85 "VRC7", 40 | 86 "JALECO-JF-13", 41 | 94 "Senjou no Ookami", 42 | 105 "NES-EVENT Similar to MMC1", 43 | 113 "NINA-03/NINA-06??", 44 | 118 "TxSROM, MMC3", 45 | 119 "TQROM, MMC3", 46 | 159 "Bandai EPROM (24C01)", 47 | 166 "SUBOR", 48 | 167 "SUBOR", 49 | 180 "Crazy Climber", 50 | 185 "CNROM with protection diodes", 51 | 192 "Pirate MMC3 derivative", 52 | 206 "DxROM, Namco 118 / MIMIC-1", 53 | 210 "Namco 175 and 340", 54 | 228 "Action 52", 55 | 232 "Camerica/Codemasters Quattro", 56 | }) 57 | 58 | (def mappers {0 nrom}) 59 | 60 | (defn make-mapper [rom] 61 | (let [mapper-id (:mapper rom) 62 | mapper-fn (get mappers mapper-id)] 63 | (if (nil? mapper-fn) 64 | (throw (ex-info "Unsupported mapper" 65 | {:id mapper-id 66 | :name (get mapper-names mapper-id "unknown")})) 67 | (mapper-fn rom)))) 68 | 69 | (defn- bit-mask [n] 70 | (if (pos? n) 71 | (bit-or 72 | (bit-shift-left 1 (dec n)) 73 | (bit-mask (dec n))) 74 | 0)) 75 | 76 | (defn- sum [s] (reduce + 0 s)) 77 | 78 | (defn- bit-val [b len offset] 79 | (let [shift-amt (- offset len) 80 | mask (bit-shift-left 81 | (bit-mask len) 82 | shift-amt) 83 | result (bit-shift-right 84 | (bit-and b mask) 85 | shift-amt)] 86 | (if (= 1 len) 87 | (= result 1) 88 | result))) 89 | 90 | (defn- bit-seq [b bit-lengths] 91 | (map-indexed 92 | (fn [i len] 93 | (let [offset (- 8 (sum (take i bit-lengths)))] 94 | (bit-val b len offset))) 95 | bit-lengths)) 96 | 97 | (defn- bit-map [b & desc] 98 | (let [ks (map first (partition 2 desc)) 99 | vs (map second (partition 2 desc))] 100 | (zipmap ks (bit-seq b vs)))) 101 | 102 | (def prg-bank-size 16384) 103 | (def chr-bank-size 8192) 104 | 105 | (defn parse-ines-header [data] 106 | (let [sig (take 4 data) 107 | prg-rom-size (* prg-bank-size (nth data 4)) 108 | prg-banks (nth data 4) 109 | chr-rom-size (* chr-bank-size (nth data 5)) 110 | chr-banks (nth data 5) 111 | chr-ram? (zero? (nth data 5)) 112 | flags-6 (bit-map (nth data 6) 113 | :lower-mapper-nibble 4 114 | :mirroring-upper 1 115 | :trainer-present? 1 116 | :battery-backed? 1 117 | :mirroring-lower 1) 118 | flags-7 (bit-map (nth data 7) 119 | :upper-mapper-nibble 4 120 | :nes-2 2 121 | :playchoice-10? 1 122 | :vs-unisystem? 1) 123 | mapper (bit-or (:lower-mapper-nibble flags-6) 124 | (bit-shift-left 125 | (:upper-mapper-nibble flags-7) 126 | 4)) 127 | mirroring (if (:mirroring-upper flags-6) 128 | :four-screen 129 | (if (:mirroring-lower flags-6) 130 | :vertical 131 | :horizontal)) 132 | nes-2? (= 2 (:nes-2 flags-7))] 133 | (if (not= sig [78 69 83 26]) 134 | (throw (Error. "Invalid iNES file")) 135 | (merge {:prg-rom-size prg-rom-size 136 | :prg-banks prg-banks 137 | :chr-rom-size chr-rom-size 138 | :chr-banks chr-banks 139 | :chr-ram? chr-ram? 140 | :mapper mapper 141 | :mapper-name (get mapper-names mapper) 142 | :mirroring mirroring 143 | :nes-2? nes-2?} 144 | 145 | (select-keys flags-6 [:trainer-present? 146 | :battery-backed?]) 147 | 148 | (select-keys flags-7 [:playchoice-10? 149 | :vs-unisystem?]))))) 150 | 151 | (defn file-data [filename] 152 | (with-open [f (input-stream filename)] 153 | (let [size (.length (file filename)) 154 | ba (byte-array size)] 155 | (.read f ba) 156 | (map unsigned-byte (sequence ba))))) 157 | 158 | (def header-size 16) 159 | (def trainer-size 512) 160 | 161 | (defn read-rom [filename] 162 | (let [data (file-data filename) 163 | header-data (take header-size data) 164 | header (parse-ines-header header-data) 165 | prg-offset (if (:trainer-present? header) 166 | (+ header-size trainer-size) 167 | header-size) 168 | prg-data (->> data 169 | (drop prg-offset) 170 | (take (:prg-rom-size header))) 171 | chr-offset (if (:trainer-present? header) 172 | (+ header-size trainer-size (:prg-rom-size header)) 173 | (+ header-size (:prg-rom-size header))) 174 | chr-data (->> data 175 | (drop chr-offset) 176 | (take (:chr-rom-size header)))] 177 | (merge header {:prg-data (vec prg-data) 178 | :chr-data (vec chr-data)}))) 179 | 180 | -------------------------------------------------------------------------------- /spec/clones/cpu_timing_spec.clj: -------------------------------------------------------------------------------- 1 | (ns clones.cpu-timing-spec 2 | (:require [speclj.core :refer :all] 3 | [clones.cpu :refer :all] 4 | [clones.cpu.memory :refer :all] 5 | [clones.nes.mappers :refer :all] 6 | [clones.cpu.addressing :refer :all])) 7 | 8 | (defrecord MockMapper [prg chr] 9 | Mapper 10 | (prg-read [this addr] [(get prg addr 0) this]) 11 | (prg-write [this v addr] [v (assoc this :prg (assoc prg addr v))]) 12 | (chr-read [this addr] [(get chr addr 0) this]) 13 | (chr-write [this v addr] [v (assoc this :chr (assoc chr addr v))])) 14 | (defn mapper [] (MockMapper. {} {})) 15 | 16 | (def cpu (merge (make-cpu) {:internal-ram {} 17 | :ppu {} 18 | :apu {} 19 | :mapper (mapper)})) 20 | (def cpu-with-carry (assoc cpu :p carry-flag)) 21 | (def cpu-with-zero (assoc cpu :p zero-flag)) 22 | (def cpu-with-negative (assoc cpu :p negative-flag)) 23 | (def cpu-with-decimal (assoc cpu :p decimal-flag)) 24 | (def cpu-with-interrupt (assoc cpu :p interrupt-flag)) 25 | (def cpu-with-overflow (assoc cpu :p overflow-flag)) 26 | 27 | (describe "The timing of instructions on the NES's 6502 2A03/7 CPU" 28 | (describe "execute-with-timing" 29 | (describe "when an address mode crosses a page" 30 | (def will-cross 31 | (let [with-registers (merge cpu {:x 0xff 32 | :y 0xff})] 33 | (second (io-> with-registers 34 | (io-write-word 0x00f0 0) 35 | (io-write-word 0xf0 0xf0))))) 36 | 37 | (def expected-times {0x7d 5 0x79 5 0x71 6 0x3d 5 0x39 5 0x31 6 0xdd 5 0xd9 5 38 | 0xd1 6 0x5d 5 0x59 5 0x51 6 0xbd 5 0xb9 5 0xb1 6 0xbe 5 39 | 0xbc 5 0x1d 5 0x19 5 0x11 6 0xfd 5 0xf9 5 0xf1 6}) 40 | 41 | (for [[op-code expected] expected-times] 42 | (let [op (op-by-opcode op-code) 43 | timing (timing-by-opcode op-code) 44 | n (:name (meta op))] 45 | (describe (format "$%02x (%s)" op-code n) 46 | (it (str "should take " expected " cycles when crossing a page") 47 | (let [[cycles _] (execute-with-timing will-cross op timing)] 48 | (should= expected cycles))))))) 49 | 50 | 51 | (describe "branching instructions" 52 | (def expected-times {0x90 [cpu cpu-with-carry] 53 | 0xb0 [cpu-with-carry cpu] 54 | 0xf0 [cpu-with-zero cpu] 55 | 0x30 [cpu-with-negative cpu] 56 | 0xd0 [cpu cpu-with-zero] 57 | 0x10 [cpu cpu-with-negative] 58 | 0x50 [cpu cpu-with-overflow] 59 | 0x70 [cpu-with-overflow cpu]}) 60 | 61 | (for [[op-code [branch-cpu no-branch-cpu]] expected-times] 62 | (let [op (op-by-opcode op-code) 63 | timing (timing-by-opcode op-code) 64 | n (:name (meta op))] 65 | (describe (format "$%02x (%s)" op-code n) 66 | (it (str "shouldn't count as crossing a page unless the " 67 | "instruction that would be after the branch op is on a " 68 | "different page that where the branch ended up") 69 | (let [on-page-boundary (assoc branch-cpu :pc 0xff) 70 | will-branch (second (io-> on-page-boundary 71 | (io-write 0xff 0x10))) 72 | [cycles _] (execute-with-timing will-branch op timing)] 73 | (should= 3 cycles))) 74 | 75 | (it "should take 4 cycles when branching to a new page" 76 | (let [will-cross (second (io-> branch-cpu 77 | (io-write 0x90 0))) 78 | [cycles _] (execute-with-timing will-cross op timing)] 79 | (should= 4 cycles))) 80 | 81 | (it "should take 2 cycles when not branching" 82 | (let [[cycles _] (execute-with-timing no-branch-cpu op timing)] 83 | (should= 2 cycles))) 84 | 85 | (it "should take 3 cycles when branching" 86 | (let [[cycles _] (execute-with-timing branch-cpu op timing)] 87 | (should= 3 cycles))))))) 88 | 89 | (describe "without page-crossing or branching" 90 | (def expected-times {0x69 2 0x65 3 0x75 4 0x6d 4 0x7d 4 0x79 4 0x61 6 0x71 5 91 | 0x29 2 0x25 3 0x35 4 0x2d 4 0x3d 4 0x39 4 0x21 6 0x31 5 92 | 0x0a 2 0x06 5 0x16 6 0x0e 6 0x1e 7 0x24 3 0x2c 4 0x00 7 93 | 0x18 2 0xd8 2 0x58 2 0xb8 2 0xc9 2 0xc5 3 0xd5 4 0xcd 4 94 | 0xdd 4 0xd9 4 0xc1 6 0xd1 5 0xe0 2 0xe4 3 0xec 4 0xc0 2 95 | 0xc4 3 0xcc 4 0xc6 5 0xd6 6 0xce 6 0xde 7 0xca 2 0x88 2 96 | 0x49 2 0x45 3 0x55 4 0x4d 4 0x5d 4 0x59 4 0x41 6 0x51 5 97 | 0xe6 5 0xf6 6 0xee 6 0xfe 7 0xe8 2 0xc8 2 0x4c 3 0x6c 5 98 | 0x20 6 0x60 6 0x40 6 0xa9 2 0xa5 3 0xb5 4 0xad 4 0xbd 4 99 | 0xb9 4 0xa1 6 0xb1 5 0xa2 2 0xa6 3 0xb6 4 0xae 4 0xbe 4 100 | 0xa0 2 0xa4 3 0xb4 4 0xac 4 0xbc 4 0x4a 2 0x46 5 0x56 6 101 | 0x4e 6 0x5e 7 0xea 2 0x09 2 0x05 3 0x15 4 0x0d 4 0x1d 4 102 | 0x19 4 0x01 6 0x11 5 0x48 3 0x08 3 0x68 4 0x28 4 0x2a 2 103 | 0x26 5 0x36 6 0x2e 6 0x3e 7 0x6a 2 0x66 5 0x76 6 0x6e 6 104 | 0x7e 7 0xe9 2 0xe5 3 0xf5 4 0xed 4 0xfd 4 0xf9 4 0xe1 6 105 | 0xf1 5 0x38 2 0xf8 2 0x78 2 0x85 3 0x95 4 0x8d 4 0x9d 5 106 | 0x99 5 0x81 6 0x91 6 0x86 3 0x96 4 0x8e 4 0x84 3 0x94 4 107 | 0x8c 4 0xaa 2 0xa8 2 0xba 2 0x8a 2 0x9a 2 0x98 2}) 108 | 109 | (for [[op-code expected] expected-times] 110 | (let [op (op-by-opcode op-code) 111 | timing (timing-by-opcode op-code) 112 | n (:name (meta op))] 113 | (it (str "should take " expected " cycles when executing op code " 114 | (format "$%02x" op-code) " (" n ")") 115 | (let [[cycles _] (execute-with-timing cpu op timing)] 116 | (should= expected cycles)))))))) 117 | 118 | -------------------------------------------------------------------------------- /spec/clones/cpu/addressing_spec.clj: -------------------------------------------------------------------------------- 1 | (ns clones.cpu.addressing-spec 2 | (:require [speclj.core :refer :all] 3 | [clojure.algo.monads :refer :all] 4 | [clones.cpu :refer :all] 5 | [clones.cpu.memory :refer :all] 6 | [clones.cpu.addressing :refer :all])) 7 | 8 | (def cpu (make-cpu)) 9 | (def cpu-with-zp 10 | (let [zp-addr 0x55 11 | [_ new-cpu] (io-> cpu 12 | (io-write 0xbe zp-addr) 13 | (io-write 0x55 (:pc cpu)))] 14 | new-cpu)) 15 | 16 | (defn do-mode-write [mode cpu v] 17 | (second (io-> cpu 18 | (mode-write mode v)))) 19 | 20 | (defn do-mode-read [mode cpu] 21 | (first (io-> cpu 22 | (mode-read mode)))) 23 | 24 | (defn do-mode [mode cpu] 25 | (first (io-> cpu (mode)))) 26 | 27 | (describe "6502 Operation Addressing Mode" (tags :addressing) 28 | (describe "mode-size" 29 | (it "should say all other modes are zero" 30 | (for [mode #{implied accumulator}] 31 | (should= 0 (mode-size mode)))) 32 | 33 | (it "should say all modes that require one byte to read are one" 34 | (for [mode #{immediate zero-page zero-page-x zero-page-y indexed-indirect indirect-indexed relative}] 35 | (should= 1 (mode-size mode)))) 36 | 37 | (it "should say all modes that require two bytes to read are two" 38 | (for [mode #{absolute absolute-x absolute-y indirect}] 39 | (should= 2 (mode-size mode))))) 40 | 41 | (describe "indirect-indexed" 42 | (it "should wrap the result if the address would be greater than two bytes" 43 | (let [[_ new-cpu] (io-> (merge cpu {:pc 1 :y 0xff}) 44 | (io-write 0xff 1) 45 | (io-write 0xff 0) 46 | (io-write 0xff 0xff))] 47 | (should= 0xfe (do-mode indirect-indexed new-cpu)))) 48 | 49 | (it "should read the high byte from 0x00 when 'read(PC) + 1' would cross a page" 50 | (let [[_ new-cpu] (io-> (assoc cpu :pc 1) 51 | (io-write 0xff 1) 52 | (io-write 0xbe 0) 53 | (io-write 0xef 0xff))] 54 | (should= 0xbeef (do-mode indirect-indexed new-cpu)))) 55 | 56 | (it "should be 'readWord(read(PC)) + Y'" 57 | (let [[_ new-cpu] (io-> (merge cpu {:y 2 :pc 0}) 58 | ;; Target address: 0x05ff 59 | ;; +------------------------+ 60 | ;; |addr: 00 | 01 | 02 | 03 | 61 | ;; +------------------------+ 62 | ;; |val : 02 | 00 | fd | 05 | 63 | ;; +------------------------+ 64 | ;; ^ ^ 65 | ;; PC Pointer ref 66 | (io-write 0x02 0) 67 | (io-write 0xfd 2) 68 | (io-write 0x05 3))] 69 | (should= 0x05ff (do-mode indirect-indexed new-cpu))))) 70 | 71 | (describe "indexed-indirect" 72 | (it "should read the high byte from 0x00 when 'read(PC) + X + 1' would cross a page" 73 | (let [[_ new-cpu] (io-> (assoc cpu :pc 1) 74 | (io-write 0xff 1) 75 | (io-write 0xbe 0) 76 | (io-write 0xef 0xff))] 77 | (should= 0xbeef (do-mode indexed-indirect new-cpu)))) 78 | 79 | (it "should be 'readWord(read(PC) + X)'" 80 | (let [[_ new-cpu] (io-> (merge cpu {:x 2 :pc 0}) 81 | ;; Target address: 0x1005 82 | ;; +----------------------------------+ 83 | ;; |addr: 00 | 01 | 02 | 03 | 04 | 05 | 84 | ;; +----------------------------------+ 85 | ;; |val : 02 | 00 | 00 | 00 | 05 | 10 | 86 | ;; +----------------------------------+ 87 | ;; ^ ^ 88 | ;; PC Pointer ref 89 | (io-write 2 0) 90 | (io-write 5 4) 91 | (io-write 0x10 5))] 92 | (should= 0x1005 (do-mode indexed-indirect new-cpu))))) 93 | 94 | (describe "indirect" 95 | (it "should be the word at read($xx00) | read($xxff) if the address mode 96 | is indirect and the pointer points to the end of the page" 97 | (let [[_ new-cpu] (io-> cpu 98 | (io-write-word 0x1ff 0) 99 | (io-write 0xbe 0x100) 100 | (io-write 0xef 0x1ff))] 101 | (should= 0xbeef (do-mode indirect new-cpu)))) 102 | 103 | (it "should be 'readWord(readWord(PC))'" 104 | (let [[_ new-cpu] (io-> cpu 105 | (io-write-word 0x100 0) 106 | (io-write-word 0x200 0x100))] 107 | (should= 0x200 (do-mode indirect new-cpu))))) 108 | 109 | (describe "absolute-y" 110 | (it "should wrap if the address would be greater than 2 bytes" 111 | (let [[_ new-cpu] (io-> cpu 112 | (io-write 0xff 0) 113 | (io-write 0xff 1))] 114 | (should= 0xf (do-mode absolute-y (assoc new-cpu :y 0x10))))) 115 | 116 | (it "should use the absolute address and add the value of Y" 117 | (let [[_ new-cpu] (io-> cpu 118 | (io-write 0xef 0) 119 | (io-write 0xbe 1))] 120 | (should= 0xbeff (do-mode absolute-y (assoc new-cpu :y 0x10)))))) 121 | 122 | (describe "absolute-x" 123 | (it "should wrap if the address would be greater than 2 bytes" 124 | (let [[_ new-cpu] (io-> cpu 125 | (io-write 0xff 0) 126 | (io-write 0xff 1))] 127 | (should= 0xf (do-mode absolute-x (assoc new-cpu :x 0x10))))) 128 | 129 | (it "should use the absolute address and add the value of X" 130 | (let [[_ new-cpu] (io-> cpu 131 | (io-write 0xef 0) 132 | (io-write 0xbe 1))] 133 | (should= 0xbeff (do-mode absolute-x (assoc new-cpu :x 0x10)))))) 134 | 135 | (describe "absolute" 136 | (it "should be 'readWord(PC)'" 137 | (let [[_ new-cpu] (io-> cpu 138 | (io-write 0xef 0) 139 | (io-write 0xbe 1))] 140 | (should= 0xbeef (do-mode absolute new-cpu))))) 141 | 142 | (describe "relative" 143 | (it "should wrap if the result would be < 0" 144 | (let [[_ new-cpu] (io-> cpu 145 | (io-write 0x80 (:pc cpu)))] 146 | (should= 0xff81 (do-mode relative new-cpu)))) 147 | 148 | ;; (it "should wrap if the result would be > 0xffff" 149 | ;; (let [cpu-with-pc (merge cpu {:pc 0xffff 150 | ;; :mapper {}}) 151 | ;; [_ new-cpu] (io-> cpu-with-pc 152 | ;; (io-write 0x79 (:pc cpu-with-pc)))] 153 | ;; (should= 0x79 (do-mode relative new-cpu)))) 154 | 155 | (it "should be 'read(PC) + (PC - 0x100) + 1' if read(PC) is >= 0x80" 156 | (let [cpu-with-pc (assoc cpu :pc 0x1000) 157 | [_ new-cpu] (io-> cpu-with-pc 158 | (io-write 0x80 (:pc cpu-with-pc)))] 159 | (should= 0x0f81 (do-mode relative new-cpu)))) 160 | 161 | (it "should be 'read(PC) + PC + 1' if read(PC) is < 0x80" 162 | (let [cpu-with-pc (assoc cpu :pc 0x1000) 163 | [_ new-cpu] (io-> cpu-with-pc 164 | (io-write 0x79 (:pc cpu-with-pc)))] 165 | (should= 0x107a (do-mode relative new-cpu))))) 166 | 167 | (describe "zero-page-y" 168 | (it "should wrap the resulting address to the first page if it would cross a page" 169 | (let [cpu-with-zp-y (assoc cpu-with-zp :y 0xff)] 170 | (should= 0x0054 (do-mode zero-page-y cpu-with-zp-y)))) 171 | 172 | (it "should use the zero-page address, and add the contents of the Y register" 173 | (let [cpu-with-zp-y (assoc cpu-with-zp :y 0x10)] 174 | (should= 0x0065 (do-mode zero-page-y cpu-with-zp-y))))) 175 | 176 | (describe "zero-page-x" 177 | (it "should wrap the resulting address to the first page if it would cross a page" 178 | (let [cpu-with-zp-x (assoc cpu-with-zp :x 0xff)] 179 | (should= 0x0054 (do-mode zero-page-x cpu-with-zp-x)))) 180 | 181 | (it "should use the zero-page address, and add the contents of the X register" 182 | (let [cpu-with-zp-x (assoc cpu-with-zp :x 0x10)] 183 | (should= 0x0065 (do-mode zero-page-x cpu-with-zp-x))))) 184 | 185 | (describe "zero-page" 186 | (it "should be '0x0000 + read(PC)'" 187 | (should= 0x0055 (do-mode zero-page cpu-with-zp)))) 188 | 189 | (describe "immediate" 190 | (it "should use whatever value PC points at" 191 | (let [new-cpu (assoc cpu :pc 0xbeef)] 192 | (should= 0xbeef (do-mode immediate new-cpu))))) 193 | 194 | (describe "implied" 195 | (it "should raise an error trying to read or write from the impled address mode" 196 | (should-throw Error "Can't read/write to the implied address mode" 197 | (do-mode-write implied cpu 0xbe)) 198 | 199 | (should-throw Error "Can't read/write to the implied address mode" 200 | (do-mode-read implied cpu)))) 201 | 202 | (describe "accumulator" 203 | (it "should write to the accumulator" 204 | (let [cpu-with-acc (do-mode-write accumulator cpu 0xbe)] 205 | (should= 0xbe (:a cpu-with-acc)))) 206 | 207 | (it "should read from the accumulator" 208 | (let [cpu-with-acc (assoc cpu :a 0xbe) 209 | result (do-mode-read accumulator cpu-with-acc)] 210 | (should= 0xbe result))))) 211 | -------------------------------------------------------------------------------- /src/clones/ppu.clj: -------------------------------------------------------------------------------- 1 | (ns clones.ppu 2 | (:require [clones.device :refer :all] 3 | [clones.byte :refer :all]) 4 | (import [java.awt.image BufferedImage])) 5 | 6 | (defn control-write [ppu v] 7 | (let [vram-latch (bit-and (:vram-latch ppu) 0xf3ff) 8 | base-nametable (bit-and 3 v)] 9 | (-> ppu 10 | (assoc! :control v) 11 | (assoc! :vram-latch (bit-or 12 | (bit-shift-left base-nametable 10) 13 | vram-latch)) 14 | (assoc! :base-nametable-addr base-nametable) 15 | (assoc! :vram-addr-inc (bit-and 1 (bit-shift-right v 2))) 16 | (assoc! :sprite-pattern-addr (bit-and 1 (bit-shift-right v 3))) 17 | (assoc! :background-pattern-addr (bit-and 1 (bit-shift-right v 4))) 18 | (assoc! :sprite-size (bit-and 1 (bit-shift-right v 5))) 19 | (assoc! :nmi-on-vblank? (bit-set? v 7))))) 20 | 21 | (defn mask-write [ppu v] 22 | (-> ppu 23 | (assoc! :mask v) 24 | (assoc! :grayscale? (bit-set? v 0)) 25 | (assoc! :show-background-on-left? (bit-set? v 1)) 26 | (assoc! :show-sprites-on-left? (bit-set? v 2)) 27 | (assoc! :show-background? (bit-set? v 3)) 28 | (assoc! :show-sprites? (bit-set? v 4)) 29 | (assoc! :intense-reds? (bit-set? v 5)) 30 | (assoc! :intense-greens? (bit-set? v 6)) 31 | (assoc! :intense-blues? (bit-set? v 7)))) 32 | 33 | (defn oam-addr-write [ppu v] 34 | (assoc! ppu :oam-addr v)) 35 | 36 | (defn- advance-oam-addr [ppu] 37 | (let [orig (:oam-addr ppu) 38 | incd (mod (inc orig) 0x100)] 39 | (assoc! ppu :oam-addr incd))) 40 | 41 | (defn oam-data-write [ppu v] 42 | (let [after-write (assoc (:oam-ram ppu) (:oam-addr ppu) v)] 43 | (-> ppu 44 | (advance-oam-addr) 45 | (assoc! :oam-ram after-write)))) 46 | 47 | (defn- scroll-write-horizontal-offset [ppu v] 48 | (let [new-fine-x (bit-and 7 v) 49 | new-vram-latch (-> (:vram-latch ppu) 50 | (bit-and 0x7fe0) 51 | (bit-or (bit-shift-right v 3)))] 52 | (-> ppu 53 | (assoc! :fine-x new-fine-x) 54 | (assoc! :vram-latch new-vram-latch)))) 55 | 56 | (defn- scroll-write-vertical-offset [ppu v] 57 | (let [scanline (bit-and 7 v) 58 | distance-from-top (bit-shift-right v 3) 59 | new-vram-latch (-> (:vram-latch ppu) 60 | (bit-and 0x0fff) 61 | (bit-or (bit-shift-left scanline 12)) 62 | (bit-and 0xfc1f) 63 | (bit-or (bit-shift-left distance-from-top 5)))] 64 | (assoc! ppu :vram-latch new-vram-latch))) 65 | 66 | (defn scroll-write [ppu v] 67 | (let [after-write (if (:write-latch? ppu) 68 | (scroll-write-horizontal-offset ppu v) 69 | (scroll-write-vertical-offset ppu v))] 70 | (assoc! after-write :write-latch? (not (:write-latch? ppu))))) 71 | 72 | (defn- addr-write-first [ppu v] 73 | (let [upper-6-bits (bit-and 0x3f v) 74 | new-vram-latch (-> (:vram-latch ppu) 75 | (bit-and 0xff) 76 | (bit-or (bit-shift-left upper-6-bits 8)))] 77 | (assoc! ppu :vram-latch new-vram-latch))) 78 | 79 | (defn- addr-write-second [ppu v] 80 | (let [new-vram-latch (-> (:vram-latch ppu) 81 | (bit-and 0x3f00) 82 | (bit-or v))] 83 | (-> ppu 84 | (assoc! :vram-latch new-vram-latch) 85 | (assoc! :vram-addr new-vram-latch)))) 86 | 87 | (defn addr-write [ppu v] 88 | (let [after-write (if (:write-latch? ppu) 89 | (addr-write-first ppu v) 90 | (addr-write-second ppu v))] 91 | (assoc! after-write :write-latch? (not (:write-latch? ppu))))) 92 | 93 | (defn- advance-vram-addr [ppu] 94 | (assoc! ppu :vram-addr (if (zero? (:vram-addr-inc ppu)) 95 | (inc (:vram-addr ppu)) 96 | (+ 0x20 (:vram-addr ppu))))) 97 | 98 | (defn data-write [ppu v] 99 | (let [memory (:memory ppu) 100 | memory-after-write (second (device-write memory v (:vram-addr ppu))) 101 | after-write (assoc! ppu :memory memory-after-write)] 102 | (advance-vram-addr after-write))) 103 | 104 | (defn- data-read-buffered [ppu] 105 | (let [result (:vram-data-buffer ppu) 106 | memory (:memory ppu) 107 | new-vram-data-buffer (first (device-read memory (:vram-addr ppu)))] 108 | [result (assoc! ppu :vram-data-buffer new-vram-data-buffer)])) 109 | 110 | (defn- data-read-unbuffered [ppu] 111 | (let [memory (:memory ppu) 112 | result (first (device-read memory (:vram-addr ppu))) 113 | buffer-fill-addr (- (:vram-addr ppu) 0x1000) 114 | new-vram-data-buffer (first (device-read memory buffer-fill-addr))] 115 | [result (assoc! ppu :vram-data-buffer new-vram-data-buffer)])) 116 | 117 | (defn data-read [ppu] 118 | (let [[result after-read] (if (< (:vram-addr ppu) 0x3f00) 119 | (data-read-buffered ppu) 120 | (data-read-unbuffered ppu))] 121 | [result (advance-vram-addr after-read)])) 122 | 123 | (defn oam-data-read [ppu] 124 | [(get (:oam-ram ppu) (:oam-addr ppu) 0) 125 | ppu]) 126 | 127 | (defn status-read [ppu] 128 | (let [at-vblank-tick? (and 129 | (= 1 (:tick ppu)) 130 | (= 240 (:scanline ppu))) 131 | vblank-started? (if at-vblank-tick? 132 | false 133 | (:vblank-started? ppu)) 134 | status (-> 0 135 | (bit-or (if vblank-started? 0x80 0)) 136 | (bit-or (if (:sprite-0-hit? ppu) 0x40 0)) 137 | (bit-or (if (:sprite-overflow? ppu) 0x20 0)))] 138 | [status (-> ppu 139 | (assoc! :write-latch? true) 140 | (assoc! :vblank-started? false) 141 | (assoc! :suppress-vblank? at-vblank-tick?) 142 | (assoc! :suppress-nmi? at-vblank-tick?))])) 143 | 144 | (defn ppu-write [ppu v addr] 145 | [v (condp = addr 146 | 0 (control-write ppu v) 147 | 1 (mask-write ppu v) 148 | 3 (oam-addr-write ppu v) 149 | 4 (oam-data-write ppu v) 150 | 5 (scroll-write ppu v) 151 | 6 (addr-write ppu v) 152 | 7 (data-write ppu v) 153 | ppu)]) 154 | 155 | (defn ppu-register-write [machine v addr] 156 | (let [ppu (:ppu machine)] 157 | (do 158 | (ppu-write ppu v addr) 159 | [v machine]))) 160 | 161 | (defn ppu-read [ppu addr] 162 | (condp = addr 163 | 2 (status-read ppu) 164 | 4 (oam-data-read ppu) 165 | 7 (data-read ppu) 166 | [0 ppu])) 167 | 168 | (defn ppu-register-read [machine addr] 169 | (let [ppu (:ppu machine) 170 | [v new-ppu] (ppu-read ppu addr)] 171 | [v machine])) 172 | 173 | (def init-oam-ram (vec (repeat 0x100 0))) 174 | 175 | (defn make-ppu [bus] 176 | {:control 0 177 | :base-nametable-address 0 178 | :vram-addr-inc 0 179 | :sprite-pattern-addr 0 180 | :background-pattern-addr 0 181 | :sprite-size 0 182 | :nmi-on-vblank? false 183 | 184 | :mask 0 185 | :grayscale? false 186 | :show-background-on-left? false 187 | :show-sprites-on-left? false 188 | :show-background? false 189 | :show-sprites? false 190 | :intense-reds? false 191 | :intense-greens? false 192 | :intense-blues? false 193 | 194 | :sprite-overflow? false 195 | :sprite-0-hit? false 196 | :vblank-started? false 197 | :write-latch? true 198 | 199 | :oam-addr 0 200 | :oam-ram init-oam-ram 201 | 202 | :fine-x 0 203 | :vram-latch 0 204 | :vram-addr 0 205 | :vram-data-buffer 0 206 | 207 | :scanline 261 208 | :tick 0 209 | :frame-count 0 210 | 211 | :background-frame-buffer (BufferedImage. 256 240 BufferedImage/TYPE_INT_ARGB) 212 | :memory bus}) 213 | 214 | (defn- rendering-enabled? [ppu] 215 | (or (:show-sprites? ppu) (:show-background? ppu))) 216 | 217 | (defn- step-pre-render-scanline [machine] 218 | (let [ppu (:ppu machine)] 219 | (condp = (:tick ppu) 220 | 1 (do 221 | (-> ppu 222 | (assoc! :sprite-0-hit? false) 223 | (assoc! :sprite-overflow? false)) 224 | machine) 225 | 226 | 304 (do 227 | (when (rendering-enabled? ppu) (assoc! ppu :vram-addr (:vram-latch ppu))) 228 | machine) 229 | machine))) 230 | 231 | (defn- step-post-render-scanline [machine] 232 | (let [ppu (:ppu machine)] 233 | (if (= 1 (:tick ppu)) 234 | (let [request-nmi? (and 235 | (:nmi-on-vblank? ppu) 236 | (not (:suppress-nmi? ppu))) 237 | frame-count (if (rendering-enabled? ppu) 238 | (inc (:frame-count ppu)) 239 | (:frame-count ppu)) 240 | ppu-after-vblank (-> ppu 241 | (assoc! :vblank-started? (not (:suppress-vblank? ppu))) 242 | (assoc! :frame-count frame-count) 243 | (assoc! :suppress-vblank? false) 244 | (assoc! :suppress-nmi? false)) 245 | nmi (when request-nmi? :nmi)] 246 | (assoc machine :interrupt nmi)) 247 | machine))) 248 | 249 | (defn- inc-coarse-y [ppu] 250 | (let [;; Get the vram addr with the fine y cleared to 0 251 | vram-addr (bit-and (:vram-addr ppu) 0xfff) 252 | old-coarse-y (bit-shift-right (bit-and vram-addr 0x03e0) 5)] 253 | (if (= 29 old-coarse-y) 254 | (let [new-vram-addr (-> vram-addr 255 | (bit-and 0xfc1f) 256 | (bit-xor 0x800))] 257 | (assoc! ppu :vram-addr new-vram-addr)) 258 | 259 | (let [new-coarse-y (bit-and 0x1f (inc old-coarse-y)) 260 | new-vram-addr (-> vram-addr 261 | (bit-and 0xfc1f) 262 | (bit-or (bit-shift-left new-coarse-y 5)))] 263 | (assoc! ppu :vram-addr new-vram-addr))))) 264 | 265 | (defn- inc-fine-y [ppu] 266 | (let [vram-addr (:vram-addr ppu) 267 | fine-y-overflow? (= 0x7000 (bit-and vram-addr 0x7000))] 268 | (if fine-y-overflow? 269 | (inc-coarse-y ppu) 270 | (let [new-vram-addr (+ vram-addr 0x1000)] 271 | (assoc! ppu :vram-addr new-vram-addr))))) 272 | 273 | (defn- inc-coarse-x [ppu] 274 | (let [vram-addr (:vram-addr ppu) 275 | old-coarse-x (bit-and vram-addr 0x1f) 276 | new-vram-addr (if (= 31 old-coarse-x) 277 | (-> old-coarse-x 278 | (bit-and 0xffe0) 279 | (bit-xor 0x400)) 280 | (inc old-coarse-x))] 281 | (assoc! ppu :vram-addr new-vram-addr))) 282 | 283 | (defn pattern-tile-row [ppu tile-index fine-y] 284 | "Read a row of palette indicies (0, 1, 2 or 3) from the pattern table. 285 | 286 | tile-index is the reference in the nametable." 287 | 288 | (let [pattern-table-addr (* 0x1000 (:background-pattern-addr ppu)) 289 | start (-> tile-index 290 | (bit-shift-left 4) 291 | (bit-and 0x0ff0) 292 | (bit-or pattern-table-addr) 293 | (bit-or fine-y)) 294 | memory (:memory ppu) 295 | pixel-row-low (first (device-read memory start)) 296 | pixel-row-high (first (device-read memory (+ start 8)))] 297 | (reduce (fn [palette-indices i] 298 | (let [low-bit (-> pixel-row-low 299 | (bit-shift-right i) 300 | (bit-and 1)) 301 | high-bit (-> pixel-row-high 302 | (bit-shift-right i) 303 | (bit-and 1) 304 | (bit-shift-left 1)) 305 | palette-index (bit-or low-bit high-bit)] 306 | (cons palette-index palette-indices))) 307 | [] 308 | (range 8)))) 309 | 310 | (defn- vram-addr-for-scanline-tile [start-of-line-vram-addr tile-x-index] 311 | (let [vram-addr start-of-line-vram-addr 312 | coarse-x (bit-and vram-addr 0x1f) 313 | new-coarse-x (+ coarse-x tile-x-index) 314 | overflow? (> new-coarse-x 0x1f) 315 | result (-> vram-addr 316 | (bit-and 0xffe0) 317 | (bit-xor (if overflow? 0x400 0)) 318 | (bit-or (bit-and 0x1f new-coarse-x)))] 319 | result)) 320 | 321 | (defn pattern-tile-indices-for-current-scanline [ppu] 322 | ;; TODO: Fine-x scroll... I'm not entirely sure how it works. 323 | (let [memory (:memory ppu) 324 | vram-addr (:vram-addr ppu)] 325 | (map (fn [i] 326 | (let [nametable-addr (bit-or 327 | 0x2000 328 | (bit-and 329 | 0xfff 330 | (vram-addr-for-scanline-tile vram-addr i))) 331 | tile-index (first (device-read memory nametable-addr))] 332 | tile-index)) 333 | (range 32)))) 334 | 335 | (defn- get-color [pixel] 336 | (condp = pixel 337 | 0 0 338 | 1 0xffff0000 339 | 2 0xff00ff00 340 | 3 0xff0000ff)) 341 | 342 | (defn- render-background-for-current-scanline [ppu] ppu) 343 | ;; (let [scanline (:scanline ppu) 344 | ;; frame-buffer (:background-frame-buffer ppu) 345 | ;; fine-y (bit-shift-right (:vram-addr ppu) 12) 346 | ;; tile-indices (pattern-tile-indices-for-current-scanline ppu) 347 | ;; scanline-pattern (vec (flatten 348 | ;; (map #(pattern-tile-row ppu % fine-y) 349 | ;; tile-indices)))] 350 | ;; (doseq [x (range 256)] 351 | ;; (let [color-index (nth scanline-pattern x)] 352 | ;; (.setRGB frame-buffer x scanline (get-color color-index))))) 353 | ;; ppu) 354 | 355 | (defn- maybe-render-background [ppu] 356 | (if (:show-background? ppu) 357 | (render-background-for-current-scanline ppu) 358 | ppu)) 359 | 360 | (defn- maybe-inc-fine-y [ppu] 361 | (if (rendering-enabled? ppu) 362 | (inc-fine-y ppu) 363 | ppu)) 364 | 365 | (defn- step-visible-scanline [machine] 366 | (let [ppu (:ppu machine)] 367 | (if (== 256 (:tick ppu)) 368 | (do 369 | (-> ppu 370 | (maybe-render-background) 371 | (maybe-inc-fine-y)) 372 | machine) 373 | machine))) 374 | 375 | (defn- advance-odd-scanline [ppu] 376 | (-> ppu 377 | (assoc! :scanline 0) 378 | (assoc! :tick 0))) 379 | 380 | (defn- advance-normal-scanline [ppu scanline tick] 381 | (if (== 340 tick) 382 | (-> ppu 383 | (assoc! :tick 0) 384 | (assoc! :scanline (mod (+ 1 scanline) 262))) 385 | (assoc! ppu :tick (+ 1 tick)))) 386 | 387 | (defn- advance-scanline [ppu] 388 | (let [^int scanline (:scanline ppu) 389 | ^int tick (:tick ppu) 390 | frame-count ^int (:frame-count ppu)] 391 | (if (and 392 | (== 339 tick) 393 | (== 261 scanline) 394 | (odd? frame-count) 395 | (:show-background? ppu)) 396 | (advance-odd-scanline ppu) 397 | (advance-normal-scanline ppu scanline tick)))) 398 | 399 | (defn transient-ppu-step [machine] 400 | (let [ppu (:ppu machine) 401 | scanline (int (:scanline ppu)) 402 | tick (int (:tick ppu)) 403 | 404 | machine (cond 405 | (< scanline 240) (step-visible-scanline machine) 406 | 407 | (== 240 scanline) (step-post-render-scanline machine) 408 | 409 | (and 410 | (== 260 scanline) 411 | (== 1 tick)) (do 412 | (assoc! ppu :vblank-started? false) 413 | machine) 414 | 415 | (== 261 scanline) (step-pre-render-scanline machine) 416 | 417 | :else machine)] 418 | (do 419 | (advance-scanline ppu) 420 | machine))) 421 | 422 | (defn- transient-machine [nes] 423 | (let [ppu (:ppu nes)] 424 | (assoc nes :ppu (transient ppu)))) 425 | 426 | (defn- persistent-machine! [nes] 427 | (let [ppu (:ppu nes)] 428 | (assoc nes :ppu (persistent! ppu)))) 429 | 430 | (defn ppu-step [machine] 431 | (-> machine 432 | (transient-machine) 433 | (transient-ppu-step) 434 | (persistent-machine!))) 435 | -------------------------------------------------------------------------------- /spec/clones/ppu_spec.clj: -------------------------------------------------------------------------------- 1 | (ns clones.ppu-specj 2 | (:require [speclj.core :refer :all] 3 | [clones.device :refer :all] 4 | [clones.ppu :refer :all]) 5 | (import [java.awt.image BufferedImage])) 6 | 7 | (defn merge! [x y] 8 | (reduce 9 | (fn [res [k v]] (assoc! res k v)) 10 | x y)) 11 | 12 | (describe "The NES's 2C02 PPU" (tags :ppu) 13 | (with ppu (transient (make-ppu {}))) 14 | (with persistent-ppu (persistent! @ppu)) 15 | (with ppu-latch-off (transient (assoc (make-ppu {}) :write-latch? false))) 16 | 17 | (describe "pattern-tile-indices-for-current-scanline" 18 | (def tiles (vec (repeat 32 0))) 19 | 20 | (it (str "should switch horizontal nametables midway through if the tiles 21 | cross a nametable border") 22 | (let [ppu-w-nametables (-> @ppu 23 | (assoc! :vram-addr 0x001f) 24 | (assoc! :memory {0x201f 1 25 | 0x2400 1})) 26 | tile-indices (pattern-tile-indices-for-current-scanline 27 | ppu-w-nametables)] 28 | (should= (-> tiles 29 | (assoc 0 1) 30 | (assoc 1 1)) tile-indices))) 31 | 32 | (it "should read from the nametables starting at vram addr + $2000" 33 | (let [ppu-w-nametable (assoc! @ppu :memory {0x2000 1 34 | 0x201f 1}) 35 | tile-indices (pattern-tile-indices-for-current-scanline 36 | ppu-w-nametable)] 37 | (should= (-> tiles 38 | (assoc 0 1) 39 | (assoc 31 1)) tile-indices)))) 40 | 41 | (describe "pattern-tile-row" 42 | (it (str "should use the line index (fine Y scroll) as the least " 43 | "significant 4 bits") 44 | (let [ppu-w-tile (assoc! @ppu :memory {0x01e1 0x41 45 | 0x01e9 0x11}) 46 | palette-indices (pattern-tile-row ppu-w-tile 30 1)] 47 | (should= [0 1 0 2 0 0 0 3] palette-indices))) 48 | 49 | (it (str "should use the index (coarse X scroll) as the middle byte of " 50 | "the address (e.g. $0xx0)") 51 | (let [ppu-w-tile (assoc! @ppu :memory {0x01e0 0x41 52 | 0x01e8 0x11}) 53 | palette-indices (pattern-tile-row ppu-w-tile 30 0)] 54 | (should= [0 1 0 2 0 0 0 3] palette-indices))) 55 | 56 | (it "should start at $1000 if the background pattern address is 1" 57 | (let [ppu-w-tile (-> @ppu 58 | (assoc! :background-pattern-addr 1) 59 | (assoc! :memory {0x1000 0x41 ;; 01000001 60 | 0x1008 0x11})) ;; 00010001 61 | palette-indices (pattern-tile-row ppu-w-tile 0 0)] 62 | (should= [0 1 0 2 0 0 0 3] palette-indices))) 63 | 64 | (it (str "should read the low and high bytes and combine them into a " 65 | "stream of palette indices from 0 to 3") 66 | (let [ppu-w-tile (assoc! @ppu :memory {0 0x41 ;; 01000001 67 | 8 0x11}) ;; 00010001 68 | palette-indices (pattern-tile-row ppu-w-tile 0 0)] 69 | (should= [0 1 0 2 0 0 0 3] palette-indices)))) 70 | 71 | (describe "transient-ppu-step" 72 | (defn ppu-step-debug [machine] 73 | (:ppu (transient-ppu-step machine))) 74 | 75 | (describe "when the tick is 340" 76 | (with ppu-at-340 (transient (persistent! (assoc! @ppu :tick 340)))) 77 | 78 | (it "should increment the scanline by 1 when it's less than 260" 79 | (let [ppu-w-scanline (assoc! @ppu-at-340 :scanline 0) 80 | machine {:ppu ppu-w-scanline}] 81 | (should= 1 (:scanline (ppu-step-debug machine))))) 82 | 83 | (it "should reset the scanline to 0 if it's 261" 84 | (let [ppu-w-scanline (assoc! @ppu-at-340 :scanline 261) 85 | machine {:ppu ppu-w-scanline}] 86 | (should= 0 (:scanline (ppu-step-debug machine))))) 87 | 88 | (it "should reset the tick to 0" 89 | (should= 0 (:tick (ppu-step-debug {:ppu @ppu-at-340}))))) 90 | 91 | (it "should increment the tick by 1 when it's less than 340" 92 | (should= 1 (:tick (ppu-step-debug {:ppu @ppu})))) 93 | 94 | (describe "the post-render scanline +1 (240)" 95 | (describe "tick 1" 96 | (describe "when rendering is enabled" 97 | (it "should increment the framecount" 98 | (let [machine {:ppu (merge! @ppu {:tick 1 99 | :scanline 240 100 | :frame-count 0 101 | :show-background? true})} 102 | new-machine (transient-ppu-step machine)] 103 | (should= 1 (get-in new-machine [:ppu :frame-count]))))) 104 | 105 | 106 | (describe "when NMI on vblank control is turned off" 107 | (it "should not request an NMI" 108 | (let [machine {:ppu (merge! @ppu {:tick 1 109 | :nmi-on-vblank? false 110 | :scanline 240}) 111 | :interrupt nil} 112 | new-machine (transient-ppu-step machine)] 113 | (should= nil (:interrupt new-machine))))) 114 | 115 | (describe "when NMI on vblank control is turned on" 116 | (it "should request an NMI" 117 | (let [machine {:ppu (merge! @ppu {:tick 1 118 | :nmi-on-vblank? true 119 | :scanline 240}) 120 | :interrupt nil} 121 | new-machine (transient-ppu-step machine)] 122 | (should= :nmi (:interrupt new-machine))))) 123 | 124 | (describe "when suppressing vblank" 125 | (it "should unsuppress vblank after having suppressed it" 126 | (let [ppu-suppressing (merge! @ppu {:vblank-started? false 127 | :scanline 240 128 | :tick 1 129 | :suppress-vblank? true}) 130 | machine {:ppu ppu-suppressing} 131 | new-ppu (ppu-step-debug machine)] 132 | (should-not (:suppress-vblank? new-ppu)))) 133 | 134 | (it "should not set the vblank started flag" 135 | (let [ppu-suppressing (merge! @ppu {:vblank-started? false 136 | :scanline 240 137 | :tick 1 138 | :suppress-vblank? true}) 139 | machine {:ppu ppu-suppressing} 140 | new-ppu (ppu-step-debug machine)] 141 | (should-not (:vblank-started? new-ppu))))) 142 | 143 | (it "should set the vblank started flag" 144 | (let [ppu-wo-vblank-started (merge! @ppu {:vblank-started? false 145 | :scanline 240 146 | :tick 1}) 147 | machine {:ppu ppu-wo-vblank-started} 148 | new-ppu (ppu-step-debug machine)] 149 | (should (:vblank-started? new-ppu)))))) 150 | 151 | (describe "the visible scanlines (0-239)" 152 | (describe "tick 256" 153 | (def frame-buffer-bg (BufferedImage. 256 240 BufferedImage/TYPE_INT_ARGB)) 154 | 155 | (def memory {;; Pattern table has 16 bytes, these two combine to 156 | ;; first row of the pattern. 157 | ;; 158 | ;; Pattern in this case is: 159 | ;; 160 | ;; 3 0 1 3 3 3 2 0 161 | ;; 1 0 0 0 0 0 0 2 162 | ;; 0 0 0 0 0 0 0 0 163 | ;; ... (for the whole 8 rows) 164 | 0x0010 0xbc 165 | 0x0018 0x9e 166 | 167 | 0x0011 0x80 168 | 0x0019 0x01 169 | 170 | ;; Nametable points to pattern table 171 | 0x2000 0x01}) 172 | 173 | (with ppu-at-end-of-scanline (-> @ppu 174 | (assoc! :show-sprites? false) 175 | (assoc! :show-background? true) 176 | (assoc! :tick 256) 177 | (assoc! :memory memory))) 178 | 179 | (defn should-match-line [v bi line] 180 | (doseq [x (range (count v))] 181 | (should= (nth v x) (bit-and 0xffffffff (.getRGB bi x line))))) 182 | 183 | (def red 0xffff0000) 184 | (def green 0xff00ff00) 185 | (def blue 0xff0000ff) 186 | 187 | (describe "when background rendering is disabled" 188 | (it "shouldn't render anything to the frame buffer" 189 | (let [ppu-at-end-of-scanline-0 (merge! @ppu-at-end-of-scanline 190 | {:scanline 0 191 | :show-background? false 192 | :vram-addr 0}) 193 | machine {:ppu ppu-at-end-of-scanline-0} 194 | new-ppu (ppu-step-debug machine)] 195 | (should-match-line [0 0 0 0 0 0 0 0] (:background-frame-buffer new-ppu) 0)))) 196 | 197 | (describe "when background rendering is enabled" 198 | (it "should add the background tile rows to the second scanline" 199 | (let [ppu-at-end-of-scanline-1 (merge! @ppu-at-end-of-scanline 200 | {:scanline 1 201 | :vram-addr 0x1000}) 202 | machine {:ppu ppu-at-end-of-scanline-1} 203 | new-ppu (ppu-step-debug machine)] 204 | (should-match-line [red 0 0 0 0 0 0 green] 205 | (:background-frame-buffer new-ppu) 206 | 1))) 207 | 208 | (it "should add the background tile rows to the first scanline" 209 | (let [ppu-at-end-of-scanline-0 (merge! @ppu-at-end-of-scanline 210 | {:scanline 0 211 | :vram-addr 0}) 212 | machine {:ppu ppu-at-end-of-scanline-0} 213 | new-ppu (ppu-step-debug machine)] 214 | (should-match-line [blue 0 red blue blue blue green 0] 215 | (:background-frame-buffer new-ppu) 216 | 0)))) 217 | 218 | (describe "when neither sprite or background rendering is enabled" 219 | (it "shouldn't increment Y" 220 | (let [ppu-at-end-of-scanline (merge! @ppu {:show-sprites? false 221 | :show-background? false 222 | :scanline 0 223 | :tick 256 224 | :vram-addr 0}) 225 | machine {:ppu ppu-at-end-of-scanline} 226 | new-ppu (ppu-step-debug machine)] 227 | (should= 0 (:vram-addr new-ppu))))) 228 | 229 | (describe "when either sprite or background rendering is enabled" 230 | (it (str "should set coarse Y to 0 but not switch vertical nametables " 231 | " when coarse Y is equal to 31") 232 | (let [ppu-at-end-of-scanline (merge! @ppu {:show-background? true 233 | :scanline 0 234 | :tick 256 235 | :vram-addr 0x73e0}) 236 | machine {:ppu ppu-at-end-of-scanline} 237 | new-ppu (ppu-step-debug machine)] 238 | (should= 0 (:vram-addr new-ppu)))) 239 | 240 | (it (str "should set coarse Y to 0 and switch vertical nametables " 241 | "when coarse Y is equal to 29") 242 | (let [ppu-at-end-of-scanline (merge! @ppu {:show-sprites? true 243 | :scanline 0 244 | :tick 256 245 | :vram-addr 0x73a0}) 246 | machine {:ppu ppu-at-end-of-scanline} 247 | new-ppu (ppu-step-debug machine)] 248 | (should= 0x800 (:vram-addr new-ppu)))) 249 | 250 | (it (str "should set fine Y to 0 and increment coarse Y when " 251 | "fine Y is equal to 7") 252 | (let [ppu-at-end-of-scanline (merge! @ppu {:show-background? true 253 | :scanline 0 254 | :tick 256 255 | :vram-addr 0x7000}) 256 | machine {:ppu ppu-at-end-of-scanline} 257 | new-ppu (ppu-step-debug machine)] 258 | (should= 0x20 (:vram-addr new-ppu)))) 259 | 260 | (it "should increment fine Y by 1 when it's < 7" 261 | (let [ppu-at-end-of-scanline (merge! @ppu {:show-sprites? true 262 | :scanline 0 263 | :tick 256 264 | :vram-addr 0x1000}) 265 | machine {:ppu ppu-at-end-of-scanline} 266 | new-ppu (ppu-step-debug machine)] 267 | (should= 0x2000 (:vram-addr new-ppu))))))) 268 | 269 | (describe "the final vblanking scanline (260)" 270 | (describe "tick 1" 271 | (it "should clear the vblank started flag" 272 | (let [ppu-w-vblank-started (merge! @ppu {:vblank-started? true 273 | :scanline 260 274 | :tick 1}) 275 | machine {:ppu ppu-w-vblank-started} 276 | new-ppu (ppu-step-debug machine)] 277 | (should-not (:vblank-started? new-ppu)))))) 278 | 279 | (describe "the pre-render scanline (261)" 280 | (describe "tick 339" 281 | (describe "when on an even frame" 282 | (it "should advance to tick 340, scanline 261 as normal" 283 | (let [ppu-odd (merge! @ppu {:show-background? true 284 | :frame-count 2 285 | :scanline 261 286 | :tick 339}) 287 | machine {:ppu ppu-odd} 288 | new-ppu (ppu-step-debug machine)] 289 | (should= 261 (:scanline new-ppu)) 290 | (should= 340 (:tick new-ppu))))) 291 | 292 | (describe "when on an odd frame" 293 | (describe "when background rendering is disabled" 294 | (it "should advance to tick 340, scanline 261 as normal" 295 | (let [ppu-odd (merge! @ppu {:show-background? false 296 | :frame-count 1 297 | :scanline 261 298 | :tick 339}) 299 | machine {:ppu ppu-odd} 300 | new-ppu (ppu-step-debug machine)] 301 | (should= 261 (:scanline new-ppu)) 302 | (should= 340 (:tick new-ppu))))) 303 | 304 | (describe "when background rendering is enabled" 305 | (it "should advance to tick 0, scanline 0 instead of tick 340, scanline 261" 306 | (let [ppu-odd (merge! @ppu {:show-background? true 307 | :frame-count 1 308 | :scanline 261 309 | :tick 339}) 310 | machine {:ppu ppu-odd} 311 | new-ppu (ppu-step-debug machine)] 312 | (should= 0 (:scanline new-ppu)) 313 | (should= 0 (:tick new-ppu))))))) 314 | 315 | (describe "tick 304" 316 | (describe "when neither sprite or background rendering is enabled" 317 | (it "should not copy the vram latch to the vram addr" 318 | (let [ppu-w-latch (merge! @ppu {:show-sprites? false 319 | :show-background? false 320 | :scanline 261 321 | :tick 304 322 | :vram-latch 0xbeef}) 323 | machine {:ppu ppu-w-latch} 324 | new-ppu (ppu-step-debug machine)] 325 | (should= 0 (:vram-addr new-ppu))))) 326 | 327 | (describe "when either sprite or background rendering is enabled" 328 | (it "should copy the vram latch to the vram addr" 329 | (for [flag [:show-background? :show-sprites?]] 330 | (let [ppu-w-latch (merge! @ppu {flag true 331 | :scanline 261 332 | :tick 304 333 | :vram-latch 0xbeef}) 334 | machine {:ppu ppu-w-latch} 335 | new-ppu (ppu-step-debug machine)] 336 | (should= 0xbeef (:vram-addr new-ppu))))))) 337 | 338 | (describe "tick 1" 339 | (it "should clear the sprite overflow flag" 340 | (let [ppu-w-sprite-overflow (merge! @ppu {:sprite-overflow? true 341 | :scanline 261 342 | :tick 1}) 343 | machine {:ppu ppu-w-sprite-overflow} 344 | new-ppu (ppu-step-debug machine)] 345 | (should-not (:sprite-overflow? new-ppu)))) 346 | 347 | (it "should clear the sprite 0 hit flag" 348 | (let [ppu-w-sprite-0 (merge! @ppu {:sprite-0-hit? true 349 | :scanline 261 350 | :tick 1}) 351 | machine {:ppu ppu-w-sprite-0} 352 | new-ppu (ppu-step-debug machine)] 353 | (should-not (:sprite-0-hit? new-ppu))))))) 354 | 355 | (describe "memory mapped register I/O" 356 | (describe "make-ppu" 357 | (it "should have the write latch set initially" 358 | (should (:write-latch? (make-ppu {}))))) 359 | 360 | (describe "read from the data register at $2007" 361 | (describe "when the address is >= $3f00" 362 | (it "should read directly from the @ppu's memory bus" 363 | (let [ppu-w-data (merge! @ppu {:memory {0x3f00 0xff} 364 | :vram-addr 0x3f00})] 365 | (should= 0xff (first (ppu-read ppu-w-data 7))))) 366 | 367 | (it "should fill the vram data buffer with the value read from the bus 368 | $1000 below the current vram address" 369 | (let [ppu-w-data (merge! @ppu {:memory {0x2f00 0xff} 370 | :vram-addr 0x3f00}) 371 | new-ppu (second (ppu-read ppu-w-data 7))] 372 | (should= 0xff (:vram-data-buffer new-ppu))))) 373 | 374 | (describe "when the address is < $3f00" 375 | (it "should read the current value of the vram data buffer" 376 | (let [result (first (ppu-read (assoc! @ppu :vram-data-buffer 0xee) 7))] 377 | (should= 0xee result))) 378 | 379 | (it "should fill the vram data buffer with the value read from the bus" 380 | (let [ppu-w-data (assoc! @ppu :memory {0 0xff}) 381 | new-ppu (second (ppu-read ppu-w-data 7))] 382 | (should= 0xff (:vram-data-buffer new-ppu))))) 383 | 384 | (describe "when vram address increment is 1" 385 | (it "should increment the vram address by 32" 386 | (let [new-ppu (second (ppu-read (assoc! @ppu 387 | :vram-addr-inc 1) 388 | 7))] 389 | (should= 0x20 (:vram-addr new-ppu))))) 390 | 391 | (describe "when vram address increment is 0" 392 | (it "should increment the vram address by 1" 393 | (let [new-ppu (second (ppu-read (assoc! @ppu 394 | :vram-addr-inc 0) 395 | 7))] 396 | (should= 1 (:vram-addr new-ppu)))))) 397 | 398 | (describe "write to the data register at $2007" 399 | (it "should write to the PPU's memory bus at the vram address" 400 | (let [new-ppu (second (ppu-write @ppu 0xff 7))] 401 | (should= 0xff (first (device-read (:memory new-ppu) 0))))) 402 | 403 | (describe "when vram address increment is 1" 404 | (it "should increment the vram address by 32" 405 | (let [new-ppu (second (ppu-write (assoc! @ppu 406 | :vram-addr-inc 1) 407 | 0 7))] 408 | (should= 0x20 (:vram-addr new-ppu))))) 409 | 410 | (describe "when vram address increment is 0" 411 | (it "should increment the vram address by 1" 412 | (let [new-ppu (second (ppu-write (assoc! @ppu 413 | :vram-addr-inc 0) 414 | 0 7))] 415 | (should= 1 (:vram-addr new-ppu)))))) 416 | 417 | (describe "write to the addr register at $2006" 418 | (describe "when the write latch is off" 419 | (it "should copy the vram latch into the vram address" 420 | (let [new-ppu (second (ppu-write @ppu-latch-off 0xff 6))] 421 | (should= 0xff (:vram-addr new-ppu)))) 422 | 423 | (it "should overwrite the lower 8 bits of the vram latch with the 424 | written value" 425 | (let [new-ppu (second (ppu-write (assoc! @ppu-latch-off 426 | :vram-latch 427 | 0x3fff) 0 6))] 428 | (should= 0x3f00 (:vram-latch new-ppu)))) 429 | 430 | (it "should update the lower 8 bits of the vram latch with the written 431 | value" 432 | (let [new-ppu (second (ppu-write @ppu-latch-off 0xff 6))] 433 | (should= 0xff (:vram-latch new-ppu))))) 434 | 435 | (describe "when the write latch is on" 436 | (it "should clear bit 14 of the vram latch" 437 | (let [new-ppu (second (ppu-write (assoc! @ppu :vram-latch 0x7fff) 0xff 6))] 438 | (should= 0x3fff (:vram-latch new-ppu)))) 439 | 440 | (it "should overwrite the existing bits 13-8 with the lower 6 bits of 441 | the 8 bit value that was written" 442 | (let [new-ppu (second (ppu-write (assoc! @ppu :vram-latch 0x3f00) 0 6))] 443 | (should= 0 (:vram-latch new-ppu)))) 444 | 445 | (it "should update bits 13-8 with the lower 6 bits of the 8 bit value 446 | that was written" 447 | (let [new-ppu (second (ppu-write @ppu 0x3f 6))] 448 | (should= 0x3f00 (:vram-latch new-ppu))))) 449 | 450 | (it "should flip the write latch" 451 | (let [off (second (ppu-write @ppu 0 6))] 452 | (should-not (:write-latch? off)) 453 | (let [on (second (ppu-write off 0 6))] 454 | (should (:write-latch? on)))))) 455 | 456 | (describe "write to the scroll register at $2005" 457 | (describe "when the write latch is off (updating vertical offset)" 458 | (it "should overwrite the existing bit 9-5 of the 15 bit vram latch 459 | with the upper 5 bits of the 8 bit value that was written" 460 | (let [new-ppu (second (ppu-write (assoc! 461 | @ppu-latch-off 462 | :vram-latch 0x3e0) 0 5))] 463 | (should= 0 (:vram-latch new-ppu)))) 464 | 465 | (it "should update bits 9-5 of the 15 bit vram latch with the upper 5 466 | bits of the 8 bit value that was written" 467 | (let [new-ppu (second (ppu-write @ppu-latch-off 0xf8 5))] 468 | (should= 0x3e0 (:vram-latch new-ppu)))) 469 | 470 | (it "should overwrite the existing upper 3 bits of the 15 bit vram latch 471 | with the lower 3 bits of the 8 bit value that was written" 472 | (let [new-ppu (second (ppu-write (assoc! 473 | @ppu-latch-off 474 | :vram-latch 0x7000) 0 5))] 475 | (should= 0 (:vram-latch new-ppu)))) 476 | 477 | (it "should update the upper 3 bits of the 15 bit vram latch with the 478 | lower 3 bits of the 8 bit value that was written" 479 | (let [new-ppu (second (ppu-write @ppu-latch-off 7 5))] 480 | (should= 0x7000 (:vram-latch new-ppu))))) 481 | 482 | (describe "when the write latch is on (updating horizontal offset)" 483 | (it "shouldn't alter the upper 10 bits of the 15 bit vram latch when 484 | updating the lower 5 bits" 485 | (let [new-ppu (second (ppu-write (assoc! @ppu :vram-latch 0x7fe0) 0xa8 5))] 486 | (should= 0x7ff5 (:vram-latch new-ppu)))) 487 | 488 | (it "should overwrite the existing lower 5 bits of the 15 bit vram 489 | latch with the upper 5 bits of the 8 bit value that was written" 490 | (let [new-ppu (second (ppu-write (assoc! @ppu :vram-latch 0x15) 0 5))] 491 | (should= 0 (:vram-latch new-ppu)))) 492 | 493 | (it "should update the lower 5 bits of the 15 bit vram latch with the 494 | upper 5 bits of the 8 bit value that was written" 495 | (let [new-ppu (second (ppu-write @ppu 0xff 5))] 496 | (should= 0x1f (:vram-latch new-ppu)))) 497 | 498 | (it "should copy the first three bits of the written value into the 499 | fine X internal register" 500 | (let [new-ppu (second (ppu-write @ppu 0xff 5))] 501 | (should= 7 (:fine-x new-ppu))))) 502 | 503 | (it "should flip the write latch" 504 | (let [off (second (ppu-write @ppu 0 5))] 505 | (should-not (:write-latch? off)) 506 | (let [on (second (ppu-write off 0 5))] 507 | (should (:write-latch? on)))))) 508 | 509 | (describe "read from the oam data register at $2004" 510 | (it "should read the value pointed at by the oam addr" 511 | (let [ppu-w-oam-data (assoc! @ppu :oam-ram {0 0xbe})] 512 | (should= 0xbe (first (ppu-read ppu-w-oam-data 4)))))) 513 | 514 | (describe "write to the oam data register at $2004" 515 | (it "should modulo the oam address with 0x100 after incrementing" 516 | (let [ppu-w-oam-addr (assoc! @ppu :oam-addr 0xff) 517 | new-ppu (second (ppu-write ppu-w-oam-addr 0 4))] 518 | (should= 0 (:oam-addr new-ppu)))) 519 | 520 | (it "should increment the oam address" 521 | (let [new-ppu (second (ppu-write @ppu 0xff 4))] 522 | (should= 1 (:oam-addr new-ppu)))) 523 | 524 | (it "should update the value pointed at by the oam addr" 525 | (let [ppu-w-oam-addr (assoc! @ppu :oam-addr 5) 526 | new-ppu (second (ppu-write ppu-w-oam-addr 0xff 4))] 527 | (should= 0xff (get (:oam-ram new-ppu) 5 0))))) 528 | 529 | (describe "write to the oam address register at $2003" 530 | (it "should set the oam address to the written value" 531 | (let [new-ppu (second (ppu-write @ppu 0xff 3))] 532 | (should= 0xff (:oam-addr new-ppu))))) 533 | 534 | (describe "reading the status register at $2002" 535 | (it "should return vblank is not started when at tick 1 of scanline 240" 536 | (let [ppu-right-before-vbl (merge! @ppu {:tick 1 537 | :scanline 240 538 | :vblank-started? true}) 539 | status (first (ppu-read ppu-right-before-vbl 2))] 540 | (should= 0 (bit-and status 0x80)))) 541 | 542 | (it "should not suppress vblank and NMI when not at tick 1 of scanline 240" 543 | (let [ppu-right-before-vbl (merge! @ppu {:tick 1 544 | :scanline 1 545 | :suppress-vblank? true 546 | :suppress-nmi? true}) 547 | new-ppu (second (ppu-read ppu-right-before-vbl 2))] 548 | (should-not (:suppress-vblank? new-ppu)) 549 | (should-not (:suppress-nmi? new-ppu)))) 550 | 551 | (it "should suppress vblank and NMI when at tick 1 of scanline 240" 552 | (let [ppu-right-before-vbl (merge! @ppu {:tick 1 553 | :scanline 240}) 554 | new-ppu (second (ppu-read ppu-right-before-vbl 2))] 555 | (should (:suppress-vblank? new-ppu)) 556 | (should (:suppress-nmi? new-ppu)))) 557 | 558 | (it "should set the write latch to true" 559 | (let [ppu-w-latch-false (assoc! @ppu :write-latch? false) 560 | new-ppu (second (ppu-read ppu-w-latch-false 2))] 561 | (should (:write-latch? new-ppu)))) 562 | 563 | (it "should clear vblank started" 564 | (let [ppu-w-vbl (assoc! @ppu :vblank-started? true) 565 | ppu-wo-vbl (second (ppu-read ppu-w-vbl 2))] 566 | (should-not (:vblank-started? ppu-wo-vbl)))) 567 | 568 | (it "should have bit 7 unset if vblank hasn't started" 569 | (let [ppu-wo-vbl (assoc! @ppu :vblank-started? false)] 570 | (should= 0 (first (ppu-read ppu-wo-vbl 2))))) 571 | 572 | (it "should have bit 7 set if vblank has started" 573 | (let [ppu-w-vbl (assoc! @ppu :vblank-started? true)] 574 | (should= 0x80 (first (ppu-read ppu-w-vbl 2))))) 575 | 576 | (it "should have bit 6 unset if sprite 0 wasn't hit" 577 | (let [ppu-w-s0 (assoc! @ppu :sprite-0-hit? false)] 578 | (should= 0 (first (ppu-read ppu-w-s0 2))))) 579 | 580 | (it "should have bit 6 set if sprite 0 was hit" 581 | (let [ppu-w-s0 (assoc! @ppu :sprite-0-hit? true)] 582 | (should= 0x40 (first (ppu-read ppu-w-s0 2))))) 583 | 584 | (it "should have bit 5 unset if there wasn't a sprite overflow" 585 | (let [ppu-w-overflow (assoc! @ppu :sprite-overflow? false)] 586 | (should= 0 (first (ppu-read ppu-w-overflow 2))))) 587 | 588 | (it "should have bit 5 set if there was a sprite overflow" 589 | (let [ppu-w-overflow (assoc! @ppu :sprite-overflow? true)] 590 | (should= 0x20 (first (ppu-read ppu-w-overflow 2)))))) 591 | 592 | (describe "writing to the mask register at $2001" 593 | (defn check-mask [m field] 594 | (let [on (second (ppu-write (transient @persistent-ppu) m 1)) 595 | off (second (ppu-write (assoc! (transient @persistent-ppu) field true) 0 1))] 596 | (should (field on)) 597 | (should-not (field off)))) 598 | 599 | (it "should set the mask property to the written value" 600 | (let [new-ppu (second (ppu-write @ppu 0xbe 1))] 601 | (should= 0xbe (:mask new-ppu)))) 602 | 603 | (it "should set intense blues based on the value at bit 7" 604 | (check-mask 0x80 :intense-blues?)) 605 | 606 | (it "should set intense greens based on the value at bit 6" 607 | (check-mask 0x40 :intense-greens?)) 608 | 609 | (it "should set intense reds based on the value at bit 5" 610 | (check-mask 0x20 :intense-reds?)) 611 | 612 | (it "should set showing sprites based on the value at bit 4" 613 | (check-mask 0x10 :show-sprites?)) 614 | 615 | (it "should set showing the background based on the value at bit 3" 616 | (check-mask 8 :show-background?)) 617 | 618 | (it "should set showing sprites on the left-most 8 pixels of the screen 619 | based on the value at bit 2" 620 | (check-mask 4 :show-sprites-on-left?)) 621 | 622 | (it "should set showing the background on the left-most 8 pixels of the 623 | screen based on the value at bit 1" 624 | (check-mask 2 :show-background-on-left?)) 625 | 626 | (it "should turn on/off grayscale display based on the value at bit 0" 627 | (check-mask 1 :grayscale?))) 628 | 629 | (describe "writing to the control register at $2000" 630 | (it "should set bits 10 and 11 in the vram latch to the value at bits 0 and 1" 631 | (let [with-vram-latch (second (ppu-write @ppu 3 0))] 632 | (should= 0xc00 (:vram-latch with-vram-latch)))) 633 | 634 | (it "should turn on/off NMI on vertical blank based on the value at bit 7" 635 | (let [on (second (ppu-write (transient @persistent-ppu) 0x80 0)) 636 | off (second (ppu-write (transient @persistent-ppu) 0 0))] 637 | (should (:nmi-on-vblank? on)) 638 | (should-not (:nmi-on-vblank? off)))) 639 | 640 | (it "should set the sprite size to the value at bit 5" 641 | (let [sz-8x8 (second (ppu-write (transient @persistent-ppu) 0 0)) 642 | sz-8x16 (second (ppu-write (transient @persistent-ppu) 0x20 0))] 643 | (should= 1 (:sprite-size sz-8x16)) 644 | (should= 0 (:sprite-size sz-8x8)))) 645 | 646 | (it "should set the background pattern table address to the value at bit 4" 647 | (let [at-0000 (second (ppu-write (transient @persistent-ppu) 0 0)) 648 | at-1000 (second (ppu-write (transient @persistent-ppu) 0x10 0))] 649 | (should= 1 (:background-pattern-addr at-1000)) 650 | (should= 0 (:background-pattern-addr at-0000)))) 651 | 652 | (it "should set the sprite pattern table address for 8x8 sprites to the 653 | value at bit 3" 654 | (let [at-0000 (second (ppu-write (transient @persistent-ppu) 0 0)) 655 | at-1000 (second (ppu-write (transient @persistent-ppu) 8 0))] 656 | (should= 1 (:sprite-pattern-addr at-1000)) 657 | (should= 0 (:sprite-pattern-addr at-0000)))) 658 | 659 | (it "should set the VRAM address increment per CPU read/write of PPUDATA 660 | to the value at bit 2" 661 | (let [vertical (second (ppu-write (transient @persistent-ppu) 4 0)) 662 | horizontal (second (ppu-write (transient @persistent-ppu) 0 0))] 663 | (should= 1 (:vram-addr-inc vertical)) 664 | (should= 0 (:vram-addr-inc horizontal)))) 665 | 666 | (it "should set the base nametable address to the first two bits" 667 | (let [at-2c00 (second (ppu-write (transient @persistent-ppu) 3 0)) 668 | at-2800 (second (ppu-write (transient @persistent-ppu) 2 0)) 669 | at-2400 (second (ppu-write (transient @persistent-ppu) 1 0)) 670 | at-2000 (second (ppu-write (transient @persistent-ppu) 0 0))] 671 | (should= 0 (:base-nametable-addr at-2000)) 672 | (should= 1 (:base-nametable-addr at-2400)) 673 | (should= 2 (:base-nametable-addr at-2800)) 674 | (should= 3 (:base-nametable-addr at-2c00)))) 675 | 676 | (it "should set the control property to the written value" 677 | (let [new-ppu (second (ppu-write @ppu 3 0))] 678 | (should= 3 (:control new-ppu))))))) 679 | -------------------------------------------------------------------------------- /src/clones/cpu.clj: -------------------------------------------------------------------------------- 1 | (ns clones.cpu 2 | (:require [clones.cpu.memory :refer :all] 3 | [clones.cpu.addressing :refer :all] 4 | [clones.byte :refer :all])) 5 | 6 | (def carry-flag 0x01) 7 | (def zero-flag 0x02) 8 | (def interrupt-flag 0x04) 9 | (def decimal-flag 0x08) 10 | (def break-flag 0x10) 11 | (def unused-flag 0x20) 12 | (def overflow-flag 0x40) 13 | (def negative-flag 0x80) 14 | 15 | (defn negative? [b] (== 0x80 (bit-and b 0x80))) 16 | (defn flag? [flags mask] (= mask (bit-and flags mask))) 17 | (defn carry-flag? [cpu] (flag? (:p cpu) carry-flag)) 18 | (defn zero-flag? [cpu] (flag? (:p cpu) zero-flag)) 19 | (defn decimal-flag? [cpu] (flag? (:p cpu) decimal-flag)) 20 | (defn interrupt-flag? [cpu] (flag? (:p cpu) interrupt-flag)) 21 | (defn overflow-flag? [cpu] (flag? (:p cpu) overflow-flag)) 22 | (defn negative-flag? [cpu] (flag? (:p cpu) negative-flag)) 23 | 24 | (defn set-flag [cpu flag v] 25 | (let [flags (:p cpu)] 26 | (if v 27 | (assoc cpu :p (bit-or flags flag)) 28 | (assoc cpu :p (bit-and flags (bit-not flag)))))) 29 | 30 | (def ops (object-array 0x100)) 31 | (def timings (object-array 0x100)) 32 | 33 | (defn op-by-opcode [c] (aget ^objects ops c)) 34 | (defn timing-by-opcode [c] (aget ^objects timings c)) 35 | 36 | (defmacro defop [n options & body] 37 | `(doseq [[~'code ~'mode ~'timing] (partition 3 ~options)] 38 | (defn ~(symbol (str \- n)) [~'cpu ~'address-mode] 39 | ~@body) 40 | 41 | (aset timings ~'code (fn cycles-wrapped [~'cpu-before ~'cpu-after] 42 | (~'timing ~'cpu-before ~'cpu-after ~'mode))) 43 | 44 | (aset ops ~'code (with-meta 45 | (fn ~n [~'cpu] 46 | (~(symbol (str \- n)) ~'cpu ~'mode)) 47 | {:address-mode ~'mode 48 | :name (str '~n)})))) 49 | 50 | (defn make-cpu [] {:a 0 51 | :x 0 52 | :y 0 53 | :sp 0xfd 54 | :p 0x24 55 | :pc 0}) 56 | 57 | (defn- inc-pc [cpu] 58 | (assoc cpu :pc (+ 1 (:pc cpu)))) 59 | 60 | (defn- advance-pc [cpu mode] 61 | (assoc cpu :pc (+ (:pc cpu) (mode-size mode)))) 62 | 63 | (defn stack-push [cpu v] 64 | (let [pointer (+ 0x100 (:sp cpu)) 65 | [_ after-push] (io-> cpu 66 | (io-write v pointer)) 67 | new-sp (unsigned-byte (dec (:sp cpu)))] 68 | (assoc after-push :sp new-sp))) 69 | 70 | (defn stack-pull [cpu] 71 | (let [top (unsigned-byte (inc (:sp cpu))) 72 | pointer (+ 0x100 top) 73 | [v after-pull] (io-> cpu (io-read pointer)) 74 | new-sp (unsigned-byte (inc (:sp cpu)))] 75 | [v (assoc after-pull :sp new-sp)])) 76 | 77 | (defn stack-pull-reg [cpu reg] 78 | (let [[v after-pull] (stack-pull cpu)] 79 | (assoc after-pull reg v))) 80 | 81 | (defn stack-pull-pc [cpu] 82 | (let [[low after-low] (stack-pull cpu) 83 | [high after-pulls] (stack-pull after-low) 84 | new-pc (bit-or (bit-shift-left high 8) low)] 85 | (assoc after-pulls :pc new-pc))) 86 | 87 | (defn stack-pull-flags [cpu] 88 | (let [pulled (stack-pull-reg cpu :p)] 89 | (-> pulled 90 | (set-flag break-flag false) 91 | (set-flag unused-flag true)))) 92 | 93 | (defn interrupt-vector [cpu] 94 | (io-> cpu (io-read-word 0xfffe))) 95 | 96 | (defn nmi-vector [cpu] 97 | (io-> cpu (io-read-word 0xfffa))) 98 | 99 | (defn perform-nmi [machine] 100 | (let [cpu machine 101 | return-pc (:pc cpu) 102 | high (high-byte return-pc) 103 | low (low-byte return-pc) 104 | flags (:p cpu) 105 | [interrupt after-read] (nmi-vector cpu)] 106 | (-> after-read 107 | (assoc :interrupt nil) 108 | (stack-push high) 109 | (stack-push low) 110 | (stack-push flags) 111 | (assoc :pc interrupt)))) 112 | 113 | (defn execute-with-timing [cpu op timing] 114 | (let [after-op (op cpu) 115 | cs (timing cpu after-op)] 116 | [cs after-op])) 117 | 118 | (defn cpu-step [machine] 119 | (let [cpu machine 120 | [op-code after-read] (io-> cpu (io-read (:pc cpu))) 121 | op (op-by-opcode op-code) 122 | timing (timing-by-opcode op-code)] 123 | (let [[cs after-op] (execute-with-timing (inc-pc after-read) op timing)] 124 | [cs after-op]))) 125 | 126 | (defn- different-pages? [a1 a2] 127 | (not= (bit-and 0xff00 a1) (bit-and 0xff00 a2))) 128 | 129 | (defn- cycles-page-crossed-penalty-abs-reg [cpu address-mode penalty] 130 | (let [abs-addr (first (io-> cpu (absolute))) 131 | abs-addr-w-reg (first (io-> cpu (address-mode)))] 132 | (if (different-pages? abs-addr abs-addr-w-reg) 133 | penalty 134 | 0))) 135 | 136 | (defn- cycles-page-crossed-penalty-ind-idx [cpu address-mode penalty] 137 | (let [i-addr (first (io-> cpu (indirect-indexed-addr))) 138 | i-addr-w-reg (first (io-> cpu (indirect-indexed)))] 139 | (if (different-pages? i-addr i-addr-w-reg) 140 | penalty 141 | 0))) 142 | 143 | (defn- cycles-page-crossed-penalty [cpu address-mode penalty] 144 | (if (= indirect-indexed address-mode) 145 | (cycles-page-crossed-penalty-ind-idx cpu address-mode penalty) 146 | (cycles-page-crossed-penalty-abs-reg cpu address-mode penalty))) 147 | 148 | (defn- cycles [base & r] 149 | (fn [before-cpu after-cpu address-mode] 150 | (let [opts (apply hash-map r) 151 | page-cross-penalty (if (contains? opts :cross-page) 152 | (cycles-page-crossed-penalty before-cpu address-mode (:cross-page opts)) 153 | 0)] 154 | (+ base page-cross-penalty)))) 155 | 156 | (defn- cycles-branched-instr [before-cpu after-cpu c] 157 | (let [pc-after-branch-instr (unsigned-word (+ 2 (:pc before-cpu)))] 158 | (if (different-pages? pc-after-branch-instr (:pc after-cpu)) 159 | (+ c 2) 160 | (+ c 1)))) 161 | 162 | (defn- branched? [cpu] 163 | (get (meta cpu) :branched? false)) 164 | 165 | (defn- branch-cycles [base] 166 | (fn [before-cpu after-cpu address-mode] 167 | (if (branched? after-cpu) 168 | (cycles-branched-instr before-cpu after-cpu base) 169 | base))) 170 | 171 | ;; Comparison operations 172 | (defn compare-op 173 | [cpu reg operand] 174 | (let [result (unsigned-byte (- (reg cpu) operand)) 175 | value (unsigned-byte operand)] 176 | (-> cpu 177 | (set-flag carry-flag (>= (reg cpu) value)) 178 | (set-flag negative-flag (negative? result)) 179 | (set-flag zero-flag (zero? result))))) 180 | 181 | (defn compare-op-with-io 182 | [cpu mode reg] 183 | (let [[operand after-io] (io-> cpu (mode-read mode))] 184 | (-> after-io 185 | (compare-op reg operand) 186 | (advance-pc mode)))) 187 | 188 | (defop cmp [0xc9 immediate (cycles 2) 189 | 0xc5 zero-page (cycles 3) 190 | 0xd5 zero-page-x (cycles 4) 191 | 0xcd absolute (cycles 4) 192 | 0xdd absolute-x (cycles 4 :cross-page 1) 193 | 0xd9 absolute-y (cycles 4 :cross-page 1) 194 | 0xc1 indexed-indirect (cycles 6) 195 | 0xd1 indirect-indexed (cycles 5 :cross-page 1)] 196 | (compare-op-with-io cpu address-mode :a)) 197 | 198 | (defop cpx [0xe0 immediate (cycles 2) 199 | 0xe4 zero-page (cycles 3) 200 | 0xec absolute (cycles 4)] 201 | (compare-op-with-io cpu address-mode :x)) 202 | 203 | (defop cpy [0xc0 immediate (cycles 2) 204 | 0xc4 zero-page (cycles 3) 205 | 0xcc absolute (cycles 4)] 206 | (compare-op-with-io cpu address-mode :y)) 207 | 208 | ;; Arithmetic operations 209 | (defn subtract-overflowed? 210 | [orig operand result] 211 | (let [orig-neg? (bit-set? orig 7) 212 | operand-neg? (bit-set? operand 7) 213 | result-neg? (bit-set? result 7)] 214 | (if (and (not orig-neg?) operand-neg? result-neg?) 215 | ;; Subtracting a negative from a positive shouldn't result in a negative 216 | true 217 | (if (and orig-neg? (not operand-neg?) (not result-neg?)) 218 | ;; Subtracking a positive from a negative shouldn't result in a 219 | ;; positive 220 | true 221 | false)))) 222 | 223 | (defn add-overflowed? 224 | [orig operand result] 225 | (let [orig-neg? (bit-set? orig 7) 226 | operand-neg? (bit-set? operand 7) 227 | result-neg? (bit-set? result 7)] 228 | (if (and (not orig-neg?) (not operand-neg?) result-neg?) 229 | ;; Adding two positives should not result in a negative 230 | true 231 | (if (and orig-neg? operand-neg? (not result-neg?)) 232 | ;; Adding two negatives should not result in a positive 233 | true 234 | false)))) 235 | 236 | (defn add-op [cpu operand] 237 | (let [signed-result (if (carry-flag? cpu) 238 | (+ (:a cpu) operand 1) 239 | (+ (:a cpu) operand)) 240 | result (unsigned-byte signed-result) 241 | carried? (> signed-result 0xff) 242 | overflowed? (add-overflowed? (:a cpu) operand result)] 243 | (-> cpu 244 | (set-flag carry-flag carried?) 245 | (set-flag overflow-flag overflowed?) 246 | (set-flag negative-flag (negative? result)) 247 | (set-flag zero-flag (zero? result)) 248 | (assoc :a result)))) 249 | 250 | (defop adc [0x69 immediate (cycles 2) 251 | 0x65 zero-page (cycles 3) 252 | 0x75 zero-page-x (cycles 4) 253 | 0x6d absolute (cycles 4) 254 | 0x7d absolute-x (cycles 4 :cross-page 1) 255 | 0x79 absolute-y (cycles 4 :cross-page 1) 256 | 0x61 indexed-indirect (cycles 6) 257 | 0x71 indirect-indexed (cycles 5 :cross-page 1)] 258 | (let [[operand after-io] (io-> cpu (mode-read address-mode))] 259 | (-> after-io 260 | (add-op operand) 261 | (advance-pc address-mode)))) 262 | 263 | (defn subtract-op [cpu operand] 264 | (let [signed-result (if (carry-flag? cpu) 265 | (- (:a cpu) operand) 266 | (- (:a cpu) operand 1)) 267 | result (unsigned-byte signed-result) 268 | carried? (>= signed-result 0) 269 | overflowed? (subtract-overflowed? (:a cpu) operand result)] 270 | (-> cpu 271 | (set-flag carry-flag carried?) 272 | (set-flag overflow-flag overflowed?) 273 | (set-flag negative-flag (negative? result)) 274 | (set-flag zero-flag (zero? result)) 275 | (assoc :a result)))) 276 | 277 | (defop sbc [0xe9 immediate (cycles 2) 278 | 0xe5 zero-page (cycles 3) 279 | 0xf5 zero-page-x (cycles 4) 280 | 0xed absolute (cycles 4) 281 | 0xfd absolute-x (cycles 4 :cross-page 1) 282 | 0xf9 absolute-y (cycles 4 :cross-page 1) 283 | 0xe1 indexed-indirect (cycles 6) 284 | 0xf1 indirect-indexed (cycles 5 :cross-page 1)] 285 | (let [[operand after-io] (io-> cpu (mode-read address-mode))] 286 | (-> after-io 287 | (subtract-op operand) 288 | (advance-pc address-mode)))) 289 | 290 | ;; Logical operations 291 | (defn logical-op 292 | [cpu mode operand method] 293 | (let [result (unsigned-byte (method (:a cpu) operand))] 294 | (-> cpu 295 | (set-flag zero-flag (zero? result)) 296 | (set-flag negative-flag (negative? result)) 297 | (assoc :a result) 298 | (advance-pc mode)))) 299 | 300 | (defop and [0x29 immediate (cycles 2) 301 | 0x25 zero-page (cycles 3) 302 | 0x35 zero-page-x (cycles 4) 303 | 0x2d absolute (cycles 4) 304 | 0x3d absolute-x (cycles 4 :cross-page 1) 305 | 0x39 absolute-y (cycles 4 :cross-page 1) 306 | 0x21 indexed-indirect (cycles 6) 307 | 0x31 indirect-indexed (cycles 5 :cross-page 1)] 308 | (let [[operand after-io] (io-> cpu (mode-read address-mode))] 309 | (logical-op after-io address-mode operand bit-and))) 310 | 311 | (defop ora [0x09 immediate (cycles 2) 312 | 0x05 zero-page (cycles 3) 313 | 0x15 zero-page-x (cycles 4) 314 | 0x0d absolute (cycles 4) 315 | 0x1d absolute-x (cycles 4 :cross-page 1) 316 | 0x19 absolute-y (cycles 4 :cross-page 1) 317 | 0x01 indexed-indirect (cycles 6) 318 | 0x11 indirect-indexed (cycles 5 :cross-page 1)] 319 | (let [[operand after-io] (io-> cpu (mode-read address-mode))] 320 | (logical-op after-io address-mode operand bit-or))) 321 | 322 | (defop eor [0x49 immediate (cycles 2) 323 | 0x45 zero-page (cycles 3) 324 | 0x55 zero-page-x (cycles 4) 325 | 0x4d absolute (cycles 4) 326 | 0x5d absolute-x (cycles 4 :cross-page 1) 327 | 0x59 absolute-y (cycles 4 :cross-page 1) 328 | 0x41 indexed-indirect (cycles 6) 329 | 0x51 indirect-indexed (cycles 5 :cross-page 1)] 330 | (let [[operand after-io] (io-> cpu (mode-read address-mode))] 331 | (logical-op after-io address-mode operand bit-xor))) 332 | 333 | (defop bit [0x24 zero-page (cycles 3) 334 | 0x2c absolute (cycles 4)] 335 | (let [[operand after-io] (io-> cpu (mode-read address-mode)) 336 | result (unsigned-byte (bit-and (:a after-io) operand)) 337 | overflowed? (= 0x40 (bit-and operand 0x40))] 338 | (-> after-io 339 | (set-flag zero-flag (zero? result)) 340 | (set-flag overflow-flag overflowed?) 341 | (set-flag negative-flag (negative? operand)) 342 | (advance-pc address-mode)))) 343 | 344 | ;; Load & store operations 345 | (defn load-op 346 | [cpu mode operand reg] 347 | (let [result (unsigned-byte operand)] 348 | (-> cpu 349 | (set-flag zero-flag (zero? result)) 350 | (set-flag negative-flag (negative? result)) 351 | (assoc reg result) 352 | (advance-pc mode)))) 353 | 354 | (defop lda [0xa9 immediate (cycles 2) 355 | 0xa5 zero-page (cycles 3) 356 | 0xb5 zero-page-x (cycles 4) 357 | 0xad absolute (cycles 4) 358 | 0xbd absolute-x (cycles 4 :cross-page 1) 359 | 0xb9 absolute-y (cycles 4 :cross-page 1) 360 | 0xa1 indexed-indirect (cycles 6) 361 | 0xb1 indirect-indexed (cycles 5 :cross-page 1)] 362 | (let [[operand after-io] (io-> cpu (mode-read address-mode))] 363 | (load-op after-io address-mode operand :a))) 364 | 365 | (defop ldx [0xa2 immediate (cycles 2) 366 | 0xa6 zero-page (cycles 3) 367 | 0xb6 zero-page-y (cycles 4) 368 | 0xae absolute (cycles 4) 369 | 0xbe absolute-y (cycles 4 :cross-page 1)] 370 | (let [[operand after-io] (io-> cpu (mode-read address-mode))] 371 | (load-op after-io address-mode operand :x))) 372 | 373 | (defop ldy [0xa0 immediate (cycles 2) 374 | 0xa4 zero-page (cycles 3) 375 | 0xb4 zero-page-x (cycles 4) 376 | 0xac absolute (cycles 4) 377 | 0xbc absolute-x (cycles 4 :cross-page 1)] 378 | (let [[operand after-io] (io-> cpu (mode-read address-mode))] 379 | (load-op after-io address-mode operand :y))) 380 | 381 | (defn store-op 382 | [cpu address-mode reg] 383 | (let [[_ after-store] (io-> cpu 384 | (mode-write address-mode (reg cpu)))] 385 | (advance-pc after-store address-mode))) 386 | 387 | (defop sta [0x85 zero-page (cycles 3) 388 | 0x95 zero-page-x (cycles 4) 389 | 0x8d absolute (cycles 4) 390 | 0x9d absolute-x (cycles 5) 391 | 0x99 absolute-y (cycles 5) 392 | 0x81 indexed-indirect (cycles 6) 393 | 0x91 indirect-indexed (cycles 6)] 394 | (store-op cpu address-mode :a)) 395 | 396 | (defop stx [0x86 zero-page (cycles 3) 397 | 0x96 zero-page-y (cycles 4) 398 | 0x8e absolute (cycles 4)] 399 | (store-op cpu address-mode :x)) 400 | 401 | (defop sty [0x84 zero-page (cycles 3) 402 | 0x94 zero-page-x (cycles 4) 403 | 0x8c absolute (cycles 4)] 404 | (store-op cpu address-mode :y)) 405 | 406 | ;; Register transfers 407 | (defn transfer-reg 408 | [cpu from to] 409 | (assoc cpu to (from cpu))) 410 | 411 | (defn transfer-reg-op 412 | [cpu from to] 413 | (let [result (from cpu)] 414 | (-> cpu 415 | (transfer-reg from to) 416 | (set-flag zero-flag (zero? result)) 417 | (set-flag negative-flag (negative? result))))) 418 | 419 | (defop tax [0xaa implied (cycles 2)] (transfer-reg-op cpu :a :x)) 420 | (defop tay [0xa8 implied (cycles 2)] (transfer-reg-op cpu :a :y)) 421 | (defop txa [0x8a implied (cycles 2)] (transfer-reg-op cpu :x :a)) 422 | (defop tya [0x98 implied (cycles 2)] (transfer-reg-op cpu :y :a)) 423 | (defop tsx [0xba implied (cycles 2)] (transfer-reg-op cpu :sp :x)) 424 | (defop txs [0x9a implied (cycles 2)] (transfer-reg cpu :x :sp)) 425 | 426 | ;; Increment & decrements 427 | (defn increment-op 428 | [cpu reg] 429 | (let [result (unsigned-byte (inc (reg cpu)))] 430 | (-> cpu 431 | (set-flag zero-flag (zero? result)) 432 | (set-flag negative-flag (negative? result)) 433 | (assoc reg result)))) 434 | 435 | (defop inc [0xe6 zero-page (cycles 5) 436 | 0xf6 zero-page-x (cycles 6) 437 | 0xee absolute (cycles 6) 438 | 0xfe absolute-x (cycles 7)] 439 | (let [[result after-io] ((with-io-> [orig (mode-read address-mode) 440 | incd (let [result (unsigned-byte (inc orig))] 441 | (mode-write address-mode result))] 442 | incd) cpu)] 443 | (-> after-io 444 | (set-flag zero-flag (zero? result)) 445 | (set-flag negative-flag (negative? result)) 446 | (advance-pc address-mode)))) 447 | 448 | (defop inx [0xe8 implied (cycles 2)] (increment-op cpu :x)) 449 | (defop iny [0xc8 implied (cycles 2)] (increment-op cpu :y)) 450 | 451 | (defn dec-reg-op 452 | [cpu reg] 453 | (let [result (unsigned-byte (dec (reg cpu)))] 454 | (-> cpu 455 | (set-flag zero-flag (zero? result)) 456 | (set-flag negative-flag (negative? result)) 457 | (assoc reg result)))) 458 | 459 | (defop dec [0xc6 zero-page (cycles 5) 460 | 0xd6 zero-page-x (cycles 6) 461 | 0xce absolute (cycles 6) 462 | 0xde absolute-x (cycles 7)] 463 | (let [[result after-io] ((with-io-> [before (mode-read address-mode) 464 | after (mode-write address-mode 465 | (unsigned-byte 466 | (dec before)))] 467 | after) cpu)] 468 | (-> after-io 469 | (set-flag zero-flag (zero? result)) 470 | (set-flag negative-flag (negative? result)) 471 | (advance-pc address-mode)))) 472 | 473 | (defop dex [0xca implied (cycles 2)] (dec-reg-op cpu :x)) 474 | (defop dey [0x88 implied (cycles 2)] (dec-reg-op cpu :y)) 475 | 476 | ;; Stack pushing and popping 477 | (defop pha [0x48 implied (cycles 3)] (stack-push cpu (:a cpu))) 478 | (defop php [0x08 implied (cycles 3)] (stack-push cpu (bit-or 0x10 (:p cpu)))) 479 | 480 | (defop pla [0x68 implied (cycles 4)] 481 | (let [pulled (stack-pull-reg cpu :a) 482 | result (:a pulled)] 483 | (-> pulled 484 | (set-flag zero-flag (zero? result)) 485 | (set-flag negative-flag (negative? result))))) 486 | 487 | (defop plp [0x28 implied (cycles 4)] (stack-pull-flags cpu)) 488 | 489 | ;; Jumps and calls 490 | (defop jmp [0x4c absolute (cycles 3) 491 | 0x6c indirect (cycles 5)] 492 | (let [[where after-io] (io-> cpu 493 | (address-mode))] 494 | (assoc after-io :pc where))) 495 | 496 | (defop jsr [0x20 absolute (cycles 6)] 497 | (let [return-pc (dec (:pc (advance-pc cpu address-mode))) 498 | high (high-byte return-pc) 499 | low (low-byte return-pc) 500 | [where after-io] (io-> cpu 501 | (address-mode))] 502 | (-> after-io 503 | (stack-push high) 504 | (stack-push low) 505 | (assoc :pc where)))) 506 | 507 | (defop rti [0x40 implied (cycles 6)] 508 | (-> cpu 509 | (stack-pull-flags) 510 | (stack-pull-pc))) 511 | 512 | (defop rts [0x60 implied (cycles 6)] 513 | (let [pulled (stack-pull-pc cpu)] 514 | (update-in pulled [:pc] inc))) 515 | 516 | ;; Branching 517 | (defn branch-if [cpu mode predicate] 518 | (let [[addr after-io] (io-> cpu (relative))] 519 | (if predicate 520 | (with-meta (assoc after-io :pc addr) {:branched? true}) 521 | (with-meta (advance-pc after-io mode) {})))) 522 | 523 | (defop bcc [0x90 relative (branch-cycles 2)] (branch-if cpu address-mode (not (carry-flag? cpu)))) 524 | (defop bcs [0xb0 relative (branch-cycles 2)] (branch-if cpu address-mode (carry-flag? cpu))) 525 | (defop beq [0xf0 relative (branch-cycles 2)] (branch-if cpu address-mode (zero-flag? cpu))) 526 | (defop bmi [0x30 relative (branch-cycles 2)] (branch-if cpu address-mode (negative-flag? cpu))) 527 | (defop bne [0xd0 relative (branch-cycles 2)] (branch-if cpu address-mode (not (zero-flag? cpu)))) 528 | (defop bpl [0x10 relative (branch-cycles 2)] (branch-if cpu address-mode (not (negative-flag? cpu)))) 529 | (defop bvc [0x50 relative (branch-cycles 2)] (branch-if cpu address-mode (not (overflow-flag? cpu)))) 530 | (defop bvs [0x70 relative (branch-cycles 2)] (branch-if cpu address-mode (overflow-flag? cpu))) 531 | 532 | ;; Status flag changes 533 | (defop clc [0x18 implied (cycles 2)] (set-flag cpu carry-flag false)) 534 | (defop cld [0xd8 implied (cycles 2)] (set-flag cpu decimal-flag false)) 535 | (defop cli [0x58 implied (cycles 2)] (set-flag cpu interrupt-flag false)) 536 | (defop clv [0xb8 implied (cycles 2)] (set-flag cpu overflow-flag false)) 537 | (defop sec [0x38 implied (cycles 2)] (set-flag cpu carry-flag true)) 538 | (defop sed [0xf8 implied (cycles 2)] (set-flag cpu decimal-flag true)) 539 | (defop sei [0x78 implied (cycles 2)] (set-flag cpu interrupt-flag true)) 540 | 541 | ;; System functions 542 | (defop nop [0xea implied (cycles 2)] cpu) 543 | 544 | (defop brk [0x00 implied (cycles 7)] 545 | (let [pc (inc (:pc cpu)) 546 | [interrupt after-read] (interrupt-vector cpu) 547 | high (high-byte pc) 548 | low (low-byte pc)] 549 | (-> after-read 550 | (stack-push high) 551 | (stack-push low) 552 | (stack-push (bit-or 0x10 (:p after-read))) 553 | (set-flag interrupt-flag true) 554 | (assoc :pc interrupt)))) 555 | 556 | ;; Shifts 557 | (defn shift-mode-left [cpu address-mode] 558 | (let [[[orig result] after-io] ((with-io-> [before (mode-read address-mode) 559 | after (mode-write address-mode 560 | (unsigned-byte 561 | (bit-shift-left before 1)))] 562 | [before after]) cpu) 563 | carried? (bit-set? orig 7) 564 | negative? (bit-set? result 7)] 565 | (-> after-io 566 | (set-flag zero-flag (zero? result)) 567 | (set-flag negative-flag negative?) 568 | (set-flag carry-flag carried?)))) 569 | 570 | (defop asl [0x0a accumulator (cycles 2) 571 | 0x06 zero-page (cycles 5) 572 | 0x16 zero-page-x (cycles 6) 573 | 0x0e absolute (cycles 6) 574 | 0x1e absolute-x (cycles 7)] 575 | (-> cpu 576 | (shift-mode-left address-mode) 577 | (advance-pc address-mode))) 578 | 579 | (defn shift-mode-right [cpu address-mode] 580 | (let [[[orig result] after-io] ((with-io-> [before (mode-read address-mode) 581 | after (mode-write address-mode 582 | (unsigned-byte 583 | (bit-shift-right before 1)))] 584 | [before after]) cpu) 585 | carried? (bit-set? orig 0)] 586 | (-> after-io 587 | (set-flag carry-flag carried?) 588 | (set-flag negative-flag false) 589 | (set-flag zero-flag (zero? result))))) 590 | 591 | (defop lsr [0x4a accumulator (cycles 2) 592 | 0x46 zero-page (cycles 5) 593 | 0x56 zero-page-x (cycles 6) 594 | 0x4e absolute (cycles 6) 595 | 0x5e absolute-x (cycles 7)] 596 | (-> cpu 597 | (shift-mode-right address-mode) 598 | (advance-pc address-mode))) 599 | 600 | (defn rotate-l [v carry?] 601 | (let [shifted (unsigned-byte (bit-shift-left v 1))] 602 | (if carry? 603 | (bit-or 1 shifted) 604 | shifted))) 605 | 606 | (defn rotate-mode-left [cpu address-mode] 607 | (let [with-carry? (carry-flag? cpu) 608 | [[orig result] after-io] ((with-io-> [before (mode-read address-mode) 609 | after (mode-write address-mode 610 | (rotate-l before with-carry?))] 611 | [before after]) cpu) 612 | carried? (bit-set? orig 7) 613 | negative? (bit-set? result 7)] 614 | (-> after-io 615 | (set-flag negative-flag negative?) 616 | (set-flag zero-flag (zero? result)) 617 | (set-flag carry-flag carried?)))) 618 | 619 | (defop rol [0x2a accumulator (cycles 2) 620 | 0x26 zero-page (cycles 5) 621 | 0x36 zero-page-x (cycles 6) 622 | 0x2e absolute (cycles 6) 623 | 0x3e absolute-x (cycles 7)] 624 | (-> cpu 625 | (rotate-mode-left address-mode) 626 | (advance-pc address-mode))) 627 | 628 | (defn rotate-r [v carry?] 629 | (let [shifted (unsigned-byte (bit-shift-right v 1))] 630 | (if carry? 631 | (bit-or 0x80 shifted) 632 | shifted))) 633 | 634 | (defn rotate-mode-right [cpu address-mode] 635 | (let [with-carry? (carry-flag? cpu) 636 | [[orig result] after-io] ((with-io-> [before (mode-read address-mode) 637 | after (mode-write address-mode 638 | (rotate-r before with-carry?))] 639 | [before after]) cpu) 640 | carried? (bit-set? orig 0) 641 | negative? (bit-set? result 7)] 642 | (-> after-io 643 | (set-flag zero-flag (zero? result)) 644 | (set-flag negative-flag negative?) 645 | (set-flag carry-flag carried?)))) 646 | 647 | (defop ror [0x6a accumulator (cycles 2) 648 | 0x66 zero-page (cycles 5) 649 | 0x76 zero-page-x (cycles 6) 650 | 0x6e absolute (cycles 6) 651 | 0x7e absolute-x (cycles 7)] 652 | (-> cpu 653 | (rotate-mode-right address-mode) 654 | (advance-pc address-mode))) 655 | 656 | ;; Unofficial operations 657 | (defop *nop [0x04 zero-page (cycles 3) 658 | 0x44 zero-page (cycles 3) 659 | 0x64 zero-page (cycles 3) 660 | 0x0c absolute (cycles 4) 661 | 0x14 zero-page-x (cycles 4) 662 | 0x34 zero-page-x (cycles 4) 663 | 0x54 zero-page-x (cycles 4) 664 | 0x74 zero-page-x (cycles 4) 665 | 0xd4 zero-page-x (cycles 4) 666 | 0xf4 zero-page-x (cycles 4) 667 | 0x1a implied (cycles 2) 668 | 0x3a implied (cycles 2) 669 | 0x5a implied (cycles 2) 670 | 0x7a implied (cycles 2) 671 | 0xda implied (cycles 2) 672 | 0xfa implied (cycles 2) 673 | 0x80 immediate (cycles 2) 674 | 0x82 immediate (cycles 2) 675 | 0x89 immediate (cycles 2) 676 | 0xc2 immediate (cycles 2) 677 | 0xe2 immediate (cycles 2) 678 | 0x1c absolute-x (cycles 4 :cross-page 1) 679 | 0x3c absolute-x (cycles 4 :cross-page 1) 680 | 0x5c absolute-x (cycles 4 :cross-page 1) 681 | 0x7c absolute-x (cycles 4 :cross-page 1) 682 | 0xdc absolute-x (cycles 4 :cross-page 1) 683 | 0xfc absolute-x (cycles 4 :cross-page 1)] 684 | (advance-pc cpu address-mode)) 685 | 686 | (defop *lax [0xab immediate (cycles 2) 687 | 0xa3 indexed-indirect (cycles 6) 688 | 0xa7 zero-page (cycles 3) 689 | 0xaf absolute (cycles 4) 690 | 0xb3 indirect-indexed (cycles 5 :cross-page 1) 691 | 0xb7 zero-page-y (cycles 4) 692 | 0xbf absolute-y (cycles 4 :cross-page 1)] 693 | (let [[v after-io] (io-> cpu (mode-read address-mode))] 694 | (-> after-io 695 | (set-flag zero-flag (zero? v)) 696 | (set-flag negative-flag (negative? v)) 697 | (assoc :x v) 698 | (assoc :a v) 699 | (advance-pc address-mode)))) 700 | 701 | (defop *sax [0x83 indexed-indirect (cycles 6) 702 | 0x87 zero-page (cycles 3) 703 | 0x8f absolute (cycles 4) 704 | 0x97 zero-page-y (cycles 4)] 705 | (let [v (bit-and (:a cpu) (:x cpu)) 706 | [_ after-io] (io-> cpu 707 | (mode-write address-mode v))] 708 | (advance-pc after-io address-mode))) 709 | 710 | (defop *sbc [0xeb immediate (cycles 2)] 711 | (-sbc cpu address-mode)) 712 | 713 | (defop *dcp [0xc3 indexed-indirect (cycles 8) 714 | 0xd3 indirect-indexed (cycles 8) 715 | 0xc7 zero-page (cycles 5) 716 | 0xcf absolute (cycles 6) 717 | 0xd7 zero-page-x (cycles 6) 718 | 0xdb absolute-y (cycles 7) 719 | 0xdf absolute-x (cycles 7)] 720 | (let [[operand after-io] ((with-io-> [orig (mode-read address-mode) 721 | decd (mode-write 722 | address-mode 723 | (unsigned-byte (dec orig)))] 724 | decd) cpu)] 725 | (-> after-io 726 | (compare-op :a operand) 727 | (advance-pc address-mode)))) 728 | 729 | (defop *isb [0xe3 indexed-indirect (cycles 8) 730 | 0xe7 zero-page (cycles 5) 731 | 0xef absolute (cycles 6) 732 | 0xf3 indirect-indexed (cycles 8) 733 | 0xf7 zero-page-x (cycles 6) 734 | 0xfb absolute-y (cycles 7) 735 | 0xff absolute-x (cycles 7)] 736 | (let [[incd after-io] ((with-io-> [orig (mode-read address-mode) 737 | incd (mode-write 738 | address-mode 739 | (unsigned-byte (inc orig)))] 740 | incd) cpu)] 741 | (-> after-io 742 | (subtract-op incd) 743 | (advance-pc address-mode)))) 744 | 745 | (defop *slo [0x03 indexed-indirect (cycles 8) 746 | 0x07 zero-page (cycles 5) 747 | 0x0f absolute (cycles 6) 748 | 0x13 indirect-indexed (cycles 8) 749 | 0x17 zero-page-x (cycles 6) 750 | 0x1b absolute-y (cycles 7) 751 | 0x1f absolute-x (cycles 7)] 752 | (let [after-shift (shift-mode-left cpu address-mode) 753 | [shifted after-read] (io-> after-shift (mode-read address-mode))] 754 | (logical-op after-read address-mode shifted bit-or))) 755 | 756 | (defop *rla [0x23 indexed-indirect (cycles 8) 757 | 0x27 zero-page (cycles 5) 758 | 0x2f absolute (cycles 6) 759 | 0x33 indirect-indexed (cycles 8) 760 | 0x37 zero-page-x (cycles 6) 761 | 0x3b absolute-y (cycles 7) 762 | 0x3f absolute-x (cycles 7)] 763 | (let [after-rotate (rotate-mode-left cpu address-mode) 764 | [rotated after-read] (io-> after-rotate (mode-read address-mode))] 765 | (logical-op after-read address-mode rotated bit-and))) 766 | 767 | (defop *sre [0x43 indexed-indirect (cycles 8) 768 | 0x47 zero-page (cycles 5) 769 | 0x4f absolute (cycles 6) 770 | 0x53 indirect-indexed (cycles 8) 771 | 0x57 zero-page-x (cycles 6) 772 | 0x5b absolute-y (cycles 7) 773 | 0x5f absolute-x (cycles 7)] 774 | (let [after-shift (shift-mode-right cpu address-mode) 775 | [shifted after-read] (io-> after-shift (mode-read address-mode))] 776 | (logical-op after-read address-mode shifted bit-xor))) 777 | 778 | (defop *rra [0x63 indexed-indirect (cycles 8) 779 | 0x67 zero-page (cycles 5) 780 | 0x6f absolute (cycles 6) 781 | 0x73 indirect-indexed (cycles 8) 782 | 0x77 zero-page-x (cycles 6) 783 | 0x7b absolute-y (cycles 7) 784 | 0x7f absolute-x (cycles 7)] 785 | (let [after-rotate (rotate-mode-right cpu address-mode) 786 | [rotated after-read] (io-> after-rotate (mode-read address-mode))] 787 | (-> after-read 788 | (add-op rotated) 789 | (advance-pc address-mode)))) 790 | 791 | (defop *anc [0x0b immediate (cycles 2) 792 | 0x2b immediate (cycles 2)] 793 | (let [[operand after-io] (io-> cpu (mode-read address-mode)) 794 | after-and (logical-op after-io address-mode operand bit-and) 795 | carried? (bit-set? (:a after-and) 7)] 796 | (set-flag after-and carry-flag carried?))) 797 | 798 | (defop *alr [0x4b immediate (cycles 2)] 799 | (let [[operand after-io] (io-> cpu (mode-read address-mode)) 800 | after-and (logical-op after-io address-mode operand bit-and)] 801 | (shift-mode-right after-and accumulator))) 802 | 803 | (defop *axs [0xcb immediate (cycles 2)] 804 | (let [[operand after-io] (io-> cpu (mode-read address-mode)) 805 | anded (bit-and (:a after-io) (:x after-io)) 806 | subbed (- anded operand) 807 | result (unsigned-byte subbed) 808 | carried? (>= anded operand)] 809 | (-> after-io 810 | (assoc :x result) 811 | (set-flag carry-flag carried?) 812 | (set-flag negative-flag (negative? result)) 813 | (set-flag zero-flag (zero? result)) 814 | (advance-pc address-mode)))) 815 | 816 | (defop *arr [0x6b immediate (cycles 2)] 817 | (let [[operand after-io] (io-> cpu (mode-read address-mode)) 818 | anded (bit-and (:a after-io) operand) 819 | rotated (rotate-r anded (carry-flag? after-io)) 820 | carried? (bit-set? rotated 6) 821 | overflowed? (not= 0 822 | (bit-xor 823 | (bit-and rotated 0x40) 824 | (bit-shift-left (bit-and rotated 0x20) 1)))] 825 | (-> after-io 826 | (assoc :a rotated) 827 | (set-flag negative-flag (negative? rotated)) 828 | (set-flag zero-flag (zero? rotated)) 829 | (set-flag carry-flag carried?) 830 | (set-flag overflow-flag overflowed?) 831 | (advance-pc address-mode)))) 832 | 833 | (defn- sh*-op [cpu address-mode reg] 834 | (let [[addr after-io] (io-> cpu (address-mode)) 835 | high (unsigned-byte (inc (high-byte addr))) 836 | result (bit-and (reg after-io) high) 837 | [_ after-write] (io-> after-io 838 | (mode-write address-mode result))] 839 | (advance-pc after-write address-mode))) 840 | 841 | (defop *shy [0x9c absolute-x (cycles 5)] (sh*-op cpu address-mode :y)) 842 | (defop *shx [0x9e absolute-y (cycles 5)] (sh*-op cpu address-mode :x)) 843 | -------------------------------------------------------------------------------- /spec/clones/cpu_spec.clj: -------------------------------------------------------------------------------- 1 | (ns clones.cpu-spec 2 | (:require [speclj.core :refer :all] 3 | [clones.cpu :refer :all] 4 | [clones.cpu.memory :refer :all] 5 | [clones.nes.mappers :refer :all] 6 | [clones.cpu.addressing :refer :all])) 7 | 8 | (defrecord MockMapper [prg chr] 9 | Mapper 10 | (prg-read [this addr] [(get prg addr 0) this]) 11 | (prg-write [this v addr] [v (assoc this :prg (assoc prg addr v))]) 12 | (chr-read [this addr] [(get chr addr 0) this]) 13 | (chr-write [this v addr] [v (assoc this :chr (assoc chr addr v))])) 14 | (defn mapper [] (MockMapper. {} {})) 15 | 16 | (def cpu (merge (make-cpu) {:internal-ram {} 17 | :ppu {} 18 | :apu {} 19 | :mapper (mapper)})) 20 | (def cpu-with-carry (assoc cpu :p carry-flag)) 21 | (def cpu-with-zero (assoc cpu :p zero-flag)) 22 | (def cpu-with-negative (assoc cpu :p negative-flag)) 23 | (def cpu-with-decimal (assoc cpu :p decimal-flag)) 24 | (def cpu-with-interrupt (assoc cpu :p interrupt-flag)) 25 | (def cpu-with-overflow (assoc cpu :p overflow-flag)) 26 | 27 | (describe "The NES's 6502 2A03/7 CPU" 28 | (defn peek-stack-n [c n] 29 | (first 30 | (io-> c 31 | (io-read (+ 0x100 1 n (:sp c)))))) 32 | 33 | (defn peek-stack [c] (peek-stack-n c 0)) 34 | 35 | (defn with-stack-top [cpu v] 36 | (let [[_ after-write] (io-> cpu 37 | (io-write v 0x1fd))] 38 | (assoc after-write :sp 0xfc))) 39 | 40 | (describe "executing an NMI" 41 | (it "should push the flags to the stack" 42 | (let [machine (assoc cpu :p 0xee) 43 | new-machine (perform-nmi machine) 44 | flags (peek-stack-n new-machine 0)] 45 | (should= 0xee flags))) 46 | 47 | (it "should set the program counter to the NMI vector at $fffa" 48 | (let [machine (second (io-> cpu 49 | (io-write-word 0xbeef 0xfffa))) 50 | new-machine (perform-nmi machine)] 51 | (should= 0xbeef (:pc new-machine)))) 52 | 53 | 54 | (it "should push the current program counter to the stack" 55 | (let [machine (assoc cpu :pc 0xffee) 56 | new-machine (perform-nmi machine) 57 | low (peek-stack-n new-machine 1) 58 | high (peek-stack-n new-machine 2)] 59 | (should= 0xff high) 60 | (should= 0xee low)))) 61 | 62 | (describe "instruction set" 63 | (defn check-zero-flag-sets [c] 64 | (it "should set the zero flag when the result is zero" 65 | (should (zero-flag? (c cpu))))) 66 | 67 | (defn check-zero-flag-unsets [c] 68 | (it "should unset the zero flag when the result is non-zero" 69 | (should-not (zero-flag? (c (set-flag cpu zero-flag true)))))) 70 | 71 | (defn check-negative-flag-sets [c] 72 | (it "should set the negative flag when the result is negative" 73 | (should (negative-flag? (c cpu))))) 74 | 75 | (defn check-negative-flag-unsets [c] 76 | (it "should unset the negative flag when the result is non-negative" 77 | (should-not (negative-flag? (c (set-flag cpu negative-flag true)))))) 78 | 79 | (defn check-carry-flag-unsets [c] 80 | (it "should unset the carry flag when the result doesn't carry" 81 | (should-not (carry-flag? (c (set-flag cpu carry-flag true)))))) 82 | 83 | (defn check-carry-flag-sets [c] 84 | (it "should set the carry flag when the result carries" 85 | (should (carry-flag? (c cpu))))) 86 | 87 | (defn check-pc-increments [c op vs] 88 | (map (fn [[amount mode]] 89 | (it (format "should increment the program counter by %d when mode %s" amount mode) 90 | (let [result (op c (mode-by-name mode))] 91 | (should= (+ amount (:pc c)) (:pc result))))) 92 | (partition 2 vs))) 93 | 94 | (defn check-branching [desc f should-branch should-not-branch] 95 | (it desc 96 | (should= 1 (:pc (f should-not-branch relative))) 97 | (let [[_ should-branch] (io-> should-branch 98 | (io-write 0x50 0))] 99 | (should= 0x51 (:pc (f should-branch relative)))))) 100 | 101 | (defn imm-n [cpu n] 102 | (second (io-> cpu (io-write n 0)))) 103 | 104 | (describe "unofficial operations" 105 | ;; Note that these are not tested as exhaustively as the official opcodes 106 | ;; Particularly the flag settings aren't unit tested. The nestest rom 107 | ;; does test the flags, and these should all pass that 108 | 109 | (describe "*shy" 110 | (it "should store (Y & (mode address high byte + 1)) at the address mode" 111 | (let [new-cpu (-*shy (second (io-> (assoc cpu :y 0xff) 112 | (io-write 0 0) 113 | (io-write 1 1))) absolute)] 114 | (should= 2 (io-debug-> new-cpu (io-read 0x100)))))) 115 | 116 | (describe "*arr" 117 | (check-pc-increments cpu -*arr [1 :immediate]) 118 | 119 | (it "should set the accumulator to (A & immediate) and then rotate the 120 | accumulator right one" 121 | (let [new-cpu (-*arr (imm-n (assoc cpu-with-carry :a 0xaa) 0x55) immediate)] 122 | (should= 0x80 (:a new-cpu))))) 123 | 124 | (describe "*axs" 125 | (check-pc-increments cpu -*axs [1 :immediate]) 126 | 127 | (it "should set X to (A & X) - immediate" 128 | (let [new-cpu (-*axs (imm-n (merge cpu {:a 0xff 129 | :x 0x40}) 130 | 2) immediate)] 131 | (should= 0x3e (:x new-cpu))))) 132 | 133 | 134 | (describe "*alr" 135 | (check-pc-increments cpu -*alr [1 :immediate]) 136 | 137 | (it "should and the argument with the accumulator and shift the result right" 138 | (let [new-cpu (-*alr (imm-n (assoc cpu :a 0xff) 0xa5) immediate)] 139 | (should= 0x52 (:a new-cpu))))) 140 | 141 | (describe "*anc" 142 | (check-pc-increments cpu -*anc [1 :immediate]) 143 | 144 | (it "should set the carry flag if the result has bit 7 set" 145 | (let [new-cpu (-*anc (imm-n (assoc cpu :a 0xff) 0xa5) immediate)] 146 | (should (carry-flag? new-cpu)))) 147 | 148 | (it "should and the argument with the accumulator" 149 | (let [new-cpu (-*anc (imm-n (assoc cpu :a 0xff) 0xa5) immediate)] 150 | (should= 0xa5 (:a new-cpu))))) 151 | 152 | (describe "*rra" 153 | (check-pc-increments cpu -*rra [1 :zero-page 154 | 1 :zero-page-x 155 | 1 :indexed-indirect 156 | 1 :indirect-indexed 157 | 2 :absolute 158 | 2 :absolute-x 159 | 2 :absolute-y]) 160 | 161 | (it "should add the result to the accumulator" 162 | (let [new-cpu (-*rra (assoc (imm-n cpu 0x4) :a 1) immediate)] 163 | (should= 0x3 (:a new-cpu)))) 164 | 165 | (it "should rotate the value at the address mode right 1" 166 | (let [new-cpu (-*rra cpu-with-carry immediate)] 167 | (should= 0x80 (first (io-> new-cpu (io-read 0))))) 168 | 169 | (let [new-cpu (-*rra (imm-n cpu 0x80) immediate)] 170 | (should= 0x40 (first (io-> new-cpu (io-read 0))))))) 171 | 172 | (describe "*sre" 173 | (check-pc-increments cpu -*sre [1 :zero-page 174 | 1 :zero-page-x 175 | 1 :indexed-indirect 176 | 1 :indirect-indexed 177 | 2 :absolute 178 | 2 :absolute-x 179 | 2 :absolute-y]) 180 | 181 | (it "should xor the result with the accumulator" 182 | (let [new-cpu (-*sre (assoc (imm-n cpu 0x4) :a 0xff) immediate)] 183 | (should= 0xfd (:a new-cpu)))) 184 | 185 | (it "should shift the value at the address mode right 1" 186 | (let [new-cpu (-*sre (imm-n cpu 2) immediate)] 187 | (should= 1 (:a new-cpu))))) 188 | 189 | (describe "*rla" 190 | (check-pc-increments cpu -*rla [1 :zero-page 191 | 1 :zero-page-x 192 | 1 :indexed-indirect 193 | 1 :indirect-indexed 194 | 2 :absolute 195 | 2 :absolute-x 196 | 2 :absolute-y]) 197 | 198 | (it "should and the result with the accumulator" 199 | (let [new-cpu (-*rla (assoc (imm-n cpu 0x4) :a 0xff) immediate)] 200 | (should= 0x8 (:a new-cpu)))) 201 | 202 | (it "should rotate the value at the address mode left 1" 203 | (let [new-cpu (-*rla (assoc cpu-with-carry :a 1) accumulator)] 204 | (should= 3 (:a new-cpu))) 205 | 206 | (let [new-cpu (-*rla (assoc cpu :a 1) accumulator)] 207 | (should= 2 (:a new-cpu))))) 208 | 209 | (describe "*slo" 210 | (check-pc-increments cpu -*slo [1 :zero-page 211 | 1 :zero-page-x 212 | 1 :indexed-indirect 213 | 1 :indirect-indexed 214 | 2 :absolute 215 | 2 :absolute-x 216 | 2 :absolute-y]) 217 | 218 | (it "should or the result with the accumulator" 219 | (let [new-cpu (-*slo (imm-n cpu 0xbe) immediate)] 220 | (should= 0x7c (:a new-cpu)))) 221 | 222 | (it "should shift the value at the address mode left 1" 223 | (let [new-cpu (-*slo (assoc cpu :a 1) accumulator)] 224 | (should= 2 (:a new-cpu))))) 225 | 226 | (describe "*isb" 227 | (check-pc-increments cpu -*isb [1 :zero-page 228 | 1 :zero-page-x 229 | 1 :indexed-indirect 230 | 1 :indirect-indexed 231 | 2 :absolute 232 | 2 :absolute-x 233 | 2 :absolute-y]) 234 | 235 | (it "should subtract the value at the address mode plus 1 from the accumulator" 236 | (let [new-cpu (-*isb cpu-with-carry immediate)] 237 | (should= 0xff (:a new-cpu)))) 238 | 239 | (it "should increment the value of the memory location by 1" 240 | (let [new-cpu (-*isb cpu immediate)] 241 | (should= 1 (first (io-> new-cpu (io-read 0))))))) 242 | 243 | (describe "*dcp" 244 | (check-pc-increments cpu -*dcp [1 :zero-page 245 | 1 :zero-page-x 246 | 1 :indexed-indirect 247 | 1 :indirect-indexed 248 | 2 :absolute 249 | 2 :absolute-x 250 | 2 :absolute-y]) 251 | 252 | (check-zero-flag-sets #(-*dcp (imm-n %1 1) immediate)) 253 | (check-zero-flag-unsets #(-*dcp % immediate)) 254 | 255 | (check-negative-flag-sets (fn [c] 256 | (-*dcp (assoc c :a 0x81) 257 | immediate))) 258 | (check-negative-flag-unsets #(-*dcp %1 immediate)) 259 | 260 | (it "should decrement the value of the memory location by 1" 261 | (let [new-cpu (-*dcp cpu immediate)] 262 | (should= 0xff (first (io-> new-cpu (io-read 0)))))) 263 | 264 | (it "should unset the carry flag if the accumulator is less than the operand minus 1" 265 | (let [with-gt-v (imm-n cpu-with-carry 2) 266 | new-cpu (-*dcp with-gt-v immediate)] 267 | (should-not (carry-flag? new-cpu)))) 268 | 269 | (it "should set the carry flag if the accumulator is greater than or equal to the operand minus 1" 270 | (let [with-val (second (io-> (assoc cpu :a 0x40) 271 | (io-write 1 0))) 272 | new-cpu (-*dcp with-val immediate)] 273 | (should (carry-flag? new-cpu))))) 274 | 275 | 276 | (describe "*sax" 277 | (check-pc-increments cpu -*sax [1 :zero-page 278 | 1 :zero-page-y 279 | 1 :indexed-indirect 280 | 1 :indirect-indexed 281 | 2 :absolute]) 282 | 283 | (it "should write A & X to the address mode" 284 | (let [new-cpu (-*sax (merge cpu {:a 0xff :x 0x40}) zero-page)] 285 | (should= 0x40 (first (io-> new-cpu (io-read 0))))))) 286 | 287 | (describe "*lax" 288 | (check-pc-increments cpu -*lax [1 :zero-page 289 | 1 :zero-page-y 290 | 1 :indexed-indirect 291 | 1 :indirect-indexed 292 | 2 :absolute 293 | 2 :absolute-y]) 294 | 295 | (check-zero-flag-sets #(-*lax %1 accumulator)) 296 | (check-zero-flag-unsets #(-*lax (assoc %1 :a 1) accumulator)) 297 | 298 | (check-negative-flag-sets #(-*lax (assoc %1 :a 0x80) accumulator)) 299 | (check-negative-flag-unsets #(-*lax (assoc %1 :a 1) accumulator)) 300 | 301 | (it "should load the accumulator with the value at the address mode" 302 | (let [cpu-with-mem (second (io-> cpu 303 | (io-write 0xff 0))) 304 | new-cpu (-*lax cpu-with-mem immediate)] 305 | (should= 0xff (:a new-cpu)))) 306 | 307 | (it "should load the x register with the value at the address mode" 308 | (let [cpu-with-mem (second (io-> cpu 309 | (io-write 0xff 0))) 310 | new-cpu (-*lax cpu-with-mem immediate)] 311 | (should= 0xff (:x new-cpu))))) 312 | 313 | (describe "*nop" 314 | (check-pc-increments cpu -asl [0 :accumulator 315 | 1 :zero-page]))) 316 | 317 | (describe "store operations" 318 | (describe "sty" 319 | (check-pc-increments cpu -sty [1 :zero-page 320 | 1 :zero-page-x 321 | 2 :absolute]) 322 | 323 | (it "should store the y register in the address mode" 324 | (let [new-cpu (-sty (assoc cpu :y 0xff) absolute)] 325 | (should= 0xff (first (io-> new-cpu 326 | (io-read 0))))))) 327 | 328 | (describe "stx" 329 | (check-pc-increments cpu -stx [1 :zero-page 330 | 1 :zero-page-y 331 | 2 :absolute]) 332 | 333 | (it "should store the x register in the address mode" 334 | (let [new-cpu (-stx (assoc cpu :x 0xff) absolute)] 335 | (should= 0xff (first (io-> new-cpu 336 | (io-read 0))))))) 337 | 338 | (describe "sta" 339 | (check-pc-increments cpu -sta [1 :zero-page 340 | 1 :zero-page-x 341 | 2 :absolute 342 | 2 :absolute-x 343 | 2 :absolute-y 344 | 1 :indexed-indirect 345 | 1 :indirect-indexed]) 346 | 347 | (it "should store the accumulator in the address mode" 348 | (let [new-cpu (-sta (assoc cpu :a 0xff) absolute)] 349 | (should= 0xff (first (io-> new-cpu 350 | (io-read 0)))))))) 351 | 352 | (describe "shifts and rotates" 353 | (describe "ror" 354 | (check-pc-increments cpu -ror [0 :accumulator 355 | 1 :zero-page 356 | 1 :zero-page-x 357 | 2 :absolute 358 | 2 :absolute-x]) 359 | 360 | (check-zero-flag-sets #(-ror %1 accumulator)) 361 | (check-zero-flag-unsets #(-ror (assoc %1 :a 0x80) accumulator)) 362 | 363 | (check-negative-flag-sets #(-ror (assoc %1 :p carry-flag) accumulator)) 364 | (check-negative-flag-unsets #(-ror (assoc %1 :a 0x40) accumulator)) 365 | 366 | (check-carry-flag-sets #(-ror (assoc %1 :a 1) accumulator)) 367 | (check-carry-flag-unsets #(-ror (assoc %1 :a 0x80) accumulator)) 368 | 369 | (it "should set bit 7 of the result if the carry flag is set" 370 | (let [cpu-rotated (-> cpu-with-carry 371 | (assoc :a 0x20) 372 | (-ror accumulator))] 373 | (should= 0x90 (:a cpu-rotated)))) 374 | 375 | (it "should shift the bits of the address mode right by 1" 376 | (let [cpu-rotated (-> cpu 377 | (assoc :a 0x21) 378 | (-ror accumulator))] 379 | (should= 0x10 (:a cpu-rotated))))) 380 | 381 | (describe "rol" 382 | (check-pc-increments cpu -rol [0 :accumulator 383 | 1 :zero-page 384 | 1 :zero-page-x 385 | 2 :absolute 386 | 2 :absolute-x]) 387 | 388 | (check-zero-flag-sets #(-rol %1 accumulator)) 389 | (check-zero-flag-unsets #(-rol (assoc %1 :a 0x40) accumulator)) 390 | 391 | (check-negative-flag-sets #(-rol (assoc %1 :a 0x40) accumulator)) 392 | (check-negative-flag-unsets #(-rol (assoc %1 :a 1) accumulator)) 393 | 394 | (check-carry-flag-sets #(-rol (assoc %1 :a 0x80) accumulator)) 395 | (check-carry-flag-unsets #(-rol (assoc %1 :a 1) accumulator)) 396 | 397 | (it "should set bit 0 of the result if the carry flag is set" 398 | (let [cpu-rotated (-> cpu-with-carry 399 | (assoc :a 0x80) 400 | (-rol accumulator))] 401 | (should= 1 (:a cpu-rotated)))) 402 | 403 | (it "should shift the bits of the address mode left by 1" 404 | (let [cpu-rotated (-> cpu 405 | (assoc :a 0x82) 406 | (-rol accumulator))] 407 | (should= 4 (:a cpu-rotated))))) 408 | 409 | (describe "lsr" 410 | (check-pc-increments cpu -lsr [0 :accumulator 411 | 1 :zero-page 412 | 1 :zero-page-x 413 | 2 :absolute 414 | 2 :absolute-x]) 415 | 416 | (check-zero-flag-sets #(-lsr %1 accumulator)) 417 | (check-zero-flag-unsets #(-lsr (assoc %1 :a 0x80) accumulator)) 418 | 419 | (check-negative-flag-unsets #(-lsr (assoc %1 :a 1) accumulator)) 420 | 421 | (check-carry-flag-sets #(-lsr (assoc %1 :a 1) accumulator)) 422 | (check-carry-flag-unsets #(-lsr (assoc %1 :a 0x80) accumulator)) 423 | 424 | (it "should shift the bits of the address mode right by 1" 425 | (let [cpu-shifted (-> cpu 426 | (assoc :a 0x80) 427 | (-lsr accumulator))] 428 | (should= 0x40 (:a cpu-shifted))))) 429 | 430 | (describe "asl" 431 | (check-pc-increments cpu -asl [0 :accumulator 432 | 1 :zero-page 433 | 1 :zero-page-x 434 | 2 :absolute 435 | 2 :absolute-x]) 436 | 437 | (check-zero-flag-sets #(-asl %1 accumulator)) 438 | (check-zero-flag-unsets #(-asl (assoc %1 :a 1) accumulator)) 439 | 440 | (check-negative-flag-sets #(-asl (assoc %1 :a 0x40) accumulator)) 441 | (check-negative-flag-unsets #(-asl (assoc %1 :a 1) accumulator)) 442 | 443 | (check-carry-flag-sets #(-asl (assoc %1 :a 0x80) accumulator)) 444 | (check-carry-flag-unsets #(-asl (assoc %1 :a 1) accumulator)) 445 | 446 | (it "should shift the bits of the address mode left by 1" 447 | (let [cpu-shifted (-> cpu 448 | (assoc :a 1) 449 | (-asl accumulator))] 450 | (should= 2 (:a cpu-shifted)))))) 451 | 452 | (describe "system functions" 453 | (describe "brk" 454 | (it "should set the program counter to the value at 0xfffe (the IRQ/BRK vector)" 455 | (let [[_ cpu-with-vector] (io-> cpu 456 | (io-write 0xff 0xffff) 457 | (io-write 0xee 0xfffe)) 458 | new-cpu (-brk cpu-with-vector implied)] 459 | (should= 0xffee (:pc new-cpu)))) 460 | 461 | (it "should push the current program counter (plus 1) to the stack" 462 | (let [new-cpu (-brk (assoc cpu :pc 0xbeef) implied) 463 | low (peek-stack-n new-cpu 1) 464 | high (peek-stack-n new-cpu 2)] 465 | (should= 0xbe high) 466 | (should= 0xf0 low))) 467 | 468 | (it "should push processor flags to the stack with the interrupt flag set" 469 | (let [new-cpu (-brk (assoc cpu :p 0) implied) 470 | stack-top (peek-stack new-cpu)] 471 | (should= 0x10 stack-top)))) 472 | 473 | (describe "nop" 474 | (it "should do nothing" 475 | (should= cpu (-nop cpu implied))))) 476 | 477 | (describe "status flag changes" 478 | (describe "sei" 479 | (it "should set the interrupt flag" 480 | (should= true (interrupt-flag? (-sei cpu implied))))) 481 | 482 | (describe "sed" 483 | (it "should set the decimal flag" 484 | (should= true (decimal-flag? (-sed cpu implied))))) 485 | 486 | (describe "sec" 487 | (it "should set the carry flag" 488 | (should= true (carry-flag? (-sec cpu implied))))) 489 | 490 | (describe "clv" 491 | (it "should clear the overflow flag" 492 | (should= false (overflow-flag? (-clv cpu-with-overflow implied))))) 493 | 494 | (describe "cli" 495 | (it "should clear the interrupt flag" 496 | (should= false (interrupt-flag? (-cli cpu-with-interrupt implied))))) 497 | 498 | (describe "cld" 499 | (it "should clear the decimal flag" 500 | (should= false (decimal-flag? (-cld cpu-with-decimal implied))))) 501 | 502 | (describe "clc" 503 | (it "should clear the carry flag" 504 | (should= false (carry-flag? (-clc cpu-with-carry implied)))))) 505 | 506 | (describe "branching" 507 | (describe "bvs" 508 | (check-branching "should branch when overflow set" 509 | -bvs 510 | cpu-with-overflow 511 | cpu)) 512 | (describe "bvc" 513 | (check-branching "should branch when overflow clear" 514 | -bvc 515 | cpu 516 | cpu-with-overflow)) 517 | (describe "bpl" 518 | (check-branching "should branch when negative clear" 519 | -bpl 520 | cpu 521 | cpu-with-negative)) 522 | (describe "bne" 523 | (check-branching "should branch when zero clear" 524 | -bne 525 | cpu 526 | cpu-with-zero)) 527 | (describe "bmi" 528 | (check-branching "should branch when negative set" 529 | -bmi 530 | cpu-with-negative 531 | cpu)) 532 | (describe "beq" 533 | (check-branching "should branch when zero set" 534 | -beq 535 | cpu-with-zero 536 | cpu)) 537 | (describe "bcs" 538 | (check-branching "should branch when carry set" 539 | -bcs 540 | cpu-with-carry 541 | cpu)) 542 | (describe "bcc" 543 | (check-branching "should branch when carry clear" 544 | -bcc 545 | cpu 546 | cpu-with-carry))) 547 | 548 | (describe "jumps and calls" 549 | (describe "rts" 550 | (it "should pull the program counter from the stack and then add one to it" 551 | (let [cpu-with-pc (-> cpu 552 | (stack-push 0xff) 553 | (stack-push 0xdd)) 554 | new-cpu (-rts cpu-with-pc implied)] 555 | (should= 0xffde (:pc new-cpu))))) 556 | 557 | (describe "rti" 558 | (it "should pull the program counter from the stack after pulling flags" 559 | (let [cpu-with-p-and-pc (-> cpu 560 | (stack-push 0xff) 561 | (stack-push 0xdd) 562 | (stack-push 0)) 563 | new-cpu (-rti cpu-with-p-and-pc implied)] 564 | (should= 0xffdd (:pc new-cpu)))) 565 | 566 | (it "should pull the flags from the top of the stack (break flag is always 0)" 567 | (let [new-cpu (-rti (with-stack-top cpu 0xff) implied)] 568 | (should= 0xef (:p new-cpu))))) 569 | 570 | (describe "jsr" 571 | (it "should set the program counter to the operand" 572 | (let [with-jsr-addr (second (io-> cpu 573 | (io-write-word 0xbeef 0))) 574 | new-cpu (-jsr with-jsr-addr absolute)] 575 | (should= 0xbeef (:pc new-cpu)))) 576 | 577 | (it "should push the return point of the function call (the next instruction after the jump) to the stack" 578 | (let [new-cpu (-jsr (assoc cpu :pc 0xffdd) absolute)] 579 | (should= 0xde (peek-stack-n new-cpu 0)) 580 | (should= 0xff (peek-stack-n new-cpu 1))))) 581 | 582 | (describe "jmp" 583 | (it "should set the program counter to the word at read($xx00) | read($xxff) 584 | if the address mode is indirect and the pointer points to the end of the page" 585 | (let [with-jmp-addr (second (io-> cpu 586 | (io-write-word 0x00ff 1) 587 | (io-write 0xef 0xff) 588 | (io-write 0xbe 0))) 589 | new-cpu (-jmp (assoc with-jmp-addr :pc 1) indirect)] 590 | (should= 0xbeef (:pc new-cpu)))) 591 | 592 | (it "should set the program counter to the word at the pointer" 593 | (let [with-jmp-addr (second (io-> cpu 594 | (io-write-word 0x1000 0))) 595 | new-cpu (-jmp with-jmp-addr absolute)] 596 | (should= 0x1000 (:pc new-cpu)))))) 597 | 598 | (describe "stack operations" 599 | (describe "stack-push" 600 | (it "should wrap the stack pointer to 0x1ff when it's 0" 601 | (let [new-cpu (stack-push (assoc cpu :sp 0) 0)] 602 | (should= 0xff (:sp new-cpu))))) 603 | 604 | (describe "stack-pull" 605 | (it "should pull from 0x0100 when the stack pointer is 0xff" 606 | (let [[_ new-cpu] (io-> cpu 607 | (io-write 0xdd 0x100)) 608 | cpu-with-sp-ff (assoc new-cpu :sp 0xff) 609 | [result after-pull] (stack-pull cpu-with-sp-ff)] 610 | (should= 0xdd result) 611 | (should= 0 (:sp after-pull))))) 612 | 613 | (describe "plp" 614 | (it "should pull the 5th bit as 1, no matter what" 615 | (let [new-cpu (-plp (with-stack-top cpu 0x00) implied)] 616 | (should= 0x20 (:p new-cpu)))) 617 | 618 | (it "should pull the break flag as 0, no matter what" 619 | (let [new-cpu (-plp (with-stack-top cpu 0xff) implied)] 620 | (should= 0xef (:p new-cpu)))) 621 | 622 | (it "should pull the top of the stack into the flags register" 623 | (let [new-cpu (-plp (with-stack-top cpu 0x21) implied)] 624 | (should= 0x21 (:p new-cpu))))) 625 | 626 | (describe "pla" 627 | (check-zero-flag-sets #(-pla (with-stack-top % 0x00) implied)) 628 | (check-zero-flag-unsets #(-pla (with-stack-top % 0x01) implied)) 629 | (check-negative-flag-sets #(-pla (with-stack-top % 0x80) implied)) 630 | (check-negative-flag-unsets #(-pla (with-stack-top % 0x00) implied)) 631 | 632 | (it "should pull the top of the stack into the accumulator" 633 | (let [new-cpu (-pla (with-stack-top cpu 0xff) implied)] 634 | (should= 0xff (:a new-cpu))))) 635 | 636 | (describe "php" 637 | (it "should always push the break flag as 1" 638 | ;; NOTE: This is only in the NES's 6502... should there be a way of 639 | ;; setting it so that the CPU can behave either way? 640 | (let [new-cpu (-php (assoc cpu :p 0) implied) 641 | stack-top (peek-stack new-cpu)] 642 | (should= 0 (:p new-cpu)) 643 | (should= break-flag stack-top))) 644 | 645 | (it "should push processor flags to the stack" 646 | (let [new-cpu (-php cpu-with-carry implied) 647 | stack-top (peek-stack new-cpu)] 648 | (should= (bit-or carry-flag break-flag) stack-top)))) 649 | 650 | (describe "pha" 651 | (it "should decrement the stack pointer" 652 | (let [new-cpu (-pha (assoc cpu :a 0xbe) implied) 653 | new-sp (:sp new-cpu)] 654 | (should= (dec (:sp cpu)) (:sp new-cpu)))) 655 | 656 | (it "should push the accumulator to the stack" 657 | (let [new-cpu (-pha (assoc cpu :a 0xbe) implied) 658 | stack-top (peek-stack new-cpu)] 659 | (should= 0xbe stack-top))))) 660 | 661 | (describe "decrement operations" 662 | (describe "dec" 663 | (check-pc-increments cpu -dec [1 :zero-page 664 | 1 :zero-page-x 665 | 2 :absolute 666 | 2 :absolute-x]) 667 | 668 | (check-zero-flag-sets #(-dec (second (io-> %1 (io-write 1 0))) immediate)) 669 | (check-zero-flag-unsets #(-dec %1 immediate)) 670 | (check-negative-flag-sets #(-dec %1 immediate)) 671 | (check-negative-flag-unsets #(-dec (second (io-> %1 (io-write 1 0))) immediate)) 672 | 673 | (it "should decrement the value at the address mode by one" 674 | (let [new-cpu (-dec cpu immediate)] 675 | (should= 0xff (first (io-> new-cpu 676 | (io-read 0))))))) 677 | 678 | (map (fn [[op reg]] 679 | (describe (str op) 680 | (check-zero-flag-sets #(op (assoc %1 reg 1) implied)) 681 | (check-zero-flag-unsets #(op (assoc %1 reg 2) implied)) 682 | (check-negative-flag-sets #(op (assoc %1 reg 0) implied)) 683 | (check-negative-flag-unsets #(op (assoc %1 reg 1) implied)) 684 | 685 | (it (format "should decrement the %s register by one" (str reg)) 686 | (let [new-cpu (op cpu implied)] 687 | (should= 0xff (reg new-cpu)))))) 688 | {-dex :x 689 | -dey :y})) 690 | 691 | (describe "increment operations" 692 | (describe "inc" 693 | (check-pc-increments cpu -inc [1 :zero-page 694 | 1 :zero-page-x 695 | 2 :absolute 696 | 2 :absolute-x]) 697 | 698 | (check-zero-flag-sets #(-inc (second (io-> %1 (io-write 0xff 0))) immediate)) 699 | (check-zero-flag-unsets #(-inc %1 immediate)) 700 | (check-negative-flag-sets #(-inc (second (io-> %1 (io-write 0x7f 0))) immediate)) 701 | (check-negative-flag-unsets #(-inc %1 immediate)) 702 | 703 | (it "should increment the value at the address mode by one" 704 | (let [new-cpu (-inc cpu immediate)] 705 | (should= 1 (first (io-> new-cpu 706 | (io-read 0))))))) 707 | 708 | (map (fn [[op reg]] 709 | (describe (str op) 710 | (check-zero-flag-sets #(op (assoc %1 reg 0xff) implied)) 711 | (check-zero-flag-unsets #(op (assoc %1 reg 0) implied)) 712 | (check-negative-flag-sets #(op (assoc %1 reg 0x7f) implied)) 713 | (check-negative-flag-unsets #(op (assoc %1 reg 0) implied)) 714 | 715 | (it (format "should increment the %s register by one" (str reg)) 716 | (let [new-cpu (op cpu implied)] 717 | (should= 1 (reg new-cpu)))))) 718 | {-inx :x 719 | -iny :y})) 720 | 721 | (describe "register transfer operations" 722 | (describe "txs" 723 | (it "should transfer the value in the x register to the sp register" 724 | (let [new-cpu (-txs (assoc cpu :x 0x33) implied)] 725 | (should= 0x33 (:sp new-cpu))))) 726 | 727 | (map (fn [[op [from-reg to-reg]]] 728 | (describe (str op) 729 | (check-zero-flag-sets #(op (assoc %1 from-reg 0) implied)) 730 | (check-zero-flag-unsets #(op (assoc %1 from-reg 1) implied)) 731 | (check-negative-flag-sets #(op (assoc %1 from-reg 0x80) implied)) 732 | (check-negative-flag-unsets #(op (assoc %1 from-reg 0) implied)) 733 | 734 | (it (format "should transfer the value in the %s register to the %s register" (str from-reg) (str to-reg)) 735 | (let [new-cpu (op (assoc cpu from-reg 0x44) implied)] 736 | (should= (to-reg new-cpu) 0x44))))) 737 | {-tax [:a :x] 738 | -tay [:a :y] 739 | -txa [:x :a] 740 | -tya [:y :a] 741 | -tsx [:sp :x]})) 742 | 743 | (describe "loading operations" 744 | (for [op [-lda -ldx -ldy]] 745 | (describe (str op) 746 | (check-zero-flag-sets #(op %1 immediate)) 747 | (check-zero-flag-unsets #(op (imm-n %1 1) immediate)) 748 | (check-negative-flag-sets #(op (imm-n %1 0x80) immediate)) 749 | (check-negative-flag-unsets #(op %1 immediate)))) 750 | 751 | (describe "ldy" 752 | (check-pc-increments cpu -ldy [1 :immediate 753 | 1 :zero-page 754 | 1 :zero-page-x 755 | 2 :absolute 756 | 2 :absolute-x]) 757 | 758 | (it "should load the y register with the argument" 759 | (let [new-cpu (-ldy (imm-n cpu 0xbb) immediate)] 760 | (should= (:y new-cpu) 0xbb)))) 761 | 762 | (describe "ldx" 763 | (check-pc-increments cpu -ldx [1 :immediate 764 | 1 :zero-page 765 | 1 :zero-page-y 766 | 2 :absolute 767 | 2 :absolute-x]) 768 | 769 | (it "should load the x register with the argument" 770 | (let [new-cpu (-ldx (imm-n cpu 0xbb) immediate)] 771 | (should= (:x new-cpu) 0xbb)))) 772 | 773 | (describe "lda" 774 | (check-pc-increments cpu -lda [1 :immediate 775 | 1 :zero-page 776 | 1 :zero-page-x 777 | 2 :absolute 778 | 2 :absolute-x 779 | 2 :absolute-y 780 | 1 :indexed-indirect 781 | 1 :indirect-indexed]) 782 | 783 | (it "should load the accumulator with the argument" 784 | (let [new-cpu (-lda (imm-n cpu 0xbb) immediate)] 785 | (should= (:a new-cpu) 0xbb))))) 786 | 787 | (describe "comparison operations" 788 | (def cpu-with-imm-1 (second (io-> cpu 789 | (io-write 1 0)))) 790 | 791 | (check-pc-increments cpu -cmp [1 :immediate 792 | 1 :zero-page 793 | 1 :zero-page-x 794 | 2 :absolute 795 | 2 :absolute-x 796 | 2 :absolute-y 797 | 1 :indexed-indirect 798 | 1 :indirect-indexed]) 799 | 800 | (check-pc-increments cpu -cpx [1 :immediate 801 | 1 :zero-page 802 | 2 :absolute]) 803 | 804 | (check-pc-increments cpu -cpy [1 :immediate 805 | 1 :zero-page 806 | 2 :absolute]) 807 | 808 | (map (fn [[op reg]] 809 | (describe (str op) 810 | (check-zero-flag-sets #(op %1 immediate)) 811 | (check-zero-flag-unsets #(op (assoc %1 reg 1) immediate)) 812 | (check-negative-flag-sets (fn [c] 813 | (op (assoc c reg 0x81) 814 | immediate))) 815 | (check-negative-flag-unsets #(op %1 immediate)) 816 | 817 | (it (format "should set the carry flag if the %s register is greater than or equal to the operand" (str reg)) 818 | (let [new-cpu (op (assoc cpu-with-imm-1 reg 0x10) immediate)] 819 | (should (carry-flag? new-cpu)))) 820 | 821 | (it (format "should unset the carry flag if the %s register is less than the operand" (str reg)) 822 | (let [cpu-with-carry (set-flag cpu-with-imm-1 overflow-flag true) 823 | new-cpu (op cpu-with-carry immediate)] 824 | (should-not (carry-flag? new-cpu)))))) 825 | {-cmp :a 826 | -cpx :x 827 | -cpy :y})) 828 | 829 | (describe "logical operations" 830 | (describe "bit" 831 | (check-pc-increments cpu -bit [1 :zero-page 832 | 2 :absolute]) 833 | 834 | (check-zero-flag-sets #(-bit %1 immediate)) 835 | (check-zero-flag-unsets #(-bit (imm-n (assoc %1 :a 1) 1) immediate)) 836 | (check-negative-flag-sets #(-bit (imm-n (assoc %1 :a 0) 0x80) immediate)) 837 | (check-negative-flag-unsets #(-bit %1 immediate)) 838 | 839 | (it "should set the overflow flag when the 6th bit of the operand is set" 840 | (let [new-cpu (-bit (imm-n (assoc cpu :a 0) 0x40) immediate)] 841 | (should (overflow-flag? new-cpu)))) 842 | 843 | (it "should unset the overflow flag when the 6th bit of the operand is unset" 844 | (let [new-cpu (-bit (set-flag cpu overflow-flag true) immediate)] 845 | (should-not (overflow-flag? new-cpu))))) 846 | 847 | (map (fn [o] 848 | (check-pc-increments cpu o [1 :immediate 849 | 1 :zero-page 850 | 1 :zero-page-x 851 | 2 :absolute 852 | 2 :absolute-x 853 | 2 :absolute-y 854 | 1 :indexed-indirect 855 | 1 :indirect-indexed])) 856 | [-eor -ora -and]) 857 | 858 | (describe "eor" 859 | (check-zero-flag-sets #(-eor %1 immediate)) 860 | (check-zero-flag-unsets #(-eor (assoc %1 :a 1) immediate)) 861 | (check-negative-flag-sets #(-eor (assoc %1 :a 0x80) immediate)) 862 | (check-negative-flag-unsets #(-eor %1 immediate))) 863 | 864 | (describe "ora" 865 | (check-zero-flag-sets #(-ora %1 immediate)) 866 | (check-zero-flag-unsets #(-ora (imm-n (assoc %1 :a 1) 1) immediate)) 867 | (check-negative-flag-sets #(-ora (imm-n (assoc %1 :a 0x80) 0x80) immediate)) 868 | (check-negative-flag-unsets #(-ora %1 immediate)) 869 | 870 | (it "should or the argument with the accumulator" 871 | (let [new-cpu (-ora (imm-n cpu 0xa5) immediate)] 872 | (should= (:a new-cpu) 0xa5)))) 873 | 874 | (describe "and" 875 | (check-zero-flag-sets #(-and %1 immediate)) 876 | (check-zero-flag-unsets #(-and (imm-n (assoc %1 :a 1) 1) immediate)) 877 | (check-negative-flag-sets #(-and (imm-n (assoc %1 :a 0x80) 0x80) immediate)) 878 | (check-negative-flag-unsets #(-and %1 immediate)) 879 | 880 | (it "should and the argument with the accumulator" 881 | (let [new-cpu (-and (imm-n (assoc cpu :a 0xff) 0xa5) immediate)] 882 | (should= (:a new-cpu) 0xa5))))) 883 | 884 | (describe "sbc" 885 | (check-pc-increments cpu -sbc [1 :immediate 886 | 1 :zero-page 887 | 1 :zero-page-x 888 | 2 :absolute 889 | 2 :absolute-x 890 | 2 :absolute-y 891 | 1 :indexed-indirect 892 | 1 :indirect-indexed]) 893 | 894 | (check-zero-flag-sets #(-sbc (assoc %1 :a 1) immediate)) 895 | (check-zero-flag-unsets #(-sbc (imm-n %1 1) immediate)) 896 | (check-negative-flag-sets #(-sbc %1 immediate)) 897 | (check-negative-flag-unsets #(-sbc (imm-n %1 0xff) immediate)) 898 | 899 | (it "should set the carry flag when the result is equal to the old accumulator" 900 | (let [new-cpu (-sbc (imm-n (assoc cpu-with-carry :a 0x40) 0x40) immediate)] 901 | (should (carry-flag? new-cpu)))) 902 | 903 | (it "should set the carry flag when the result is an unsigned underflow" 904 | (let [new-cpu (-sbc (imm-n (assoc cpu :a 1) 0) immediate)] 905 | (should (carry-flag? new-cpu)))) 906 | 907 | (it "should unset the carry flag when the result is not an unsigned underflow" 908 | (let [cpu-with-carry (assoc cpu :a 0) 909 | new-cpu (-sbc cpu-with-carry immediate)] 910 | (should-not (carry-flag? new-cpu)))) 911 | 912 | (it "should set the overflow flag when subtracting a negative from a positive yields a negative" 913 | (let [cpu-with-carry (set-flag cpu carry-flag true) 914 | new-cpu (-sbc (imm-n cpu-with-carry 0x80) immediate)] 915 | (should (overflow-flag? new-cpu)))) 916 | 917 | (it "should set the overflow flag when subtracting a positive from a negative yields a positive" 918 | (let [new-cpu (-sbc (imm-n (assoc cpu :a 0x80) 0x0f) immediate)] 919 | (should (overflow-flag? new-cpu)))) 920 | 921 | (context "when the carry flag is clear" 922 | (it "should subtract the argument and an additional 1 from the accumulator" 923 | (let [new-cpu (-sbc (assoc cpu :a 0xff) immediate)] 924 | (should= (:a new-cpu) 0xfe)))) 925 | 926 | (context "when the carry flag is set" 927 | (it "should subtract the argument from the accumulator" 928 | (let [new-cpu (-sbc (imm-n (assoc cpu-with-carry :a 0xff) 1) immediate)] 929 | (should= (:a new-cpu) 0xfe))) 930 | 931 | (it "should overflow if the subtraction would be less than 0" 932 | (let [new-cpu (-sbc (imm-n cpu-with-carry 1) immediate)] 933 | (should= (:a new-cpu) 0xff))))) 934 | 935 | (describe "adc" 936 | (check-pc-increments cpu -adc [1 :immediate 937 | 1 :zero-page 938 | 1 :zero-page-x 939 | 2 :absolute 940 | 2 :absolute-x 941 | 2 :absolute-y 942 | 1 :indexed-indirect 943 | 1 :indirect-indexed]) 944 | 945 | (it "should overflow if the addition would exceed 0xff" 946 | (let [new-cpu (-adc (assoc (imm-n cpu 1) :a 0xff) immediate)] 947 | (should= (:a new-cpu) 0))) 948 | 949 | (it "should set the carry flag when the result is an unsigned overflow" 950 | (let [new-cpu (-adc (assoc (imm-n cpu 1) :a 0xff) immediate)] 951 | (should (carry-flag? new-cpu)))) 952 | 953 | (it "should unset the carry flag when the result isn't an unsigned overflow" 954 | (let [new-cpu (-adc (set-flag (imm-n cpu 1) carry-flag true) immediate)] 955 | (should-not (carry-flag? new-cpu)))) 956 | 957 | (check-zero-flag-sets #(-adc (imm-n %1 0) immediate)) 958 | (check-zero-flag-unsets #(-adc (imm-n %1 1) immediate)) 959 | (check-negative-flag-sets #(-adc (imm-n %1 0x80) immediate)) 960 | (check-negative-flag-unsets #(-adc (imm-n %1 0) immediate)) 961 | 962 | (it "should set the overflow flag when adding two positives yields a negative" 963 | (let [cpu (merge cpu {:a 0x79}) 964 | new-cpu (-adc (imm-n cpu 0x79) immediate)] 965 | (should (overflow-flag? new-cpu)))) 966 | 967 | (it "should set the overflow flag when adding two negatives yields a positive" 968 | (let [cpu (merge cpu {:a 0x80}) 969 | new-cpu (-adc (imm-n cpu 0x80) immediate)] 970 | (should (overflow-flag? new-cpu)))) 971 | 972 | (context "when the carry flag is clear" 973 | (it "should add the argument to the accumulator" 974 | (let [new-cpu (-adc (imm-n cpu 1) immediate)] 975 | (should= (:a new-cpu) 1)))) 976 | 977 | (context "when the carry flag is set" 978 | (it "should add an additional 1 to the result" 979 | (let [new-cpu (-adc cpu-with-carry immediate)] 980 | (should= (:a new-cpu) 1))) 981 | 982 | (it "should unset the carry flag" 983 | (let [new-cpu (-adc (imm-n cpu-with-carry 1) immediate)] 984 | (should-not (carry-flag? new-cpu)))))))) 985 | --------------------------------------------------------------------------------