Mercurial > vba-clojure

     1 (ns com.aurellem.gb.gb-driver

     2     (: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)))

     7 

     8 ;; Savestates

     9 

    10 (defrecord SaveState [data])

    11 

    12 (def user-home (File. (System/getProperty "user.home")))

    13 

    14 (def ^:dynamic *save-state-cache*

    15   (File. user-home "proj/vba-clojure/save-states/"))

    16 

    17 (def current-state (atom nil))

    18 

    19 (defn state-cache-file [name]

    20   (File. *save-state-cache* (str name ".sav")))

    21 

    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)))

    33 

    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 ;;;;;;;;;;;;;;;;

    43 

    44 

    45 ;; Gameboy management

    46 (Gb/loadVBA)

    47 

    48 (def yellow-rom-image

    49   (File. user-home "proj/pokemon-escape/roms/yellow.gbc"))

    50 

    51 (def yellow-save-file

    52   (File. user-home "proj/pokemon-escape/roms/yellow.sav"))

    53 

    54 (def on? (atom nil))

    55 

    56 (defn shutdown! [] (Gb/shutdown) (reset! on? false))

    57 

    58 (defn restart! []

    59   (shutdown!)

    60   (.delete yellow-save-file)

    61   (Gb/startEmulator (.getCanonicalPath yellow-rom-image))

    62   (reset! on? true))

    63 

    64 ;;; The first state!

    65 (defn gen-root! []

    66   (restart!)

    67   (let [state (SaveState. (Gb/saveState))]

    68     (write-state! state "root" ) state))

    69 

    70 (defn root []

    71   (if (.exists (state-cache-file "root"))

    72     (read-state "root")

    73     (gen-root!)))

    74 

    75 ;;;; Press Buttons

    76 

    77 (def button-code

    78   {;; main buttons

    79    :a         0x0001

    80    :b         0x0002

    81 

    82    ;; directional pad

    83    :r         0x0010

    84    :l         0x0020

    85    :u         0x0040

    86    :d         0x0080

    87 

    88    ;; meta buttons

    89    :select    0x0004

    90    :start     0x0008

    91 

    92    ;; pseudo-buttons

    93    :restart   0x0800 ; hard reset 

    94    :listen -1        ; listen for user input

    95    })

    96 

    97 (defn button-mask [buttons]

    98   (reduce bit-or 0x0000 (map button-code buttons)))

    99 

   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     (do 

   105       (Gb/loadState (:data state))

   106       (reset! current-state state))))

   107 

   108 (defn update-state []

   109   (reset! current-state

   110           (SaveState. (Gb/saveState))))

   111 

   112 (defn step

   113   ([^SaveState state buttons]

   114      (set-state! state)

   115      (Gb/step (button-mask buttons))

   116      (reset! current-state 

   117              (SaveState. (Gb/saveState))))

   118   ([^SaveState state]

   119      (step state [:listen]))

   120   ([] (step (if @current-state @current-state (root)))))

   121 

   122 (defn tick

   123   ([] (tick @current-state))

   124   ([^SaveState state]

   125      (set-state! state)

   126      (Gb/tick)

   127      (update-state)))

   128 

   129 (defn play

   130   ([^SaveState state n]

   131      (try

   132        (set-state! state)

   133        (dorun (dotimes [_ n]

   134                 (Thread/sleep 1)

   135                 (Gb/step)))

   136        (finally

   137              (update-state))))

   138   ([n]

   139      (play @current-state n)))

   140 

   141 (defn continue!

   142   ([state]

   143      (play state Integer/MAX_VALUE))

   144   ([]

   145     (continue! @current-state)))

   146 

   147 (defn run-moves [state moves]

   148   (set-state! state)

   149   (dorun (map #(Gb/step (button-mask %))

   150               moves))

   151   (update-state))

   152 

   153 (defn play-moves

   154   ([moves [prev state]]

   155      (set-state! state)

   156      (dorun (map (fn [move] (step @current-state move)) moves))

   157      [(concat prev moves) @current-state]))

   158 

   159 (defn accurate-memory

   160   ([^SaveState state address]

   161      (set-state! state)

   162      (Gb/readMemory address))

   163   ([address]

   164      (accurate-memory @current-state address)))

   165   

   166 ;;;;;;;;;;;

   167 

   168 ;; Get Screen Pixels, Save Screenshot

   169 

   170 (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)))

   176 

   177 ;;;;;;;;;;;;;;; CPU data

   178 

   179 (defn cpu-data [size arr-fn]

   180   (let [store (int-array size)]

   181     (fn get-data

   182       ([] (get-data @current-state))

   183       ([state]

   184          (set-state! state) (arr-fn store) store))))

   185 

   186 (defn write-cpu-data [size store-fn]

   187   (fn store-data

   188     ([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))))

   196 

   197 (def gb-sound-format

   198   "44100 hertz, linear PCM, 2 channels with 16 bits per sample."

   199   (AudioFormat. 44100 16 2 true false))

   200 

   201 (let [store (byte-array Gb/MAX_SOUND_BYTES)]

   202   (defn sound-bytes

   203     "Returns a byte array containting the sound samples

   204      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))))))

   212 

   213 (def memory

   214   (cpu-data Gb/GB_MEMORY #(Gb/getMemory %)))

   215 

   216 (def ram

   217   (cpu-data Gb/RAM_SIZE #(Gb/getRAM %)))

   218 

   219 (def rom 

   220   (cpu-data Gb/ROM_SIZE #(Gb/getROM %)))

   221 

   222 (def working-ram 

   223   (cpu-data Gb/WRAM_SIZE #(Gb/getWRAM %)))

   224 

   225 (def video-ram 

   226   (cpu-data Gb/VRAM_SIZE #(Gb/getVRAM %)))

   227 

   228 (def registers

   229   (cpu-data Gb/NUM_REGISTERS #(Gb/getRegisters %)))

   230 

   231 (def pixels

   232   (cpu-data (* Gb/DISPLAY_WIDTH Gb/DISPLAY_HEIGHT)

   233             #(Gb/getPixels %)))

   234 

   235 (def write-memory!

   236   (write-cpu-data Gb/GB_MEMORY #(Gb/writeMemory %)))

   237 

   238 (def write-registers!

   239   (write-cpu-data Gb/NUM_REGISTERS #(Gb/writeRegisters %)))

   240 

   241 (def write-rom!

   242   (write-cpu-data Gb/ROM_SIZE #(Gb/writeROM %)))

   243 

   244 ;;;;;  Registers  ;;;;;;;;;;;;;;;;;;;;;;;;;;;

   245 

   246 (defmacro gen-get-set-register [name index]

   247   (let [name-bang (symbol (str name "!"))]

   248     `(do

   249        (defn ~name

   250          ~(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-bang

   257          ~(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#))))))

   267 

   268 ;; 16 bit registers

   269 (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)

   276 

   277 ;; 8 bit registers

   278 (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)

   298 

   299 ;;;;;;;;;;;;;;;

   300 

   301 (defmacro defn-memo

   302   [& forms]

   303   (let [fun-name (first forms)]

   304     `(do

   305        (defn ~@forms)

   306        (alter-var-root (var ~fun-name) memoize))))

   307 

   308 (def original-rom (rom (root)))

   309 

   310 

   311 ;; RGB colors in an image are not the same as those in a GameBoy, so I

   312 ;; need to convert them.  Fortunately, this code is already written

   313 ;; for me in this C-code from the public domain hi-color converter by

   314 ;; 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)))

   319
author	Robert McIntyre <rlm@mit.edu>
date	Sun, 24 Jun 2012 13:34:15 -0500
parents	fa7676dbf6f2
children