Mercurial > vba-clojure

annotate clojure/com/aurellem/gb_driver.clj @ 104:d2e00ea31508

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
checking in continue!, which let's the GB run for an unlimited time.
author Robert McIntyre <rlm@mit.edu>
date Tue, 13 Mar 2012 00:03:02 -0500
parents 37711ff4a7bc
children 2f8089eacab9
rev   line source
rlm@60 1 (ns com.aurellem.gb-driver
rlm@87 2 (:import com.aurellem.gb.Gb)
rlm@87 3 (:import java.io.File)
rlm@87 4 (:import org.apache.commons.io.FileUtils)
rlm@87 5 (:import (java.nio IntBuffer ByteOrder)))
rlm@48 6
rlm@87 7 ;; Savestates
rlm@87 8 (defrecord SaveState [frame data])
rlm@76 9
rlm@76 10 (def ^:dynamic *save-state-cache*
rlm@76 11 (File. "/home/r/proj/pokemon-escape/save-states/"))
rlm@76 12
rlm@87 13 (defn frame->filename [frame]
rlm@87 14 (File. *save-state-cache* (format "%07d.sav" frame)))
rlm@87 15
rlm@88 16 (defn write-state! [^SaveState save]
rlm@87 17 (let [buf (:data save)
rlm@87 18 bytes (byte-array (.limit buf))
rlm@87 19 dest (frame->filename (:frame save))]
rlm@87 20 (.get buf bytes)
rlm@87 21 (FileUtils/writeByteArrayToFile dest bytes)
rlm@87 22 (.rewind buf)
rlm@88 23 dest))
rlm@87 24
rlm@88 25 (defn read-state [frame]
rlm@87 26 (let [save (frame->filename frame)]
rlm@87 27 (if (.exists save)
rlm@87 28 (let [buf (Gb/saveBuffer)
rlm@87 29 bytes (FileUtils/readFileToByteArray save)]
rlm@87 30 (.put buf bytes)
rlm@87 31 (.flip buf)
rlm@87 32 (SaveState. frame buf)))))
rlm@87 33 ;;;;;;;;;;;;;;;;
rlm@87 34
rlm@87 35 ;; Gameboy management
rlm@87 36 (Gb/loadVBA)
rlm@87 37
rlm@65 38 (def yellow-rom-image
rlm@65 39 (File. "/home/r/proj/pokemon-escape/roms/yellow.gbc"))
rlm@65 40
rlm@67 41 (def yellow-save-file
rlm@67 42 (File. "/home/r/proj/pokemon-escape/roms/yellow.sav"))
rlm@67 43
rlm@87 44 (def on? (atom nil))
rlm@73 45
rlm@87 46 (defn shutdown! [] (Gb/shutdown) (reset! on? false))
rlm@87 47
rlm@87 48 (defn restart! []
rlm@87 49 (shutdown!)
rlm@67 50 (.delete yellow-save-file)
rlm@87 51 (Gb/startEmulator (.getCanonicalPath yellow-rom-image))
rlm@87 52 (reset! on? true))
rlm@60 53
rlm@87 54 ;;; The first state!
rlm@87 55 (defn gen-root! []
rlm@87 56 (restart!)
rlm@88 57 (let [state (SaveState. 0 (Gb/saveState))]
rlm@88 58 (write-state! state)
rlm@88 59 state))
rlm@71 60
rlm@87 61 (defn root []
rlm@87 62 (if (.exists (frame->filename 0))
rlm@88 63 (read-state 0)
rlm@87 64 (gen-root!)))
rlm@87 65
rlm@87 66 ;;;; Press Buttons
rlm@87 67
rlm@87 68 (def button-code
rlm@87 69 {;; main buttons
rlm@87 70 :a 0x0001
rlm@87 71 :b 0x0002
rlm@87 72
rlm@87 73 ;; directional pad
rlm@87 74 :r 0x0010
rlm@87 75 :l 0x0020
rlm@87 76 :u 0x0040
rlm@87 77 :d 0x0080
rlm@87 78
rlm@87 79 ;; meta buttons
rlm@87 80 :select 0x0004
rlm@87 81 :start 0x0008
rlm@87 82
rlm@87 83 ;; pseudo-buttons
rlm@87 84 :restart 0x0800 ; hard reset
rlm@87 85 :listen -1 ; listen for user input
rlm@87 86 })
rlm@87 87
rlm@87 88 (defn button-mask [buttons]
rlm@87 89 (reduce bit-or 0x0000 (map button-code buttons)))
rlm@87 90
rlm@87 91 (def current-state (atom nil))
rlm@87 92
rlm@87 93 (defn set-state! [^SaveState state]
rlm@87 94 (assert (:data state) "Not a valid state!")
rlm@87 95 (if (not @on?) (restart!))
rlm@87 96 (if (not= @current-state state)
rlm@87 97 (Gb/loadState (:data state)))
rlm@87 98 (reset! current-state state))
rlm@87 99
rlm@87 100 (defrecord Move [keys state])
rlm@87 101
rlm@99 102 (defn update-state []
rlm@99 103 (reset! current-state
rlm@99 104 (SaveState. (:frame @current-state)
rlm@99 105 (Gb/saveState))))
rlm@99 106
rlm@87 107 (defn step
rlm@87 108 ([^SaveState state buttons]
rlm@87 109 (set-state! state)
rlm@87 110 (Gb/step (button-mask buttons))
rlm@87 111 (reset! current-state
rlm@87 112 (SaveState. (inc (:frame state))(Gb/saveState))))
rlm@87 113 ([^SaveState state]
rlm@87 114 (step state [:listen]))
rlm@87 115 ([] (step (if @current-state @current-state (root)))))
rlm@87 116
rlm@100 117 (defn tick
rlm@100 118 ([] (tick @current-state))
rlm@100 119 ([state]
rlm@100 120 (set-state! state)
rlm@100 121 (Gb/tick)
rlm@100 122 (update-state)))
rlm@100 123
rlm@87 124 (defn move
rlm@87 125 [^Move move buttons]
rlm@87 126 (Move. (step (:state move) buttons) buttons))
rlm@87 127
rlm@87 128 (defn play
rlm@87 129 ([^SaveState state n]
rlm@87 130 (reduce (fn [s _] (step s)) state (range n)))
rlm@87 131 ([n]
rlm@87 132 (play @current-state n)))
rlm@87 133
rlm@104 134 (defn continue! []
rlm@104 135 (play @current-state Integer/MAX_VALUE))
rlm@104 136
rlm@87 137 (defn play-moves
rlm@87 138 ([moves [prev state]]
rlm@87 139 (set-state! state)
rlm@87 140 (dorun (map (fn [move] (step @current-state move)) moves))
rlm@87 141 [(concat prev moves) @current-state]))
rlm@87 142
rlm@87 143 ;;;;;;;;;;;
rlm@87 144
rlm@87 145
rlm@87 146 ;;;;;;;;;;;;;;; CPU data
rlm@87 147
rlm@64 148 (defn cpu-data [size arr-fn]
rlm@64 149 (let [store (int-array size)]
rlm@94 150 (fn get-data
rlm@94 151 ([] (get-data @current-state))
rlm@94 152 ([state]
rlm@94 153 (set-state! state) (arr-fn store) store))))
rlm@60 154
rlm@100 155 (defn write-cpu-data [size store-fn]
rlm@100 156 (fn [new-data]
rlm@100 157 (let [store (int-array new-data)]
rlm@100 158 (assert (= size (count new-data)))
rlm@100 159 (store-fn store))))
rlm@100 160
rlm@93 161 (def memory
rlm@94 162 (cpu-data Gb/GB_MEMORY #(Gb/getMemory %)))
rlm@93 163
rlm@64 164 (def ram
rlm@93 165 (cpu-data Gb/RAM_SIZE #(Gb/getRAM %)))
rlm@61 166
rlm@64 167 (def rom
rlm@93 168 (cpu-data Gb/ROM_SIZE #(Gb/getROM %)))
rlm@61 169
rlm@64 170 (def working-ram
rlm@64 171 (cpu-data Gb/WRAM_SIZE #(Gb/getWRAM %)))
rlm@62 172
rlm@64 173 (def video-ram
rlm@64 174 (cpu-data Gb/VRAM_SIZE #(Gb/getVRAM %)))
rlm@64 175
rlm@64 176 (def registers
rlm@64 177 (cpu-data Gb/NUM_REGISTERS #(Gb/getRegisters %)))
rlm@64 178
rlm@100 179 (def write-memory!
rlm@100 180 (write-cpu-data Gb/GB_MEMORY #(Gb/writeMemory %)))
rlm@96 181
rlm@100 182 (def write-registers!
rlm@100 183 (write-cpu-data Gb/NUM_REGISTERS #(Gb/writeRegisters %)))
rlm@100 184
rlm@101 185 ;;;;; Registers ;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@71 186
rlm@100 187 (defmacro gen-get-set-register [name index]
rlm@100 188 (let [name-bang (symbol (str name "!"))]
rlm@100 189 `(do
rlm@100 190 (defn ~name
rlm@100 191 ~(str "Retrieve the " name " register from state, or "
rlm@100 192 "from @current-state if state is absent.")
rlm@100 193 ([state#]
rlm@100 194 (nth (registers state#) ~index))
rlm@100 195 ([]
rlm@100 196 (~name @current-state)))
rlm@100 197 (defn ~name-bang
rlm@100 198 ~(str "Set the " name " register for state, or "
rlm@100 199 "for @current-state if state is absent.")
rlm@100 200 ([state# new-register#]
rlm@100 201 (set-state! state#)
rlm@100 202 (let [registers# (registers state#)]
rlm@100 203 (aset registers# ~index new-register#)
rlm@100 204 (Gb/writeRegisters registers#)
rlm@100 205 (update-state)))
rlm@100 206 ([new-register#]
rlm@100 207 (~name-bang @current-state new-register#))))))
rlm@71 208
rlm@101 209 ;; 16 bit registers
rlm@100 210 (gen-get-set-register PC 0)
rlm@100 211 (gen-get-set-register SP 1)
rlm@100 212 (gen-get-set-register AF 2)
rlm@100 213 (gen-get-set-register BC 3)
rlm@100 214 (gen-get-set-register DE 4)
rlm@100 215 (gen-get-set-register HL 5)
rlm@100 216 (gen-get-set-register IFF 6)
rlm@100 217
rlm@101 218 ;; 8 bit registers
rlm@101 219 (gen-get-set-register DIV 7)
rlm@101 220 (gen-get-set-register TIMA 8)
rlm@101 221 (gen-get-set-register TMA 9)
rlm@101 222 (gen-get-set-register IF 11)
rlm@101 223 (gen-get-set-register LCDC 12)
rlm@101 224 (gen-get-set-register STAT 13)
rlm@101 225 (gen-get-set-register SCY 14)
rlm@101 226 (gen-get-set-register SCX 15)
rlm@101 227 (gen-get-set-register LY 16)
rlm@101 228 (gen-get-set-register DMA 18)
rlm@101 229 (gen-get-set-register WY 19)
rlm@101 230 (gen-get-set-register WX 20)
rlm@101 231 (gen-get-set-register VBK 21)
rlm@101 232 (gen-get-set-register HDMA1 22)
rlm@101 233 (gen-get-set-register HDMA2 23)
rlm@101 234 (gen-get-set-register HDMA3 24)
rlm@101 235 (gen-get-set-register HDMA4 25)
rlm@101 236 (gen-get-set-register HDMA5 26)
rlm@101 237 (gen-get-set-register SVBK 27)
rlm@101 238 (gen-get-set-register IE 28)
rlm@101 239
rlm@87 240 ;;;;;;;;;;;;;;;
rlm@71 241
rlm@87 242 (defmacro defn-memo
rlm@87 243 [& forms]
rlm@87 244 (let [fun-name (first forms)]
rlm@87 245 `(do
rlm@87 246 (defn ~@forms)
rlm@87 247 (alter-var-root (var ~fun-name) memoize))))
rlm@95 248