Mercurial > vba-clojure
view clojure/com/aurellem/gb/gb_driver.clj @ 562:114f58b5b6d0
new glyph rendering skeleton complete.
author | Robert McIntyre <rlm@mit.edu> |
---|---|
date | Fri, 31 Aug 2012 09:22:52 -0500 |
parents | 2620d6318e8d |
children |
line wrap: on
line source
1 (ns com.aurellem.gb.gb-driver2 (:import com.aurellem.gb.Gb)3 (:import java.io.File)4 (:import javax.sound.sampled.AudioFormat)5 (:import org.apache.commons.io.FileUtils)6 (:import (java.nio IntBuffer ByteOrder)))8 ;; Savestates10 (defrecord SaveState [data])12 (def user-home (File. (System/getProperty "user.home")))14 (def ^:dynamic *save-state-cache*15 (File. user-home "proj/vba-clojure/save-states/"))17 (def current-state (atom nil))19 (defn state-cache-file [name]20 (File. *save-state-cache* (str name ".sav")))22 (defn write-state!23 ([^SaveState name]24 (write-state! @current-state name))25 ([^SaveState save ^String name]26 (let [buffer (:data save)27 bytes (byte-array (.limit buffer))28 dest (state-cache-file name)]29 (.get buffer bytes)30 (FileUtils/writeByteArrayToFile dest bytes)31 (.rewind buffer)32 dest)))34 (defn read-state [name]35 (let [save (state-cache-file name)]36 (assert (.exists save))37 (let [buffer (Gb/saveBuffer)38 bytes (FileUtils/readFileToByteArray save)]39 (.put buffer bytes)40 (.flip buffer)41 (SaveState. buffer))))42 ;;;;;;;;;;;;;;;;45 ;; Gameboy management46 (Gb/loadVBA)48 (def yellow-rom-image49 (File. user-home "proj/pokemon-escape/roms/yellow.gbc"))51 (def yellow-save-file52 (File. user-home "proj/pokemon-escape/roms/yellow.sav"))54 (def on? (atom nil))56 (defn shutdown! [] (Gb/shutdown) (reset! on? false))58 (defn restart! []59 (shutdown!)60 (.delete yellow-save-file)61 (Gb/startEmulator (.getCanonicalPath yellow-rom-image))62 (reset! on? true))64 ;;; The first state!65 (defn gen-root! []66 (restart!)67 (let [state (SaveState. (Gb/saveState))]68 (write-state! state "root" ) state))70 (defn root []71 (if (.exists (state-cache-file "root"))72 (read-state "root")73 (gen-root!)))75 ;;;; Press Buttons77 (def button-code78 {;; main buttons79 :a 0x000180 :b 0x000282 ;; directional pad83 :r 0x001084 :l 0x002085 :u 0x004086 :d 0x008088 ;; meta buttons89 :select 0x000490 :start 0x000892 ;; pseudo-buttons93 :restart 0x0800 ; hard reset94 :listen -1 ; listen for user input95 })97 (defn button-mask [buttons]98 (reduce bit-or 0x0000 (map button-code buttons)))100 (defn set-state! [^SaveState state]101 (assert (:data state) "Not a valid state!")102 (if (not @on?) (restart!))103 (if (not= state @current-state)104 (do105 (Gb/loadState (:data state))106 (reset! current-state state))))108 (defn update-state []109 (reset! current-state110 (SaveState. (Gb/saveState))))112 (defn step113 ([^SaveState state buttons]114 (set-state! state)115 (Gb/step (button-mask buttons))116 (reset! current-state117 (SaveState. (Gb/saveState))))118 ([^SaveState state]119 (step state [:listen]))120 ([] (step (if @current-state @current-state (root)))))122 (defn tick123 ([] (tick @current-state))124 ([^SaveState state]125 (set-state! state)126 (Gb/tick)127 (update-state)))129 (defn play130 ([^SaveState state n]131 (try132 (set-state! state)133 (dorun (dotimes [_ n]134 (Thread/sleep 1)135 (Gb/step)))136 (finally137 (update-state))))138 ([n]139 (play @current-state n)))141 (defn continue!142 ([state]143 (play state Integer/MAX_VALUE))144 ([]145 (continue! @current-state)))147 (defn run-moves [state moves]148 (set-state! state)149 (dorun (map #(Gb/step (button-mask %))150 moves))151 (update-state))153 (defn play-moves154 ([moves [prev state]]155 (set-state! state)156 (dorun (map (fn [move] (step @current-state move)) moves))157 [(concat prev moves) @current-state]))159 (defn accurate-memory160 ([^SaveState state address]161 (set-state! state)162 (Gb/readMemory address))163 ([address]164 (accurate-memory @current-state address)))166 ;;;;;;;;;;;168 ;; Get Screen Pixels, Save Screenshot170 (defn write-png!171 ([^SaveState state ^File target]172 (set-state! state)173 (Gb/nwritePNG (.getCanonicalPath target)))174 ([^File target]175 (write-png! @current-state target)))177 ;;;;;;;;;;;;;;; CPU data179 (defn cpu-data [size arr-fn]180 (let [store (int-array size)]181 (fn get-data182 ([] (get-data @current-state))183 ([state]184 (set-state! state) (arr-fn store) store))))186 (defn write-cpu-data [size store-fn]187 (fn store-data188 ([state new-data]189 (set-state! state)190 (let [store (int-array new-data)]191 (assert (= size (count new-data)))192 (store-fn store)193 (update-state)))194 ([new-data]195 (store-data @current-state new-data))))197 (def gb-sound-format198 "44100 hertz, linear PCM, 2 channels with 16 bits per sample."199 (AudioFormat. 44100 16 2 true false))201 (let [store (byte-array Gb/MAX_SOUND_BYTES)]202 (defn sound-bytes203 "Returns a byte array containting the sound samples204 generated this step."205 ([](sound-bytes @current-state))206 ([state]207 (set-state! state)208 (Gb/getFrameSound store)209 (let [actual-bytes (* 2 (Gb/getSoundFrameWritten))]210 (Gb/setSoundFrameWritten 0)211 (byte-array (take actual-bytes store))))))213 (def memory214 (cpu-data Gb/GB_MEMORY #(Gb/getMemory %)))216 (def ram217 (cpu-data Gb/RAM_SIZE #(Gb/getRAM %)))219 (def rom220 (cpu-data Gb/ROM_SIZE #(Gb/getROM %)))222 (def working-ram223 (cpu-data Gb/WRAM_SIZE #(Gb/getWRAM %)))225 (def video-ram226 (cpu-data Gb/VRAM_SIZE #(Gb/getVRAM %)))228 (def registers229 (cpu-data Gb/NUM_REGISTERS #(Gb/getRegisters %)))231 (def pixels232 (cpu-data (* Gb/DISPLAY_WIDTH Gb/DISPLAY_HEIGHT)233 #(Gb/getPixels %)))235 (def write-memory!236 (write-cpu-data Gb/GB_MEMORY #(Gb/writeMemory %)))238 (def write-registers!239 (write-cpu-data Gb/NUM_REGISTERS #(Gb/writeRegisters %)))241 (def write-rom!242 (write-cpu-data Gb/ROM_SIZE #(Gb/writeROM %)))244 ;;;;; Registers ;;;;;;;;;;;;;;;;;;;;;;;;;;;246 (defmacro gen-get-set-register [name index]247 (let [name-bang (symbol (str name "!"))]248 `(do249 (defn ~name250 ~(str "Retrieve the " name " register from state, or "251 "from @current-state if state is absent.")252 ([state#]253 (nth (registers state#) ~index))254 ([]255 (~name @current-state)))256 (defn ~name-bang257 ~(str "Set the " name " register for state, or "258 "for @current-state if state is absent.")259 ([state# new-register#]260 (set-state! state#)261 (let [registers# (registers state#)]262 (aset registers# ~index new-register#)263 (Gb/writeRegisters registers#)264 (update-state)))265 ([new-register#]266 (~name-bang @current-state new-register#))))))268 ;; 16 bit registers269 (gen-get-set-register PC 0)270 (gen-get-set-register SP 1)271 (gen-get-set-register AF 2)272 (gen-get-set-register BC 3)273 (gen-get-set-register DE 4)274 (gen-get-set-register HL 5)275 (gen-get-set-register IFF 6)277 ;; 8 bit registers278 (gen-get-set-register DIV 7)279 (gen-get-set-register TIMA 8)280 (gen-get-set-register TMA 9)281 (gen-get-set-register IF 11)282 (gen-get-set-register LCDC 12)283 (gen-get-set-register STAT 13)284 (gen-get-set-register SCY 14)285 (gen-get-set-register SCX 15)286 (gen-get-set-register LY 16)287 (gen-get-set-register DMA 18)288 (gen-get-set-register WY 19)289 (gen-get-set-register WX 20)290 (gen-get-set-register VBK 21)291 (gen-get-set-register HDMA1 22)292 (gen-get-set-register HDMA2 23)293 (gen-get-set-register HDMA3 24)294 (gen-get-set-register HDMA4 25)295 (gen-get-set-register HDMA5 26)296 (gen-get-set-register SVBK 27)297 (gen-get-set-register IE 28)299 ;;;;;;;;;;;;;;;301 (defmacro defn-memo302 [& forms]303 (let [fun-name (first forms)]304 `(do305 (defn ~@forms)306 (alter-var-root (var ~fun-name) memoize))))308 (def original-rom (rom (root)))311 ;; RGB colors in an image are not the same as those in a GameBoy, so I312 ;; need to convert them. Fortunately, this code is already written313 ;; for me in this C-code from the public domain hi-color converter by314 ;; Glen Cook, Jeff Frohwein, and Rob Jones.315 (defn rgb->gb-rb [[r g b :as color]]316 (let [store (int-array 3)]317 (Gb/translateRGB (int-array color) store)318 (vec store)))