Mercurial > vba-clojure

     1 (ns com.aurellem.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/pokemon-escape/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     (if (.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 play-moves

   145   ([moves [prev state]]

   146      (set-state! state)

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

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

   149   

   150 ;;;;;;;;;;;

   151 

   152 

   153 ;;;;;;;;;;;;;;; CPU data

   154 

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

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

   157     (fn get-data

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

   159       ([state]

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

   161 

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

   163   (fn store-data

   164     ([state new-data]

   165        (set-state! state)

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

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

   168          (store-fn store)

   169          (update-state)))

   170     ([new-data]

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

   172     

   173 

   174 (def memory

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

   176 

   177 (def ram

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

   179 

   180 (def rom 

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

   182 

   183 (def working-ram 

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

   185 

   186 (def video-ram 

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

   188 

   189 (def registers

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

   191 

   192 (def write-memory!

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

   194 

   195 (def write-registers!

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

   197 

   198 ;;;;;  Registers  ;;;;;;;;;;;;;;;;;;;;;;;;;;;

   199 

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

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

   202     `(do

   203        (defn ~name

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

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

   206          ([state#]

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

   208          ([]

   209             (~name @current-state)))

   210        (defn ~name-bang

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

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

   213          ([state# new-register#]

   214             (set-state! state#)

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

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

   217               (Gb/writeRegisters registers#)

   218               (update-state)))

   219          ([new-register#]

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

   221 

   222 ;; 16 bit registers

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

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

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

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

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

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

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

   230 

   231 ;; 8 bit registers

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

   252                             

   253 ;;;;;;;;;;;;;;;

   254 

   255 (defmacro defn-memo

   256   [& forms]

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

   258     `(do

   259        (defn ~@forms)

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

   261
author	Dylan Holmes <ocsenave@gmail.com>
date	Sun, 18 Mar 2012 05:13:19 -0500
parents	718abf3bec8a
children	d125a294f9d8