Mercurial > vba-clojure

annotate clojure/com/aurellem/gb/gb_driver.clj @ 524:7ef5c73ea8fa

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
working on recording sound. almost have it, but there is still unexplained popping sounds.
author Robert McIntyre <rlm@mit.edu>
date Sat, 23 Jun 2012 23:10:31 -0500
parents d00096b6bf17
children fa7676dbf6f2
rev   line source
rlm@145 1 (ns com.aurellem.gb.gb-driver
rlm@145 2 (:import com.aurellem.gb.Gb)
rlm@145 3 (:import java.io.File)
rlm@145 4 (:import org.apache.commons.io.FileUtils)
rlm@145 5 (:import (java.nio IntBuffer ByteOrder)))
rlm@145 6
rlm@145 7 ;; Savestates
ocsenave@227 8
rlm@145 9 (defrecord SaveState [data])
rlm@145 10
rlm@145 11 (def user-home (File. (System/getProperty "user.home")))
rlm@145 12
rlm@145 13 (def ^:dynamic *save-state-cache*
rlm@145 14 (File. user-home "proj/vba-clojure/save-states/"))
rlm@145 15
rlm@145 16 (def current-state (atom nil))
rlm@145 17
rlm@145 18 (defn state-cache-file [name]
rlm@145 19 (File. *save-state-cache* (str name ".sav")))
rlm@145 20
rlm@145 21 (defn write-state!
rlm@145 22 ([^SaveState name]
rlm@145 23 (write-state! @current-state name))
rlm@145 24 ([^SaveState save ^String name]
rlm@145 25 (let [buffer (:data save)
rlm@145 26 bytes (byte-array (.limit buffer))
rlm@145 27 dest (state-cache-file name)]
rlm@145 28 (.get buffer bytes)
rlm@145 29 (FileUtils/writeByteArrayToFile dest bytes)
rlm@145 30 (.rewind buffer)
rlm@145 31 dest)))
rlm@145 32
rlm@145 33 (defn read-state [name]
rlm@145 34 (let [save (state-cache-file name)]
rlm@154 35 (assert (.exists save))
rlm@154 36 (let [buffer (Gb/saveBuffer)
rlm@154 37 bytes (FileUtils/readFileToByteArray save)]
rlm@154 38 (.put buffer bytes)
rlm@154 39 (.flip buffer)
rlm@154 40 (SaveState. buffer))))
rlm@145 41 ;;;;;;;;;;;;;;;;
rlm@145 42
rlm@496 43
rlm@145 44 ;; Gameboy management
rlm@145 45 (Gb/loadVBA)
rlm@145 46
rlm@145 47 (def yellow-rom-image
rlm@145 48 (File. user-home "proj/pokemon-escape/roms/yellow.gbc"))
rlm@145 49
rlm@145 50 (def yellow-save-file
rlm@145 51 (File. user-home "proj/pokemon-escape/roms/yellow.sav"))
rlm@145 52
rlm@145 53 (def on? (atom nil))
rlm@145 54
rlm@145 55 (defn shutdown! [] (Gb/shutdown) (reset! on? false))
rlm@145 56
rlm@145 57 (defn restart! []
rlm@145 58 (shutdown!)
rlm@145 59 (.delete yellow-save-file)
rlm@145 60 (Gb/startEmulator (.getCanonicalPath yellow-rom-image))
rlm@145 61 (reset! on? true))
rlm@145 62
rlm@145 63 ;;; The first state!
rlm@145 64 (defn gen-root! []
rlm@145 65 (restart!)
rlm@145 66 (let [state (SaveState. (Gb/saveState))]
rlm@145 67 (write-state! state "root" ) state))
rlm@145 68
rlm@145 69 (defn root []
rlm@145 70 (if (.exists (state-cache-file "root"))
rlm@145 71 (read-state "root")
rlm@145 72 (gen-root!)))
rlm@145 73
rlm@145 74 ;;;; Press Buttons
rlm@145 75
rlm@145 76 (def button-code
rlm@145 77 {;; main buttons
rlm@145 78 :a 0x0001
rlm@145 79 :b 0x0002
rlm@145 80
rlm@145 81 ;; directional pad
rlm@145 82 :r 0x0010
rlm@145 83 :l 0x0020
rlm@145 84 :u 0x0040
rlm@145 85 :d 0x0080
rlm@145 86
rlm@145 87 ;; meta buttons
rlm@145 88 :select 0x0004
rlm@145 89 :start 0x0008
rlm@145 90
rlm@145 91 ;; pseudo-buttons
rlm@145 92 :restart 0x0800 ; hard reset
rlm@145 93 :listen -1 ; listen for user input
rlm@145 94 })
rlm@145 95
rlm@145 96 (defn button-mask [buttons]
rlm@145 97 (reduce bit-or 0x0000 (map button-code buttons)))
rlm@145 98
rlm@145 99 (defn set-state! [^SaveState state]
rlm@145 100 (assert (:data state) "Not a valid state!")
rlm@145 101 (if (not @on?) (restart!))
rlm@145 102 (if (not= state @current-state)
rlm@145 103 (do
rlm@145 104 (Gb/loadState (:data state))
rlm@145 105 (reset! current-state state))))
rlm@145 106
rlm@145 107 (defn update-state []
rlm@145 108 (reset! current-state
rlm@145 109 (SaveState. (Gb/saveState))))
rlm@145 110
rlm@145 111 (defn step
rlm@145 112 ([^SaveState state buttons]
rlm@145 113 (set-state! state)
rlm@145 114 (Gb/step (button-mask buttons))
rlm@145 115 (reset! current-state
rlm@145 116 (SaveState. (Gb/saveState))))
rlm@145 117 ([^SaveState state]
rlm@145 118 (step state [:listen]))
rlm@145 119 ([] (step (if @current-state @current-state (root)))))
rlm@145 120
rlm@145 121 (defn tick
rlm@145 122 ([] (tick @current-state))
rlm@145 123 ([^SaveState state]
rlm@145 124 (set-state! state)
rlm@145 125 (Gb/tick)
rlm@145 126 (update-state)))
rlm@145 127
rlm@145 128 (defn play
rlm@145 129 ([^SaveState state n]
rlm@145 130 (try
rlm@145 131 (set-state! state)
rlm@145 132 (dorun (dotimes [_ n]
rlm@145 133 (Thread/sleep 1)
rlm@145 134 (Gb/step)))
rlm@145 135 (finally
rlm@145 136 (update-state))))
rlm@145 137 ([n]
rlm@145 138 (play @current-state n)))
rlm@145 139
rlm@145 140 (defn continue!
rlm@145 141 ([state]
rlm@145 142 (play state Integer/MAX_VALUE))
rlm@145 143 ([]
rlm@145 144 (continue! @current-state)))
rlm@145 145
rlm@326 146 (defn run-moves [state moves]
rlm@154 147 (set-state! state)
rlm@154 148 (dorun (map #(Gb/step (button-mask %))
rlm@154 149 moves))
rlm@154 150 (update-state))
rlm@154 151
rlm@145 152 (defn play-moves
rlm@145 153 ([moves [prev state]]
rlm@145 154 (set-state! state)
rlm@145 155 (dorun (map (fn [move] (step @current-state move)) moves))
rlm@145 156 [(concat prev moves) @current-state]))
rlm@522 157
rlm@522 158 (defn accurate-memory
rlm@522 159 ([^SaveState state address]
rlm@522 160 (set-state! state)
rlm@522 161 (Gb/readMemory address))
rlm@522 162 ([address]
rlm@522 163 (accurate-memory @current-state address)))
rlm@145 164
rlm@145 165 ;;;;;;;;;;;
rlm@145 166
rlm@496 167 ;; Get Screen Pixels, Save Screenshot
rlm@496 168
rlm@496 169 (defn write-png!
rlm@496 170 ([^SaveState state ^File target]
rlm@496 171 (set-state! state)
rlm@496 172 (Gb/nwritePNG (.getCanonicalPath target)))
rlm@496 173 ([^File target]
rlm@496 174 (write-png! @current-state target)))
rlm@496 175
rlm@145 176 ;;;;;;;;;;;;;;; CPU data
rlm@145 177
rlm@145 178 (defn cpu-data [size arr-fn]
rlm@145 179 (let [store (int-array size)]
rlm@145 180 (fn get-data
rlm@145 181 ([] (get-data @current-state))
rlm@145 182 ([state]
rlm@145 183 (set-state! state) (arr-fn store) store))))
rlm@145 184
rlm@145 185 (defn write-cpu-data [size store-fn]
rlm@145 186 (fn store-data
rlm@145 187 ([state new-data]
rlm@145 188 (set-state! state)
rlm@145 189 (let [store (int-array new-data)]
rlm@145 190 (assert (= size (count new-data)))
rlm@145 191 (store-fn store)
rlm@145 192 (update-state)))
rlm@145 193 ([new-data]
rlm@145 194 (store-data @current-state new-data))))
rlm@145 195
rlm@524 196 (let [store (byte-array Gb/SOUND_SIZE)]
rlm@524 197 (defn sound-data
rlm@524 198 ([](sound-data @current-state))
rlm@524 199 ([state]
rlm@524 200 (set-state! state)
rlm@524 201 (Gb/getFrameSound store)
rlm@524 202 (Gb/setSoundFrameWritten 0)
rlm@524 203 store)))
rlm@524 204
rlm@145 205 (def memory
rlm@145 206 (cpu-data Gb/GB_MEMORY #(Gb/getMemory %)))
rlm@145 207
rlm@145 208 (def ram
rlm@145 209 (cpu-data Gb/RAM_SIZE #(Gb/getRAM %)))
rlm@145 210
rlm@145 211 (def rom
rlm@145 212 (cpu-data Gb/ROM_SIZE #(Gb/getROM %)))
rlm@145 213
rlm@145 214 (def working-ram
rlm@145 215 (cpu-data Gb/WRAM_SIZE #(Gb/getWRAM %)))
rlm@145 216
rlm@145 217 (def video-ram
rlm@145 218 (cpu-data Gb/VRAM_SIZE #(Gb/getVRAM %)))
rlm@145 219
rlm@145 220 (def registers
rlm@145 221 (cpu-data Gb/NUM_REGISTERS #(Gb/getRegisters %)))
rlm@145 222
rlm@496 223 (def pixels
rlm@496 224 (cpu-data (* Gb/DISPLAY_WIDTH Gb/DISPLAY_HEIGHT)
rlm@496 225 #(Gb/getPixels %)))
rlm@496 226
rlm@145 227 (def write-memory!
rlm@145 228 (write-cpu-data Gb/GB_MEMORY #(Gb/writeMemory %)))
rlm@145 229
rlm@145 230 (def write-registers!
rlm@145 231 (write-cpu-data Gb/NUM_REGISTERS #(Gb/writeRegisters %)))
rlm@145 232
rlm@191 233 (def write-rom!
rlm@191 234 (write-cpu-data Gb/ROM_SIZE #(Gb/writeROM %)))
rlm@191 235
rlm@145 236 ;;;;; Registers ;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@145 237
rlm@145 238 (defmacro gen-get-set-register [name index]
rlm@145 239 (let [name-bang (symbol (str name "!"))]
rlm@145 240 `(do
rlm@145 241 (defn ~name
rlm@145 242 ~(str "Retrieve the " name " register from state, or "
rlm@145 243 "from @current-state if state is absent.")
rlm@145 244 ([state#]
rlm@145 245 (nth (registers state#) ~index))
rlm@145 246 ([]
rlm@145 247 (~name @current-state)))
rlm@145 248 (defn ~name-bang
rlm@145 249 ~(str "Set the " name " register for state, or "
rlm@145 250 "for @current-state if state is absent.")
rlm@145 251 ([state# new-register#]
rlm@145 252 (set-state! state#)
rlm@145 253 (let [registers# (registers state#)]
rlm@145 254 (aset registers# ~index new-register#)
rlm@145 255 (Gb/writeRegisters registers#)
rlm@145 256 (update-state)))
rlm@145 257 ([new-register#]
rlm@145 258 (~name-bang @current-state new-register#))))))
rlm@145 259
rlm@145 260 ;; 16 bit registers
rlm@145 261 (gen-get-set-register PC 0)
rlm@145 262 (gen-get-set-register SP 1)
rlm@145 263 (gen-get-set-register AF 2)
rlm@145 264 (gen-get-set-register BC 3)
rlm@145 265 (gen-get-set-register DE 4)
rlm@145 266 (gen-get-set-register HL 5)
rlm@145 267 (gen-get-set-register IFF 6)
rlm@145 268
rlm@145 269 ;; 8 bit registers
rlm@145 270 (gen-get-set-register DIV 7)
rlm@145 271 (gen-get-set-register TIMA 8)
rlm@145 272 (gen-get-set-register TMA 9)
rlm@145 273 (gen-get-set-register IF 11)
rlm@145 274 (gen-get-set-register LCDC 12)
rlm@145 275 (gen-get-set-register STAT 13)
rlm@145 276 (gen-get-set-register SCY 14)
rlm@145 277 (gen-get-set-register SCX 15)
rlm@145 278 (gen-get-set-register LY 16)
rlm@145 279 (gen-get-set-register DMA 18)
rlm@145 280 (gen-get-set-register WY 19)
rlm@145 281 (gen-get-set-register WX 20)
rlm@145 282 (gen-get-set-register VBK 21)
rlm@145 283 (gen-get-set-register HDMA1 22)
rlm@145 284 (gen-get-set-register HDMA2 23)
rlm@145 285 (gen-get-set-register HDMA3 24)
rlm@145 286 (gen-get-set-register HDMA4 25)
rlm@145 287 (gen-get-set-register HDMA5 26)
rlm@145 288 (gen-get-set-register SVBK 27)
rlm@145 289 (gen-get-set-register IE 28)
rlm@145 290
rlm@145 291 ;;;;;;;;;;;;;;;
rlm@145 292
rlm@145 293 (defmacro defn-memo
rlm@145 294 [& forms]
rlm@145 295 (let [fun-name (first forms)]
rlm@145 296 `(do
rlm@145 297 (defn ~@forms)
rlm@145 298 (alter-var-root (var ~fun-name) memoize))))
rlm@145 299
rlm@488 300 (def original-rom (rom (root)))
ocsenave@227 301
rlm@489 302
rlm@489 303 ;; RGB colors in an image are not the same as those in a GameBoy, so I
rlm@489 304 ;; need to convert them. Fortunately, this code is already written
rlm@489 305 ;; for me in this C-code from the public domain hi-color converter by
rlm@489 306 ;; Glen Cook, Jeff Frohwein, and Rob Jones.
rlm@488 307 (defn rgb->gb-rb [[r g b :as color]]
rlm@488 308 (let [store (int-array 3)]
rlm@488 309 (Gb/translateRGB (int-array color) store)
rlm@524 310 (vec store)))
rlm@524 311