vba-clojure-helpers

helpers.clj

(defn first-change
  "Watch the current memory location as it ticks,
return the first state that differs at location mem."-
  [state n]
  (tick state)
  (set-state! state)
  (let [init (aget (memory state) n)] 
    (loop []
      (if (= (aget (memory) n) init)
        (do 
          (com.aurellem.gb.Gb/tick)
          (recur))))
    (update-state)))

(defn pc-diff
  "Return the differences between the program counter evolution
between the two states (measured for 10000 ticks)."
  [state-1 state-2]
  (differences (map hex (pc-trail state-1 10000))
               (map hex (pc-trail state-2 10000))))

(defn search-memory
  "Search for the given codes in memory, returning short snippets of
text around the results."
  ([codes k]
     (search-memory com.aurellem.gb.gb-driver/original-rom codes k))
  ([array codes k]
     (map
      (fn [n]
        [(hex n)
         (take k (drop n array))])
------
      (find-sublists
       array
       codes))))

(defn pc-trail
  "Track the PC for a number of ticks."
  [state ticks]
  (tick state)
  (set-state! state)
  (loop [pcs [(PC)] ]
    (if (> (count pcs) ticks) pcs
        (do
          (com.aurellem.gb.Gb/tick)
          (recur (conj pcs (PC)))))))

(defn pre-wild-battle []
  (read-state "prepare-for-battle"))

(defn pre-trainer-battle []
  (read-state "pre-trainer-battle"))

(defn rlm-pallet-town []
  (read-state "rlm-pallet-town"))

(defn talk-to-oak []
  (read-state "talk-to-oak"))

(defn view-register [state name reg-fn]
  (println (format "%s: %s" name
                   (binary-str (reg-fn state))))
  state)

(defn set-state! [^SaveState state]
  (assert (:data state) "Not a valid state!")
  (if (not @on?) (restart!))
  (if (not= state @current-state)
    (do
      (Gb/loadState (:data state))
      (reset! current-state state))))

(defn update-state []
  (reset! current-state
          (SaveState. (Gb/saveState))))

(defn step
  ([^SaveState state buttons]
     (set-state! state)
     (Gb/step (button-mask buttons))
     (reset! current-state
             (SaveState. (Gb/saveState))))
  ([^SaveState state]
     (step state [:listen]))
  ([] (step (if @current-state @current-state (root)))))

(defn tick
  ([] (tick @current-state))
  ([^SaveState state]
     (set-state! state)
     (Gb/tick)
     (update-state)))

(defn play
  ([^SaveState state n]
     (try
       (set-state! state)
       (dorun (dotimes [_ n]
                (Thread/sleep 1)
                (Gb/step)))
       (finally
             (update-state))))
  ([n]
     (play @current-state n)))

(defn continue!
  ([state]
     (play state Integer/MAX_VALUE))
  ([]
    (continue! @current-state)))

;;;;;;;;;;;

;; Get Screen Pixels, Save Screenshot

(defn write-png!
  ([^SaveState state ^File target]
     (set-state! state)
     (Gb/nwritePNG (.getCanonicalPath target)))
  ([^File target]
     (write-png! @current-state target)))

;;;;;;;;;;; CPU data

(defn cpu-data [size arr-fn]
  (let [store (int-array size)]
    (fn get-data
      ([] (get-data @current-state))
      ([state]
         (set-state! state) (arr-fn store) store))))

(defn write-cpu-data [size store-fn]
  (fn store-data
    ([state new-data]
       (set-state! state)
       (let [store (int-array new-data)]
         (assert (= size (count new-data)))
         (store-fn store)
         (update-state)))
    ([new-data]
       (store-data @current-state new-data))))

(def gb-sound-format
  "44100 hertz, linear PCM, 2 channels with 16 bits per sample."
  (AudioFormat. 44100 16 2 true false))

(let [store (byte-array Gb/MAX_SOUND_BYTES)]
  (defn sound-bytes
    "Returns a byte array containting the sound samples
     generated this step."
    ([](sound-bytes @current-state))
    ([state]
       (set-state! state)
       (Gb/getFrameSound store)
       (let [actual-bytes (* 2 (Gb/getSoundFrameWritten))]
         (Gb/setSoundFrameWritten 0)
         (byte-array (take actual-bytes store))))))

