Mercurial > vba-clojure

annotate clojure/com/aurellem/run/util.clj @ 407:03ade2a04458

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Astoundingly, it is not generally possible to convert decimal representations into hexadecimal simply by prepending 0x.
author Dylan Holmes <ocsenave@gmail.com>
date Thu, 12 Apr 2012 22:30:03 -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