Mercurial > vba-clojure

annotate clojure/com/aurellem/run/util.clj @ 316:d263df762c59

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
greatly speed up scroll-text by using binary-search.
author Robert McIntyre <rlm@mit.edu>
date Mon, 02 Apr 2012 21:20:54 -0500
parents 073600cba28a
children 3c5bf2221ea0
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@313 10 (defn first-difference
rlm@313 11 [base alt difference-metric [moves root :as script]]
rlm@313 12 (loop [branch-point root
rlm@313 13 actions moves]
rlm@313 14 (let [base-branch (step branch-point base)
rlm@313 15 base-val (difference-metric base-branch)
rlm@313 16 alt-branch (step branch-point alt)
rlm@313 17 alt-val (difference-metric alt-branch)]
rlm@313 18 (if (not= base-val alt-val)
rlm@313 19 [(conj actions alt) alt-branch]
rlm@313 20 (recur base-branch (conj actions base))))))
rlm@313 21
rlm@313 22 (defn repeat-until-different
rlm@314 23 [buttons metric [moves root :as script]]
rlm@313 24 (let [baseline (metric root)]
rlm@313 25 (loop [actions (vec moves)
rlm@313 26 state root]
rlm@313 27 (let [new-state (step state buttons)
rlm@313 28 new-actions (conj actions buttons)]
rlm@313 29 (if (not= (metric new-state) baseline)
rlm@313 30 [new-actions new-state]
rlm@313 31 (recur new-actions new-state))))))
rlm@313 32
rlm@316 33
rlm@316 34 (defn binary-search [metric]
rlm@316 35 (let [baseline (metric 0)]
rlm@316 36 (loop [low 1
rlm@316 37 high 2]
rlm@316 38 (let [low-val (metric low)
rlm@316 39 high-val (metric high)]
rlm@316 40 (println low high)
rlm@316 41 (cond
rlm@316 42 ;; base case
rlm@316 43 (and (= low (dec high))
rlm@316 44 (not= low-val high-val))
rlm@316 45 high
rlm@316 46 ;; exponential growth
rlm@316 47 (= baseline high-val low-val)
rlm@316 48 (recur high (* high 2))
rlm@316 49
rlm@316 50 ;; binary search
rlm@316 51 (and (= baseline low-val)
rlm@316 52 (not= baseline high-val))
rlm@316 53 (let [test (int (/ (+ low high) 2))
rlm@316 54 test-val (metric test)]
rlm@316 55 (if (= test-val baseline)
rlm@316 56 (recur test high)
rlm@316 57 (recur low test))))))))
rlm@316 58
rlm@316 59 (defn delayed-difference
rlm@316 60 [base alt delay difference-metric [moves root :as script]]
rlm@316 61 (let [generator
rlm@316 62 (memoize
rlm@316 63 (fn [n]
rlm@316 64 (run-moves
rlm@316 65 root
rlm@316 66 (repeat n base))))
rlm@316 67 len
rlm@316 68 (binary-search
rlm@316 69 (fn [n]
rlm@316 70 (= (difference-metric
rlm@316 71 (run-moves
rlm@316 72 (generator n)
rlm@316 73 (concat [alt] (repeat delay base))))
rlm@316 74 (difference-metric
rlm@316 75 (run-moves
rlm@316 76 (generator n)
rlm@316 77 (repeat (inc delay) base))))))
rlm@316 78 new-moves (concat moves (repeat len base) [alt])
rlm@316 79 new-state (run-moves (generator len) [alt])]
rlm@316 80 [new-moves new-state]))
rlm@316 81
rlm@314 82 (defn delayed-difference
rlm@314 83 [base alt delay difference-metric [moves root :as script]]
rlm@314 84 (loop [branch-point root
rlm@314 85 actions moves]
rlm@314 86 (let [base-branch (step branch-point base)
rlm@314 87 base-val
rlm@314 88 (difference-metric
rlm@314 89 (run-moves base-branch
rlm@314 90 (repeat delay base)))
rlm@314 91 alt-branch (step branch-point alt)
rlm@314 92 alt-val
rlm@314 93 (difference-metric
rlm@314 94 (run-moves alt-branch
rlm@314 95 (repeat delay base)))]
rlm@314 96 (if (not= base-val alt-val)
rlm@314 97 [(conj actions alt) alt-branch]
rlm@314 98 (recur base-branch (conj actions base))))))
rlm@313 99
rlm@313 100
rlm@316 101
rlm@316 102
rlm@316 103
rlm@316 104
rlm@314 105
rlm@313 106 ;; (defn advance
rlm@313 107 ;; ([base alt difference-metric [commands state]]
rlm@313 108 ;; (let [[c s]
rlm@313 109 ;; (first-difference base alt difference-metric state)]
rlm@313 110 ;; [(concat commands c) s]))
rlm@313 111 ;; ([base alt [commands state]]
rlm@313 112 ;; (advance base alt AF [commands state]))
rlm@313 113 ;; ([alt [commands state]]
rlm@313 114 ;; (advance [] alt [commands state])))
rlm@313 115
rlm@313 116
rlm@313 117 (def x-position-address 0xD361)
rlm@313 118 (def y-position-address 0xD362)
rlm@313 119
rlm@313 120 (defn x-position
rlm@313 121 ([^SaveState state]
rlm@313 122 (aget (memory state) x-position-address))
rlm@313 123 ([] (x-position @current-state)))
rlm@313 124
rlm@313 125 (defn y-position
rlm@313 126 ([^SaveState state]
rlm@313 127 (aget (memory state) y-position-address))
rlm@313 128 ([] (y-position @current-state)))
rlm@313 129
rlm@313 130 (defn move
rlm@313 131 [dir script]
rlm@313 132 (let [current-position-fn
rlm@313 133 (cond (#{← →} dir) x-position
rlm@313 134 (#{↑ ↓} dir) y-position)]
rlm@313 135 (repeat-until-different dir current-position-fn script)))
rlm@313 136
rlm@313 137 (defn walk
rlm@313 138 "Move the character along the given directions."
rlm@313 139 [directions script]
rlm@313 140 (reduce (fn [script dir]
rlm@313 141 (move dir script)) script directions))
rlm@313 142
rlm@313 143 (defn menu
rlm@313 144 [directions script]
rlm@313 145 (reduce (fn [script direction]
rlm@313 146 (move direction script))
rlm@313 147 script directions))
rlm@313 148
rlm@313 149
rlm@313 150 (defn search-string
rlm@314 151 [^SaveState state string]
rlm@313 152 (let [codes
rlm@313 153 (str->character-codes string)
rlm@313 154 codes-length (count codes)
rlm@314 155 mem (vec (memory state))
rlm@313 156 mem-length (count mem)]
rlm@313 157 (loop [idx 0]
rlm@313 158 (if (< (- mem-length idx) codes-length)
rlm@313 159 nil
rlm@313 160 (if (= (subvec mem idx (+ idx codes-length))
rlm@313 161 codes)
rlm@313 162 idx
rlm@313 163 (recur (inc idx)))))))
rlm@313 164
rlm@314 165 (def text-address 0x9DC1)
rlm@314 166
rlm@314 167 (defn displayed-text
rlm@314 168 ([^SaveState state]
rlm@314 169 (character-codes->str
rlm@314 170 (subvec (vec (memory state))
rlm@314 171 text-address
rlm@314 172 (+ text-address 82))))
rlm@314 173 ([] (displayed-text @current-state)))
rlm@314 174
rlm@314 175 ;; (defn scroll-text
rlm@314 176 ;; ([script]
rlm@314 177 ;; (first-difference [:b] [:a :b] AF script))
rlm@314 178 ;; ([n script]
rlm@314 179 ;; (reduce (fn [script _]
rlm@314 180 ;; (scroll-text script))
rlm@314 181 ;; script
rlm@314 182 ;; (range n))))
rlm@314 183
rlm@314 184 (defn scroll-text
rlm@314 185 ([script]
rlm@314 186 (delayed-difference
rlm@314 187 [:b] [:a :b] 25 displayed-text script))
rlm@314 188 ([n script]
rlm@314 189 (reduce (fn [script _]
rlm@314 190 (scroll-text script))
rlm@314 191 script
rlm@314 192 (range n))))
rlm@314 193
rlm@314 194
rlm@314 195 (defn end-text [script]
rlm@314 196 (->> script
rlm@314 197 (scroll-text)
rlm@314 198 (play-moves [[] [:a]])))
rlm@314 199
rlm@314 200
rlm@314 201
rlm@316 202 (memory-compare
rlm@316 203 (step (talk-to-oak) [:a])
rlm@316 204 (step (talk-to-oak) [])
rlm@316 205 (step (oak-battle) [])
rlm@316 206 (step (oak-battle) [:a]))
rlm@316 207
rlm@314 208
rlm@314 209
rlm@314 210
rlm@314 211
rlm@313 212
rlm@313 213 (defn do-nothing [n script]
rlm@313 214 (->> script
rlm@313 215 (play-moves
rlm@313 216 (repeat n []))))
rlm@313 217
rlm@313 218
rlm@313 219 (defn critical-hit
rlm@313 220 "Put the cursor over the desired attack. This program will
rlm@313 221 determine the appropriate amount of blank frames to
rlm@313 222 insert before pressing [:a] to ensure that the attack is
rlm@313 223 a critical hit."
rlm@313 224 [script]
rlm@313 225 (loop [blanks 6]
rlm@313 226 (let [new-script
rlm@313 227 (->> script
rlm@313 228 (play-moves
rlm@313 229 (concat (repeat blanks [])
rlm@313 230 [[:a][]])))]
rlm@313 231 (if (let [future-state
rlm@313 232 (run-moves (second new-script)
rlm@313 233 (repeat 400 []))
rlm@313 234
rlm@313 235 result (search-string (memory future-state)
rlm@313 236 "Critical")]
rlm@313 237 (if result
rlm@313 238 (println "critical hit with" blanks "blank frames"))
rlm@313 239 result)
rlm@313 240 new-script
rlm@313 241 (recur (inc blanks))))))
rlm@313 242
rlm@313 243 (defn move-thru-grass
rlm@313 244 [direction script]
rlm@313 245 (loop [blanks 0]
rlm@313 246 (let [new-script
rlm@313 247 (->> script
rlm@313 248 (play-moves (repeat blanks []))
rlm@313 249 (move direction))
rlm@313 250
rlm@313 251 future-state
rlm@313 252 (run-moves (second new-script)
rlm@313 253 (repeat 600 []))
rlm@313 254
rlm@313 255 result (search-string (memory future-state)
rlm@313 256 "Wild")]
rlm@313 257 (if (nil? result)
rlm@313 258 (do
rlm@313 259 (if (< 0 blanks)
rlm@313 260 (do
rlm@313 261 (println "avoided pokemon with"
rlm@313 262 blanks "blank frames")))
rlm@313 263 new-script)
rlm@313 264 (recur (inc blanks))))))
rlm@313 265
rlm@313 266 (defn walk-thru-grass
rlm@313 267 [directions script]
rlm@313 268 (reduce (fn [script direction]
rlm@313 269 (move-thru-grass direction script))
rlm@313 270 script directions))
rlm@313 271
rlm@313 272 (defn slowly
rlm@313 273 [delay moves script]
rlm@313 274 (reduce
rlm@313 275 (fn [script move]
rlm@313 276 (->> script
rlm@313 277 (do-nothing delay)
rlm@313 278 (play-moves (vector move))))
rlm@313 279 script moves))
rlm@313 280
rlm@313 281 (defn multiple-times
rlm@313 282 ([n command args script]
rlm@313 283 (reduce (fn [script _]
rlm@313 284 (apply command (concat args [script])))
rlm@313 285 script
rlm@313 286 (range n)))
rlm@313 287 ([n command script]
rlm@313 288 (multiple-times n command [] script)))