(def memory
  (cpu-data Gb/GB_MEMORY #(Gb/getMemory %)))

(def ram
  (cpu-data Gb/RAM_SIZE #(Gb/getRAM %)))

(def rom
  (cpu-data Gb/ROM_SIZE #(Gb/getROM %)))

(def working-ram
  (cpu-data Gb/WRAM_SIZE #(Gb/getWRAM %)))

(def video-ram
  (cpu-data Gb/VRAM_SIZE #(Gb/getVRAM %)))

(def registers
  (cpu-data Gb/NUM_REGISTERS #(Gb/getRegisters %)))

(def pixels
  (cpu-data (* Gb/DISPLAY_WIDTH Gb/DISPLAY_HEIGHT)
            #(Gb/getPixels %)))

(def write-memory!
  (write-cpu-data Gb/GB_MEMORY #(Gb/writeMemory %)))

(def write-registers!
  (write-cpu-data Gb/NUM_REGISTERS #(Gb/writeRegisters %)))

(def write-rom!
  (write-cpu-data Gb/ROM_SIZE #(Gb/writeROM %)))

(defmacro gen-get-set-register [name index]
  (let [name-bang (symbol (str name "!"))]
    `(do
       (defn ~name
         ~(str "Retrieve the " name " register from state, or "
               "from @current-state if state is absent.")
         ([state#]
            (nth (registers state#) ~index))
         ([]
            (~name @current-state)))
       (defn ~name-bang
         ~(str "Set the " name " register for state, or "
               "for @current-state if state is absent.")
         ([state# new-register#]
            (set-state! state#)
            (let [registers# (registers state#)]
              (aset registers# ~index new-register#)
              (Gb/writeRegisters registers#)
              (update-state)))
         ([new-register#]
            (~name-bang @current-state new-register#))))))

(defn delayed-difference
  "determine the shortest sequence of the form:

   sequence = (concat (repeat n base) alt)
    which will cause difference-metric
   to yield a different value between.

   (concat sequence (repeat delay base))
   and 
   (repeat (+ n 1 delay base))

   This search function is good for finding the optimum keypresses
   whose effect on the game is not revealed until several frames after
   those keys have been pressed (such as scrolling text)."
  [base alt delay difference-metric [moves root :as script]]
  (let [states-cache (atom {}) 
        generator-
        ;; (memoize  ;; 32947 msecs
        ;;  (fn gen [n]-
        ;;    (run-moves
        ;;     root
        ;;     (repeat n base))))

        (fn gen [n]  ;; 21150 msecs
          (if (= 0 n)
            root
            (if-let [cached (@states-cache n)] 
              cached
              (do (swap!
                   states-cache
                   #(assoc % n 
                           (run-moves
                            (gen (dec n)) 
                            [base])))
                  (gen n)))))
------------
        len 
        (binary-search
         (memoize
          (fn [n] 
            (if (= n 0) true
                (=(difference-metric
                   (run-moves
                    (generator n)
                    (concat [alt] (repeat delay base))))
                  (difference-metric
                    (generator (+ n 1 delay))))))))
        new-moves (concat moves (repeat len base) [alt])
        new-state (run-moves (generator len) [alt])]
    [new-moves new-state]))

(defn move-thru-grass
  [direction script]
  (delayed-improbability-search
   600 
   #(nil? (search-string % "Wild"))
   (partial move direction)
   script))

(defn walk-
  "Move the character along the given directions."
  [directions script]
  (reduce (fn [script dir]
            (move dir script)) script directions))

(def x-position-address 0xD361)
(def y-position-address 0xD362)

(defn x-position
  ([^SaveState state]
     (aget (memory state) x-position-address))
  ([] (x-position @current-state)))

(defn y-position
  ([^SaveState state]
     (aget (memory state) y-position-address))
  ([] (y-position @current-state)))

(defn move
  [dir script]
  (let [current-position-fn
        (cond (#{← →} dir) x-position
              (#{↑ ↓} dir) y-position)]
    (repeat-until-different dir current-position-fn script)))