Mercurial > vba-clojure

annotate clojure/com/aurellem/gb/gb_driver.clj @ 513:3dbb863eb801

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
accuracy of displayed image is much improved, but there the palettes are still messed up.
author Robert McIntyre <rlm@mit.edu>
date Fri, 22 Jun 2012 18:58:47 -0500
parents a6d060a64246
children 5596cd4a3fc6
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@145 157
rlm@145 158 ;;;;;;;;;;;
rlm@145 159
rlm@496 160 ;; Get Screen Pixels, Save Screenshot
rlm@496 161
rlm@496 162 (defn write-png!
rlm@496 163 ([^SaveState state ^File target]
rlm@496 164 (set-state! state)
rlm@496 165 (Gb/nwritePNG (.getCanonicalPath target)))
rlm@496 166 ([^File target]
rlm@496 167 (write-png! @current-state target)))
rlm@496 168
rlm@496 169
rlm@496 170
rlm@145 171
rlm@145 172 ;;;;;;;;;;;;;;; CPU data
rlm@145 173
rlm@145 174 (defn cpu-data [size arr-fn]
rlm@145 175 (let [store (int-array size)]
rlm@145 176 (fn get-data
rlm@145 177 ([] (get-data @current-state))
rlm@145 178 ([state]
rlm@145 179 (set-state! state) (arr-fn store) store))))
rlm@145 180
rlm@145 181 (defn write-cpu-data [size store-fn]
rlm@145 182 (fn store-data
rlm@145 183 ([state new-data]
rlm@145 184 (set-state! state)
rlm@145 185 (let [store (int-array new-data)]
rlm@145 186 (assert (= size (count new-data)))
rlm@145 187 (store-fn store)
rlm@145 188 (update-state)))
rlm@145 189 ([new-data]
rlm@145 190 (store-data @current-state new-data))))
rlm@145 191
rlm@145 192 (def memory
rlm@145 193 (cpu-data Gb/GB_MEMORY #(Gb/getMemory %)))
rlm@145 194
rlm@145 195 (def ram
rlm@145 196 (cpu-data Gb/RAM_SIZE #(Gb/getRAM %)))
rlm@145 197
rlm@145 198 (def rom
rlm@145 199 (cpu-data Gb/ROM_SIZE #(Gb/getROM %)))
rlm@145 200
rlm@145 201 (def working-ram
rlm@145 202 (cpu-data Gb/WRAM_SIZE #(Gb/getWRAM %)))
rlm@145 203
rlm@145 204 (def video-ram
rlm@145 205 (cpu-data Gb/VRAM_SIZE #(Gb/getVRAM %)))
rlm@145 206
rlm@145 207 (def registers
rlm@145 208 (cpu-data Gb/NUM_REGISTERS #(Gb/getRegisters %)))
rlm@145 209
rlm@496 210 (def pixels
rlm@496 211 (cpu-data (* Gb/DISPLAY_WIDTH Gb/DISPLAY_HEIGHT)
rlm@496 212 #(Gb/getPixels %)))
rlm@496 213
rlm@145 214 (def write-memory!
rlm@145 215 (write-cpu-data Gb/GB_MEMORY #(Gb/writeMemory %)))
rlm@145 216
rlm@145 217 (def write-registers!
rlm@145 218 (write-cpu-data Gb/NUM_REGISTERS #(Gb/writeRegisters %)))
rlm@145 219
rlm@191 220 (def write-rom!
rlm@191 221 (write-cpu-data Gb/ROM_SIZE #(Gb/writeROM %)))
rlm@191 222
rlm@145 223 ;;;;; Registers ;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@145 224
rlm@145 225 (defmacro gen-get-set-register [name index]
rlm@145 226 (let [name-bang (symbol (str name "!"))]
rlm@145 227 `(do
rlm@145 228 (defn ~name
rlm@145 229 ~(str "Retrieve the " name " register from state, or "
rlm@145 230 "from @current-state if state is absent.")
rlm@145 231 ([state#]
rlm@145 232 (nth (registers state#) ~index))
rlm@145 233 ([]
rlm@145 234 (~name @current-state)))
rlm@145 235 (defn ~name-bang
rlm@145 236 ~(str "Set the " name " register for state, or "
rlm@145 237 "for @current-state if state is absent.")
rlm@145 238 ([state# new-register#]
rlm@145 239 (set-state! state#)
rlm@145 240 (let [registers# (registers state#)]
rlm@145 241 (aset registers# ~index new-register#)
rlm@145 242 (Gb/writeRegisters registers#)
rlm@145 243 (update-state)))
rlm@145 244 ([new-register#]
rlm@145 245 (~name-bang @current-state new-register#))))))
rlm@145 246
rlm@145 247 ;; 16 bit registers
rlm@145 248 (gen-get-set-register PC 0)
rlm@145 249 (gen-get-set-register SP 1)
rlm@145 250 (gen-get-set-register AF 2)
rlm@145 251 (gen-get-set-register BC 3)
rlm@145 252 (gen-get-set-register DE 4)
rlm@145 253 (gen-get-set-register HL 5)
rlm@145 254 (gen-get-set-register IFF 6)
rlm@145 255
rlm@145 256 ;; 8 bit registers
rlm@145 257 (gen-get-set-register DIV 7)
rlm@145 258 (gen-get-set-register TIMA 8)
rlm@145 259 (gen-get-set-register TMA 9)
rlm@145 260 (gen-get-set-register IF 11)
rlm@145 261 (gen-get-set-register LCDC 12)
rlm@145 262 (gen-get-set-register STAT 13)
rlm@145 263 (gen-get-set-register SCY 14)
rlm@145 264 (gen-get-set-register SCX 15)
rlm@145 265 (gen-get-set-register LY 16)
rlm@145 266 (gen-get-set-register DMA 18)
rlm@145 267 (gen-get-set-register WY 19)
rlm@145 268 (gen-get-set-register WX 20)
rlm@145 269 (gen-get-set-register VBK 21)
rlm@145 270 (gen-get-set-register HDMA1 22)
rlm@145 271 (gen-get-set-register HDMA2 23)
rlm@145 272 (gen-get-set-register HDMA3 24)
rlm@145 273 (gen-get-set-register HDMA4 25)
rlm@145 274 (gen-get-set-register HDMA5 26)
rlm@145 275 (gen-get-set-register SVBK 27)
rlm@145 276 (gen-get-set-register IE 28)
rlm@145 277
rlm@145 278 ;;;;;;;;;;;;;;;
rlm@145 279
rlm@145 280 (defmacro defn-memo
rlm@145 281 [& forms]
rlm@145 282 (let [fun-name (first forms)]
rlm@145 283 `(do
rlm@145 284 (defn ~@forms)
rlm@145 285 (alter-var-root (var ~fun-name) memoize))))
rlm@145 286
rlm@488 287 (def original-rom (rom (root)))
ocsenave@227 288
rlm@489 289
rlm@489 290 ;; RGB colors in an image are not the same as those in a GameBoy, so I
rlm@489 291 ;; need to convert them. Fortunately, this code is already written
rlm@489 292 ;; for me in this C-code from the public domain hi-color converter by
rlm@489 293 ;; Glen Cook, Jeff Frohwein, and Rob Jones.
rlm@488 294 (defn rgb->gb-rb [[r g b :as color]]
rlm@488 295 (let [store (int-array 3)]
rlm@488 296 (Gb/translateRGB (int-array color) store)
rlm@496 297 (vec store)))
rlm@496 298
rlm@496 299