1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/clojure/com/aurellem/gb/gb_driver.clj	Mon Mar 19 21:23:46 2012 -0500
     1.3 @@ -0,0 +1,261 @@
     1.4 +(ns com.aurellem.gb.gb-driver
     1.5 +    (:import com.aurellem.gb.Gb)
     1.6 +    (:import java.io.File)
     1.7 +    (:import org.apache.commons.io.FileUtils)
     1.8 +    (:import (java.nio IntBuffer ByteOrder)))
     1.9 +
    1.10 +;; Savestates
    1.11 +(defrecord SaveState [data])
    1.12 +
    1.13 +(def user-home (File. (System/getProperty "user.home")))
    1.14 +
    1.15 +(def ^:dynamic *save-state-cache*
    1.16 +  (File. user-home "proj/vba-clojure/save-states/"))
    1.17 +
    1.18 +(def current-state (atom nil))
    1.19 +
    1.20 +(defn state-cache-file [name]
    1.21 +  (File. *save-state-cache* (str name ".sav")))
    1.22 +
    1.23 +(defn write-state!
    1.24 +  ([^SaveState name]
    1.25 +     (write-state! @current-state name))
    1.26 +  ([^SaveState save ^String name]
    1.27 +     (let [buffer (:data save)
    1.28 +           bytes (byte-array (.limit buffer))
    1.29 +           dest (state-cache-file name)]
    1.30 +       (.get buffer bytes)
    1.31 +       (FileUtils/writeByteArrayToFile dest bytes)
    1.32 +       (.rewind buffer)
    1.33 +       dest)))
    1.34 +
    1.35 +(defn read-state [name]
    1.36 +  (let [save (state-cache-file name)]
    1.37 +    (if (.exists save)
    1.38 +      (let [buffer (Gb/saveBuffer)
    1.39 +            bytes (FileUtils/readFileToByteArray save)]
    1.40 +        (.put buffer bytes)
    1.41 +        (.flip buffer)
    1.42 +        (SaveState. buffer)))))
    1.43 +;;;;;;;;;;;;;;;;
    1.44 +
    1.45 +;; Gameboy management
    1.46 +(Gb/loadVBA)
    1.47 +
    1.48 +(def yellow-rom-image
    1.49 +  (File. user-home "proj/pokemon-escape/roms/yellow.gbc"))
    1.50 +
    1.51 +(def yellow-save-file
    1.52 +  (File. user-home "proj/pokemon-escape/roms/yellow.sav"))
    1.53 +
    1.54 +(def on? (atom nil))
    1.55 +
    1.56 +(defn shutdown! [] (Gb/shutdown) (reset! on? false))
    1.57 +
    1.58 +(defn restart! []
    1.59 +  (shutdown!)
    1.60 +  (.delete yellow-save-file)
    1.61 +  (Gb/startEmulator (.getCanonicalPath yellow-rom-image))
    1.62 +  (reset! on? true))
    1.63 +
    1.64 +;;; The first state!
    1.65 +(defn gen-root! []
    1.66 +  (restart!)
    1.67 +  (let [state (SaveState. (Gb/saveState))]
    1.68 +    (write-state! state "root" ) state))
    1.69 +
    1.70 +(defn root []
    1.71 +  (if (.exists (state-cache-file "root"))
    1.72 +    (read-state "root")
    1.73 +    (gen-root!)))
    1.74 +
    1.75 +;;;; Press Buttons
    1.76 +
    1.77 +(def button-code
    1.78 +  {;; main buttons
    1.79 +   :a         0x0001
    1.80 +   :b         0x0002
    1.81 +
    1.82 +   ;; directional pad
    1.83 +   :r         0x0010
    1.84 +   :l         0x0020
    1.85 +   :u         0x0040
    1.86 +   :d         0x0080
    1.87 +
    1.88 +   ;; meta buttons
    1.89 +   :select    0x0004
    1.90 +   :start     0x0008
    1.91 +
    1.92 +   ;; pseudo-buttons
    1.93 +   :restart   0x0800 ; hard reset 
    1.94 +   :listen -1        ; listen for user input
    1.95 +   })
    1.96 +
    1.97 +(defn button-mask [buttons]
    1.98 +  (reduce bit-or 0x0000 (map button-code buttons)))
    1.99 +
   1.100 +(defn set-state! [^SaveState state]
   1.101 +  (assert (:data state) "Not a valid state!")
   1.102 +  (if (not @on?) (restart!))
   1.103 +  (if (not= state @current-state)
   1.104 +    (do 
   1.105 +      (Gb/loadState (:data state))
   1.106 +      (reset! current-state state))))
   1.107 +
   1.108 +(defn update-state []
   1.109 +  (reset! current-state
   1.110 +          (SaveState. (Gb/saveState))))
   1.111 +
   1.112 +(defn step
   1.113 +  ([^SaveState state buttons]
   1.114 +     (set-state! state)
   1.115 +     (Gb/step (button-mask buttons))
   1.116 +     (reset! current-state 
   1.117 +             (SaveState. (Gb/saveState))))
   1.118 +  ([^SaveState state]
   1.119 +     (step state [:listen]))
   1.120 +  ([] (step (if @current-state @current-state (root)))))
   1.121 +
   1.122 +(defn tick
   1.123 +  ([] (tick @current-state))
   1.124 +  ([^SaveState state]
   1.125 +     (set-state! state)
   1.126 +     (Gb/tick)
   1.127 +     (update-state)))
   1.128 +
   1.129 +(defn play
   1.130 +  ([^SaveState state n]
   1.131 +     (try
   1.132 +       (set-state! state)
   1.133 +       (dorun (dotimes [_ n]
   1.134 +                (Thread/sleep 1)
   1.135 +                (Gb/step)))
   1.136 +       (finally
   1.137 +             (update-state))))
   1.138 +  ([n]
   1.139 +     (play @current-state n)))
   1.140 +
   1.141 +(defn continue!
   1.142 +  ([state]
   1.143 +     (play state Integer/MAX_VALUE))
   1.144 +  ([]
   1.145 +    (continue! @current-state)))
   1.146 +
   1.147 +(defn play-moves
   1.148 +  ([moves [prev state]]
   1.149 +     (set-state! state)
   1.150 +     (dorun (map (fn [move] (step @current-state move)) moves))
   1.151 +     [(concat prev moves) @current-state]))
   1.152 +  
   1.153 +;;;;;;;;;;;
   1.154 +
   1.155 +
   1.156 +;;;;;;;;;;;;;;; CPU data
   1.157 +
   1.158 +(defn cpu-data [size arr-fn]
   1.159 +  (let [store (int-array size)]
   1.160 +    (fn get-data
   1.161 +      ([] (get-data @current-state))
   1.162 +      ([state]
   1.163 +         (set-state! state) (arr-fn store) store))))
   1.164 +
   1.165 +(defn write-cpu-data [size store-fn]
   1.166 +  (fn store-data
   1.167 +    ([state new-data]
   1.168 +       (set-state! state)
   1.169 +       (let [store (int-array new-data)]
   1.170 +         (assert (= size (count new-data)))
   1.171 +         (store-fn store)
   1.172 +         (update-state)))
   1.173 +    ([new-data]
   1.174 +       (store-data @current-state new-data))))
   1.175 +    
   1.176 +
   1.177 +(def memory
   1.178 +  (cpu-data Gb/GB_MEMORY #(Gb/getMemory %)))
   1.179 +
   1.180 +(def ram
   1.181 +  (cpu-data Gb/RAM_SIZE #(Gb/getRAM %)))
   1.182 +
   1.183 +(def rom 
   1.184 +  (cpu-data Gb/ROM_SIZE #(Gb/getROM %)))
   1.185 +
   1.186 +(def working-ram 
   1.187 +  (cpu-data Gb/WRAM_SIZE #(Gb/getWRAM %)))
   1.188 +
   1.189 +(def video-ram 
   1.190 +  (cpu-data Gb/VRAM_SIZE #(Gb/getVRAM %)))
   1.191 +
   1.192 +(def registers
   1.193 +  (cpu-data Gb/NUM_REGISTERS #(Gb/getRegisters %)))
   1.194 +
   1.195 +(def write-memory!
   1.196 +  (write-cpu-data Gb/GB_MEMORY #(Gb/writeMemory %)))
   1.197 +
   1.198 +(def write-registers!
   1.199 +  (write-cpu-data Gb/NUM_REGISTERS #(Gb/writeRegisters %)))
   1.200 +
   1.201 +;;;;;  Registers  ;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.202 +
   1.203 +(defmacro gen-get-set-register [name index]
   1.204 +  (let [name-bang (symbol (str name "!"))]
   1.205 +    `(do
   1.206 +       (defn ~name
   1.207 +         ~(str "Retrieve the " name " register from state, or "
   1.208 +               "from @current-state if state is absent.")
   1.209 +         ([state#]
   1.210 +            (nth (registers state#) ~index))
   1.211 +         ([]
   1.212 +            (~name @current-state)))
   1.213 +       (defn ~name-bang
   1.214 +         ~(str "Set the " name " register for state, or "
   1.215 +               "for @current-state if state is absent.")
   1.216 +         ([state# new-register#]
   1.217 +            (set-state! state#)
   1.218 +            (let [registers# (registers state#)]
   1.219 +              (aset registers# ~index new-register#)
   1.220 +              (Gb/writeRegisters registers#)
   1.221 +              (update-state)))
   1.222 +         ([new-register#]
   1.223 +            (~name-bang @current-state new-register#))))))
   1.224 +
   1.225 +;; 16 bit registers
   1.226 +(gen-get-set-register PC 0)
   1.227 +(gen-get-set-register SP 1)
   1.228 +(gen-get-set-register AF 2)
   1.229 +(gen-get-set-register BC 3)
   1.230 +(gen-get-set-register DE 4)
   1.231 +(gen-get-set-register HL 5)
   1.232 +(gen-get-set-register IFF 6)
   1.233 +
   1.234 +;; 8 bit registers
   1.235 +(gen-get-set-register DIV 7)
   1.236 +(gen-get-set-register TIMA 8)
   1.237 +(gen-get-set-register TMA 9)
   1.238 +(gen-get-set-register IF 11)
   1.239 +(gen-get-set-register LCDC 12)
   1.240 +(gen-get-set-register STAT 13)
   1.241 +(gen-get-set-register SCY 14)
   1.242 +(gen-get-set-register SCX 15)
   1.243 +(gen-get-set-register LY 16)
   1.244 +(gen-get-set-register DMA 18)
   1.245 +(gen-get-set-register WY 19)
   1.246 +(gen-get-set-register WX 20)
   1.247 +(gen-get-set-register VBK 21)
   1.248 +(gen-get-set-register HDMA1 22)
   1.249 +(gen-get-set-register HDMA2 23)
   1.250 +(gen-get-set-register HDMA3 24)
   1.251 +(gen-get-set-register HDMA4 25)
   1.252 +(gen-get-set-register HDMA5 26)
   1.253 +(gen-get-set-register SVBK 27)
   1.254 +(gen-get-set-register IE 28)
   1.255 +
   1.256 +;;;;;;;;;;;;;;;
   1.257 +
   1.258 +(defmacro defn-memo
   1.259 +  [& forms]
   1.260 +  (let [fun-name (first forms)]
   1.261 +    `(do
   1.262 +       (defn ~@forms)
   1.263 +       (alter-var-root (var ~fun-name) memoize))))
   1.264 +