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

   205 

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

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

   208     `(do

   209        (defn ~name

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

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

   212          ([state#]

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

   214          ([]

   215             (~name @current-state)))

   216        (defn ~name-bang

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

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

   219          ([state# new-register#]

   220             (set-state! state#)

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

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

   223               (Gb/writeRegisters registers#)

   224               (update-state)))

   225          ([new-register#]

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

   227 

   228 ;; 16 bit registers

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

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

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

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

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

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

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

   236 

   237 ;; 8 bit registers

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

   258 

   259 ;;;;;;;;;;;;;;;

   260 

   261 (defmacro defn-memo

   262   [& forms]

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

   264     `(do

   265        (defn ~@forms)

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

   267
author	Robert McIntyre <rlm@mit.edu>
date	Tue, 20 Mar 2012 03:54:15 -0500
parents	3a3bb2197b7f
children	893c753f8088