Mercurial > vba-clojure

annotate clojure/com/aurellem/run/util.clj @ 536:c2ee7222a3c4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
investigating a problem with bad sound when writing RAM with bootstrapping program
author Robert McIntyre <rlm@mit.edu>
date Mon, 25 Jun 2012 14:23:16 -0500
parents 7c89fe478de4
children
rev   line source
rlm@313 1 (ns com.aurellem.run.util
rlm@314 2 (:use (com.aurellem.gb util gb-driver vbm characters saves))
rlm@313 3 (:import [com.aurellem.gb.gb_driver SaveState]))
rlm@313 4
rlm@313 5 (def ↑ [:u])
rlm@313 6 (def ↓ [:d])
rlm@313 7 (def ← [:l])
rlm@313 8 (def → [:r])
rlm@313 9
rlm@318 10 [↑ ↓ ← →]
rlm@318 11
rlm@327 12 (defn do-nothing [n script]
rlm@327 13 (->> script
rlm@327 14 (play-moves
rlm@327 15 (repeat n []))))
rlm@327 16
rlm@313 17 (defn first-difference
rlm@313 18 [base alt difference-metric [moves root :as script]]
rlm@313 19 (loop [branch-point root
rlm@335 20 actions (vec moves)]
rlm@313 21 (let [base-branch (step branch-point base)
rlm@313 22 base-val (difference-metric base-branch)
rlm@313 23 alt-branch (step branch-point alt)
rlm@313 24 alt-val (difference-metric alt-branch)]
rlm@313 25 (if (not= base-val alt-val)
rlm@313 26 [(conj actions alt) alt-branch]
rlm@313 27 (recur base-branch (conj actions base))))))
rlm@313 28
rlm@313 29 (defn repeat-until-different
rlm@314 30 [buttons metric [moves root :as script]]
rlm@313 31 (let [baseline (metric root)]
rlm@313 32 (loop [actions (vec moves)
rlm@313 33 state root]
rlm@313 34 (let [new-state (step state buttons)
rlm@313 35 new-actions (conj actions buttons)]
rlm@313 36 (if (not= (metric new-state) baseline)
rlm@313 37 [new-actions new-state]
rlm@313 38 (recur new-actions new-state))))))
rlm@313 39
rlm@316 40 (defn binary-search [metric]
rlm@329 41 (loop [low 0
rlm@329 42 high 1]
rlm@329 43 (let [low-val (metric low)
rlm@329 44 high-val (metric high)]
rlm@329 45 (println "(" low high ")")
rlm@329 46 (cond
rlm@329 47 ;; base case
rlm@329 48 (and (= low (dec high))
rlm@329 49 (not= low-val high-val))
rlm@329 50 high
rlm@329 51 ;; exponential growth
rlm@329 52 (= high-val low-val)
rlm@329 53 (recur high (* high 2))
rlm@329 54
rlm@329 55 ;; binary search
rlm@329 56 (not= low-val high-val)
rlm@329 57 (let [test (int (/ (+ low high) 2))
rlm@329 58 test-val (metric test)]
rlm@329 59 (if (= test-val low-val)
rlm@329 60 (recur test high)
rlm@329 61 (recur low test)))))))
rlm@316 62
rlm@328 63
rlm@316 64 (defn delayed-difference
rlm@329 65 "determine the shortest sequence of the form:
rlm@329 66
rlm@329 67 sequence = (concat (repeat n base) alt)
rlm@329 68 which will cause difference-metric
rlm@329 69 to yield a different value between.
rlm@329 70
rlm@329 71 (concat sequence (repeat delay base))
rlm@329 72 and
rlm@329 73 (repeat (+ n 1 delay base))
rlm@329 74
rlm@329 75 This search function is good for finding the optimum keypresses
rlm@329 76 whose effect on the game is not revealed until several frames after
rlm@329 77 those keys have been pressed (such as scrolling text)."
rlm@316 78 [base alt delay difference-metric [moves root :as script]]
rlm@329 79 (let [states-cache (atom {})
rlm@329 80 generator
rlm@329 81 ;; (memoize ;; 32947 msecs
rlm@329 82 ;; (fn gen [n]
rlm@329 83 ;; (run-moves
rlm@329 84 ;; root
rlm@329 85 ;; (repeat n base))))
rlm@329 86
rlm@329 87 (fn gen [n] ;; 21150 msecs
rlm@329 88 (if (= 0 n)
rlm@316 89 root
rlm@329 90 (if-let [cached (@states-cache n)]
rlm@329 91 cached
rlm@329 92 (do (swap!
rlm@329 93 states-cache
rlm@329 94 #(assoc % n
rlm@329 95 (run-moves
rlm@329 96 (gen (dec n))
rlm@329 97 [base])))
rlm@329 98 (gen n)))))
rlm@329 99
rlm@316 100 len
rlm@316 101 (binary-search
rlm@329 102 (memoize
rlm@329 103 (fn [n]
rlm@329 104 (if (= n 0) true
rlm@329 105 (=(difference-metric
rlm@329 106 (run-moves
rlm@329 107 (generator n)
rlm@329 108 (concat [alt] (repeat delay base))))
rlm@329 109 (difference-metric
rlm@329 110 (generator (+ n 1 delay))))))))
rlm@316 111 new-moves (concat moves (repeat len base) [alt])
rlm@316 112 new-state (run-moves (generator len) [alt])]
rlm@316 113 [new-moves new-state]))
rlm@316 114
rlm@313 115 (def x-position-address 0xD361)
rlm@313 116 (def y-position-address 0xD362)
rlm@313 117
rlm@313 118 (defn x-position
rlm@313 119 ([^SaveState state]
rlm@313 120 (aget (memory state) x-position-address))
rlm@313 121 ([] (x-position @current-state)))
rlm@313 122
rlm@313 123 (defn y-position
rlm@313 124 ([^SaveState state]
rlm@313 125 (aget (memory state) y-position-address))
rlm@313 126 ([] (y-position @current-state)))
rlm@313 127
rlm@313 128 (defn move
rlm@313 129 [dir script]
rlm@313 130 (let [current-position-fn
rlm@313 131 (cond (#{← →} dir) x-position
rlm@313 132 (#{↑ ↓} dir) y-position)]
rlm@313 133 (repeat-until-different dir current-position-fn script)))
rlm@313 134
rlm@313 135 (defn walk
rlm@313 136 "Move the character along the given directions."
rlm@313 137 [directions script]
rlm@313 138 (reduce (fn [script dir]
rlm@313 139 (move dir script)) script directions))
rlm@313 140
rlm@313 141 (defn search-string
rlm@320 142 ([^SaveState state string]
rlm@320 143 (let [codes
rlm@320 144 (str->character-codes string)
rlm@320 145 codes-length (count codes)
rlm@320 146 mem (vec (memory state))
rlm@320 147 mem-length (count mem)]
rlm@320 148 (loop [idx 0]
rlm@320 149 (if (< (- mem-length idx) codes-length)
rlm@320 150 nil
rlm@320 151 (if (= (subvec mem idx (+ idx codes-length))
rlm@320 152 codes)
rlm@320 153 idx
rlm@320 154 (recur (inc idx)))))))
rlm@320 155 ([string]
rlm@320 156 (search-string @current-state string)))
rlm@313 157
rlm@314 158 (def text-address 0x9DC1)
rlm@314 159
rlm@314 160 (defn displayed-text
rlm@314 161 ([^SaveState state]
rlm@314 162 (character-codes->str
rlm@314 163 (subvec (vec (memory state))
rlm@329 164 (+ text-address 0)
rlm@329 165 (+ text-address 90))))
rlm@314 166 ([] (displayed-text @current-state)))
rlm@314 167
rlm@314 168 (defn scroll-text
rlm@314 169 ([script]
rlm@314 170 (delayed-difference
rlm@314 171 [:b] [:a :b] 25 displayed-text script))
rlm@314 172 ([n script]
rlm@314 173 (reduce (fn [script _]
rlm@314 174 (scroll-text script))
rlm@314 175 script
rlm@314 176 (range n))))
rlm@314 177
rlm@319 178 (defn end-text
rlm@319 179 ([script]
rlm@320 180 (->>
rlm@320 181 script
rlm@320 182 (do-nothing 150)
rlm@320 183 (play-moves [[:b]]))))
rlm@319 184
rlm@318 185 (defn delayed-improbability-search
rlm@318 186 "insert blank frames before calling script-fn until
rlm@318 187 metric returns true."
rlm@318 188 [delay metric script-fn script]
rlm@318 189 (loop [blanks 0]
rlm@318 190 (let [new-script
rlm@318 191 (->> script
rlm@318 192 (play-moves
rlm@318 193 (concat (repeat blanks [])))
rlm@318 194 script-fn)
rlm@318 195 future-state
rlm@318 196 (run-moves (second new-script)
rlm@318 197 (repeat delay []))
rlm@318 198 result (metric future-state)]
rlm@318 199 (if result
rlm@318 200 (do
rlm@318 201 (println "improbability factor:" blanks)
rlm@318 202 new-script)
rlm@318 203 (recur (inc blanks))))))
rlm@313 204
rlm@313 205 (defn critical-hit
rlm@313 206 "Put the cursor over the desired attack. This program will
rlm@313 207 determine the appropriate amount of blank frames to
rlm@313 208 insert before pressing [:a] to ensure that the attack is
rlm@313 209 a critical hit."
rlm@313 210 [script]
rlm@318 211 (delayed-improbability-search
rlm@318 212 400
rlm@318 213 #(search-string % "Critical")
rlm@318 214 (partial play-moves [[:a][]])
rlm@318 215 script))
rlm@313 216
rlm@313 217 (defn move-thru-grass
rlm@313 218 [direction script]
rlm@318 219 (delayed-improbability-search
rlm@318 220 600
rlm@318 221 #(nil? (search-string % "Wild"))
rlm@318 222 (partial move direction)
rlm@318 223 script))
rlm@313 224
rlm@313 225 (defn walk-thru-grass
rlm@313 226 [directions script]
rlm@313 227 (reduce (fn [script direction]
rlm@313 228 (move-thru-grass direction script))
rlm@313 229 script directions))
rlm@313 230
rlm@313 231 (defn slowly
rlm@313 232 [delay moves script]
rlm@313 233 (reduce
rlm@313 234 (fn [script move]
rlm@313 235 (->> script
rlm@313 236 (do-nothing delay)
rlm@313 237 (play-moves (vector move))))
rlm@313 238 script moves))
rlm@313 239
rlm@313 240 (defn multiple-times
rlm@313 241 ([n command args script]
rlm@313 242 (reduce (fn [script _]
rlm@313 243 (apply command (concat args [script])))
rlm@313 244 script
rlm@313 245 (range n)))
rlm@313 246 ([n command script]
rlm@313 247 (multiple-times n command [] script)))
rlm@376 248
rlm@376 249 (defn write-script!
rlm@376 250 [[moves state :as script] name]
rlm@376 251 [(write-moves! moves name)
rlm@376 252 (write-state! state name)])
rlm@376 253
rlm@376 254 (defn read-script
rlm@376 255 [name]
rlm@376 256 [(read-moves name)
rlm@376 257 (read-state name)])
rlm@376 258