Mercurial > vba-clojure

annotate clojure/com/aurellem/run/util.clj @ 328:35960b03693f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
improved delayed-difference with memoization
author Robert McIntyre <rlm@mit.edu>
date Thu, 05 Apr 2012 15:05:08 -0500
parents fe6fd2323264
children a452deec2882
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@313 20 actions 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@316 41 (let [baseline (metric 0)]
rlm@316 42 (loop [low 1
rlm@316 43 high 2]
rlm@316 44 (let [low-val (metric low)
rlm@316 45 high-val (metric high)]
rlm@316 46 (println low high)
rlm@316 47 (cond
rlm@316 48 ;; base case
rlm@316 49 (and (= low (dec high))
rlm@316 50 (not= low-val high-val))
rlm@316 51 high
rlm@316 52 ;; exponential growth
rlm@316 53 (= baseline high-val low-val)
rlm@316 54 (recur high (* high 2))
rlm@316 55
rlm@316 56 ;; binary search
rlm@316 57 (and (= baseline low-val)
rlm@316 58 (not= baseline high-val))
rlm@316 59 (let [test (int (/ (+ low high) 2))
rlm@316 60 test-val (metric test)]
rlm@316 61 (if (= test-val baseline)
rlm@316 62 (recur test high)
rlm@316 63 (recur low test))))))))
rlm@316 64
rlm@328 65
rlm@316 66 (defn delayed-difference
rlm@316 67 [base alt delay difference-metric [moves root :as script]]
rlm@316 68 (let [generator
rlm@316 69 (memoize
rlm@328 70 (fn gen [n]
rlm@316 71 (run-moves
rlm@316 72 root
rlm@316 73 (repeat n base))))
rlm@316 74 len
rlm@316 75 (binary-search
rlm@328 76 (memoize (fn [n]
rlm@316 77 (= (difference-metric
rlm@316 78 (run-moves
rlm@316 79 (generator n)
rlm@316 80 (concat [alt] (repeat delay base))))
rlm@316 81 (difference-metric
rlm@316 82 (run-moves
rlm@316 83 (generator n)
rlm@328 84 (repeat (inc delay) base)))))))
rlm@316 85 new-moves (concat moves (repeat len base) [alt])
rlm@316 86 new-state (run-moves (generator len) [alt])]
rlm@316 87 [new-moves new-state]))
rlm@316 88
rlm@313 89 (def x-position-address 0xD361)
rlm@313 90 (def y-position-address 0xD362)
rlm@313 91
rlm@313 92 (defn x-position
rlm@313 93 ([^SaveState state]
rlm@313 94 (aget (memory state) x-position-address))
rlm@313 95 ([] (x-position @current-state)))
rlm@313 96
rlm@313 97 (defn y-position
rlm@313 98 ([^SaveState state]
rlm@313 99 (aget (memory state) y-position-address))
rlm@313 100 ([] (y-position @current-state)))
rlm@313 101
rlm@313 102 (defn move
rlm@313 103 [dir script]
rlm@313 104 (let [current-position-fn
rlm@313 105 (cond (#{← →} dir) x-position
rlm@313 106 (#{↑ ↓} dir) y-position)]
rlm@313 107 (repeat-until-different dir current-position-fn script)))
rlm@313 108
rlm@313 109 (defn walk
rlm@313 110 "Move the character along the given directions."
rlm@313 111 [directions script]
rlm@313 112 (reduce (fn [script dir]
rlm@313 113 (move dir script)) script directions))
rlm@313 114
rlm@313 115 (defn search-string
rlm@320 116 ([^SaveState state string]
rlm@320 117 (let [codes
rlm@320 118 (str->character-codes string)
rlm@320 119 codes-length (count codes)
rlm@320 120 mem (vec (memory state))
rlm@320 121 mem-length (count mem)]
rlm@320 122 (loop [idx 0]
rlm@320 123 (if (< (- mem-length idx) codes-length)
rlm@320 124 nil
rlm@320 125 (if (= (subvec mem idx (+ idx codes-length))
rlm@320 126 codes)
rlm@320 127 idx
rlm@320 128 (recur (inc idx)))))))
rlm@320 129 ([string]
rlm@320 130 (search-string @current-state string)))
rlm@313 131
rlm@314 132 (def text-address 0x9DC1)
rlm@314 133
rlm@314 134 (defn displayed-text
rlm@314 135 ([^SaveState state]
rlm@314 136 (character-codes->str
rlm@314 137 (subvec (vec (memory state))
rlm@314 138 text-address
rlm@314 139 (+ text-address 82))))
rlm@314 140 ([] (displayed-text @current-state)))
rlm@314 141
rlm@314 142 (defn scroll-text
rlm@314 143 ([script]
rlm@314 144 (delayed-difference
rlm@314 145 [:b] [:a :b] 25 displayed-text script))
rlm@314 146 ([n script]
rlm@314 147 (reduce (fn [script _]
rlm@314 148 (scroll-text script))
rlm@314 149 script
rlm@314 150 (range n))))
rlm@314 151
rlm@319 152 (defn end-text
rlm@319 153 ([script]
rlm@320 154 (->>
rlm@320 155 script
rlm@320 156 (do-nothing 150)
rlm@320 157 (play-moves [[:b]]))))
rlm@319 158
rlm@318 159 (defn delayed-improbability-search
rlm@318 160 "insert blank frames before calling script-fn until
rlm@318 161 metric returns true."
rlm@318 162 [delay metric script-fn script]
rlm@318 163 (loop [blanks 0]
rlm@318 164 (let [new-script
rlm@318 165 (->> script
rlm@318 166 (play-moves
rlm@318 167 (concat (repeat blanks [])))
rlm@318 168 script-fn)
rlm@318 169 future-state
rlm@318 170 (run-moves (second new-script)
rlm@318 171 (repeat delay []))
rlm@318 172 result (metric future-state)]
rlm@318 173 (if result
rlm@318 174 (do
rlm@318 175 (println "improbability factor:" blanks)
rlm@318 176 new-script)
rlm@318 177 (recur (inc blanks))))))
rlm@313 178
rlm@313 179 (defn critical-hit
rlm@313 180 "Put the cursor over the desired attack. This program will
rlm@313 181 determine the appropriate amount of blank frames to
rlm@313 182 insert before pressing [:a] to ensure that the attack is
rlm@313 183 a critical hit."
rlm@313 184 [script]
rlm@318 185 (delayed-improbability-search
rlm@318 186 400
rlm@318 187 #(search-string % "Critical")
rlm@318 188 (partial play-moves [[:a][]])
rlm@318 189 script))
rlm@313 190
rlm@313 191 (defn move-thru-grass
rlm@313 192 [direction script]
rlm@318 193 (delayed-improbability-search
rlm@318 194 600
rlm@318 195 #(nil? (search-string % "Wild"))
rlm@318 196 (partial move direction)
rlm@318 197 script))
rlm@313 198
rlm@313 199 (defn walk-thru-grass
rlm@313 200 [directions script]
rlm@313 201 (reduce (fn [script direction]
rlm@313 202 (move-thru-grass direction script))
rlm@313 203 script directions))
rlm@313 204
rlm@313 205 (defn slowly
rlm@313 206 [delay moves script]
rlm@313 207 (reduce
rlm@313 208 (fn [script move]
rlm@313 209 (->> script
rlm@313 210 (do-nothing delay)
rlm@313 211 (play-moves (vector move))))
rlm@313 212 script moves))
rlm@313 213
rlm@313 214 (defn multiple-times
rlm@313 215 ([n command args script]
rlm@313 216 (reduce (fn [script _]
rlm@313 217 (apply command (concat args [script])))
rlm@313 218 script
rlm@313 219 (range n)))
rlm@313 220 ([n command script]
rlm@313 221 (multiple-times n command [] script)))