Mercurial > vba-clojure

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

     2     (:import com.aurellem.gb.Gb)

     3     (:import java.io.File)

     4     (:import org.apache.commons.io.FileUtils)

     5     (:import (java.nio IntBuffer ByteOrder)))

     6 

     7 ;; Savestates

     8 (defrecord SaveState [data])

     9 

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

    11 

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

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

    14 

    15 (def current-state (atom nil))

    16 

    17 (defn state-cache-file [name]

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

    19 

    20 (defn write-state!

    21   ([^SaveState name]

    22      (write-state! @current-state name))

    23   ([^SaveState save ^String name]

    24      (let [buffer (:data save)

    25            bytes (byte-array (.limit buffer))

    26            dest (state-cache-file name)]

    27        (.get buffer bytes)

    28        (FileUtils/writeByteArrayToFile dest bytes)

    29        (.rewind buffer)

    30        dest)))

    31 

    32 (defn read-state [name]

    33   (let [save (state-cache-file name)]

    34     (assert (.exists save))

    35     (let [buffer (Gb/saveBuffer)

    36           bytes (FileUtils/readFileToByteArray save)]

    37       (.put buffer bytes)

    38       (.flip buffer)

    39       (SaveState. buffer))))

    40 ;;;;;;;;;;;;;;;;

    41 

    42 ;; Gameboy management

    43 (Gb/loadVBA)

    44 

    45 (def yellow-rom-image

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

    47 

    48 (def yellow-save-file

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

    50 

    51 (def on? (atom nil))

    52 

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

    54 

    55 (defn restart! []

    56   (shutdown!)

    57   (.delete yellow-save-file)

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

    59   (reset! on? true))

    60 

    61 ;;; The first state!

    62 (defn gen-root! []

    63   (restart!)

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

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

    66 

    67 (defn root []

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

    69     (read-state "root")

    70     (gen-root!)))

    71 

    72 ;;;; Press Buttons

    73 

    74 (def button-code

    75   {;; main buttons

    76    :a         0x0001

    77    :b         0x0002

    78 

    79    ;; directional pad

    80    :r         0x0010

    81    :l         0x0020

    82    :u         0x0040

    83    :d         0x0080

    84 

    85    ;; meta buttons

    86    :select    0x0004

    87    :start     0x0008

    88 

    89    ;; pseudo-buttons

    90    :restart   0x0800 ; hard reset 

    91    :listen -1        ; listen for user input

    92    })

    93 

    94 (defn button-mask [buttons]

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

    96 

    97 (defn set-state! [^SaveState state]

    98   (assert (:data state) "Not a valid state!")

    99   (if (not @on?) (restart!))

   100   (if (not= state @current-state)

   101     (do 

   102       (Gb/loadState (:data state))

   103       (reset! current-state state))))

   104 

   105 (defn update-state []

   106   (reset! current-state

   107           (SaveState. (Gb/saveState))))

   108 

   109 (defn step

   110   ([^SaveState state buttons]

   111      (set-state! state)

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

   113      (reset! current-state 

   114              (SaveState. (Gb/saveState))))

   115   ([^SaveState state]

   116      (step state [:listen]))

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

   118 

   119 (defn tick

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

   121   ([^SaveState state]

   122      (set-state! state)

   123      (Gb/tick)

   124      (update-state)))

   125 

   126 (defn play

   127   ([^SaveState state n]

   128      (try

   129        (set-state! state)

   130        (dorun (dotimes [_ n]

   131                 (Thread/sleep 1)

   132                 (Gb/step)))

   133        (finally

   134              (update-state))))

   135   ([n]

   136      (play @current-state n)))

   137 

   138 (defn continue!

   139   ([state]

   140      (play state Integer/MAX_VALUE))

   141   ([]

   142     (continue! @current-state)))

   143 

   144 (defn run-moves [state moves]

   145   (set-state! state)

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

   147               moves))

   148   (update-state))

   149 

   150 (defn play-moves

   151   ([moves [prev state]]

   152      (set-state! state)

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

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

   155   

   156 ;;;;;;;;;;;

   157 

   158 

   159 ;;;;;;;;;;;;;;; CPU data

   160 

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

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

   163     (fn get-data

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

   165       ([state]

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

   167 

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

   169   (fn store-data

   170     ([state new-data]

   171        (set-state! state)

   172        (let [store (int-array new-data)]

   173          (assert (= size (count new-data)))

   174          (store-fn store)

   175          (update-state)))

   176     ([new-data]

   177        (store-data @current-state new-data))))

   178     

   179 

   180 (def memory

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

   182 

   183 (def ram

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

   185 

   186 (def rom 

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

   188 

   189 (def working-ram 

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

   191 

   192 (def video-ram 

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

   194 

   195 (def registers

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

   197 

   198 (def write-memory!

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

   200 

   201 (def write-registers!

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

   203 

   204 (def write-rom!

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

   206 

   207 ;;;;;  Registers  ;;;;;;;;;;;;;;;;;;;;;;;;;;;

   208 

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

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

   211     `(do

   212        (defn ~name

   213          ~(str "Retrieve the " name " register from state, or "

   214                "from @current-state if state is absent.")

   215          ([state#]

   216             (nth (registers state#) ~index))

   217          ([]

   218             (~name @current-state)))

   219        (defn ~name-bang

   220          ~(str "Set the " name " register for state, or "

   221                "for @current-state if state is absent.")

   222          ([state# new-register#]

   223             (set-state! state#)

   224             (let [registers# (registers state#)]

   225               (aset registers# ~index new-register#)

   226               (Gb/writeRegisters registers#)

   227               (update-state)))

   228          ([new-register#]

   229             (~name-bang @current-state new-register#))))))

   230 

   231 ;; 16 bit registers

   232 (gen-get-set-register PC 0)

   233 (gen-get-set-register SP 1)

   234 (gen-get-set-register AF 2)

   235 (gen-get-set-register BC 3)

   236 (gen-get-set-register DE 4)

   237 (gen-get-set-register HL 5)

   238 (gen-get-set-register IFF 6)

   239 

   240 ;; 8 bit registers

   241 (gen-get-set-register DIV 7)

   242 (gen-get-set-register TIMA 8)

   243 (gen-get-set-register TMA 9)

   244 (gen-get-set-register IF 11)

   245 (gen-get-set-register LCDC 12)

   246 (gen-get-set-register STAT 13)

   247 (gen-get-set-register SCY 14)

   248 (gen-get-set-register SCX 15)

   249 (gen-get-set-register LY 16)

   250 (gen-get-set-register DMA 18)

   251 (gen-get-set-register WY 19)

   252 (gen-get-set-register WX 20)

   253 (gen-get-set-register VBK 21)

   254 (gen-get-set-register HDMA1 22)

   255 (gen-get-set-register HDMA2 23)

   256 (gen-get-set-register HDMA3 24)

   257 (gen-get-set-register HDMA4 25)

   258 (gen-get-set-register HDMA5 26)

   259 (gen-get-set-register SVBK 27)

   260 (gen-get-set-register IE 28)

   261 

   262 ;;;;;;;;;;;;;;;

   263 

   264 (defmacro defn-memo

   265   [& forms]

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

   267     `(do

   268        (defn ~@forms)

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

   270
author	Robert McIntyre <rlm@mit.edu>
date	Thu, 22 Mar 2012 22:37:35 -0500
parents	893c753f8088
children	d5dddf33543c