Mercurial > vba-clojure

annotate clojure/com/aurellem/run/bootstrap_0.clj @ 305:7998b1cf18cf

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
improve testing program
author Robert McIntyre <rlm@mit.edu>
date Sat, 31 Mar 2012 00:41:28 -0500
parents fefe5ce49b21
children 8e63b0bb8ea3
rev   line source
rlm@247 1 (ns com.aurellem.run.bootstrap-0
rlm@284 2 (:use (com.aurellem.gb gb-driver util items vbm characters money))
rlm@250 3 (:use (com.aurellem.run title save-corruption))
rlm@264 4 (:use (com.aurellem.exp item-bridge))
rlm@264 5 (:import [com.aurellem.gb.gb_driver SaveState]))
rlm@247 6
rlm@250 7 (defn-memo boot-root []
rlm@255 8 [ [] (root)])
rlm@247 9
rlm@255 10 (defn-memo to-rival-name
rlm@255 11 ([] (to-rival-name (boot-root)))
rlm@255 12 ([script]
rlm@255 13 (-> script
rlm@255 14 title
rlm@255 15 oak
rlm@255 16 name-entry-rlm
rlm@255 17 scroll-text
rlm@255 18 scroll-text
rlm@255 19 scroll-text
rlm@255 20 scroll-text
rlm@274 21 scroll-text)))
rlm@247 22
rlm@255 23 (defn-memo name-rival-bootstrap
rlm@255 24 ([] (name-rival-bootstrap (to-rival-name)))
rlm@255 25 ([script]
rlm@255 26 (->> script
rlm@255 27 (advance [] [:a])
rlm@255 28 (advance [] [:r] DE)
rlm@255 29 (play-moves
rlm@255 30 [[]
rlm@255 31 [:r] [] [:r] [] [:r] [] [:r] []
rlm@255 32 [:r] [] [:r] [] [:r] [] [:d] []
rlm@255 33 [:d] [:a] ;; space
rlm@255 34 [:l] [] [:d] [:a] ;; [PK]
rlm@255 35 [:u] [] [:u] [] [:u] [] [:l] [:a] ;; G
rlm@255 36 [:d] [] [:d] [] [:d] [] [:r] [:a] ;; [PK]
rlm@255 37 [:u] [] [:u] [] [:u] [] [:l] [:a] ;; G
rlm@255 38 [:d] [] [:d] [] [:d] [] [:r] [:a] ;; [PK]
rlm@247 39
rlm@255 40 [:d] [] [:r] [:a] ;; finish
rlm@255 41 ]))))
rlm@255 42
rlm@255 43 (defn walk
rlm@255 44 "Move the character along the given directions."
rlm@255 45 [directions script]
rlm@255 46 (reduce (fn [script direction]
rlm@255 47 (move direction script))
rlm@255 48 script directions))
rlm@255 49
rlm@255 50 (def ↑ [:u])
rlm@255 51 (def ↓ [:d])
rlm@255 52 (def ← [:l])
rlm@255 53 (def → [:r])
rlm@255 54
rlm@255 55 (defn-memo leave-house
rlm@255 56 ([] (leave-house (name-rival-bootstrap)))
rlm@255 57 ([script]
rlm@255 58 (->> script
rlm@255 59 finish-title
rlm@255 60 start-walking
rlm@255 61 walk-to-stairs
rlm@255 62 walk-to-door
rlm@255 63 (walk [↓ ↓]))))
rlm@255 64
rlm@255 65 (defn-memo to-pallet-town-edge
rlm@255 66 ([] (to-pallet-town-edge (leave-house)))
rlm@255 67 ([script]
rlm@255 68 (->> script
rlm@255 69 start-walking
rlm@255 70 (walk [→ → → → →
rlm@255 71 ↑ ↑ ↑ ↑ ↑ ↑]))))
rlm@255 72
rlm@257 73 (defn end-text [script]
rlm@257 74 (->> script
rlm@257 75 (scroll-text)
rlm@257 76 (play-moves [[] [:a]])))
rlm@257 77
rlm@257 78 (defn-memo start-pikachu-battle
rlm@257 79 ([] (start-pikachu-battle
rlm@257 80 (to-pallet-town-edge)))
rlm@257 81 ([script]
rlm@257 82 (->> script
rlm@257 83 (advance [:b] [:b :a] DE)
rlm@257 84 (scroll-text)
rlm@257 85 (play-moves [[:b]])
rlm@257 86 (scroll-text)
rlm@257 87 (end-text) ;; battle begins
rlm@257 88 (scroll-text))))
rlm@257 89
rlm@257 90 (defn-memo capture-pikachu
rlm@257 91 ([] (capture-pikachu (start-pikachu-battle)))
rlm@257 92 ([script]
rlm@257 93 (->> script
rlm@257 94 (scroll-text 2)
rlm@257 95 (end-text))))
rlm@257 96
rlm@257 97 (defn-memo go-to-lab
rlm@257 98 ([] (go-to-lab (capture-pikachu)))
rlm@257 99 ([script]
rlm@257 100 (->> script
rlm@257 101 (scroll-text 5)
rlm@257 102 (end-text)
rlm@257 103 (scroll-text)
rlm@257 104 (end-text)
rlm@257 105 (scroll-text 8)
rlm@257 106 (end-text)
rlm@257 107 (scroll-text)
rlm@257 108 (end-text))))
rlm@257 109
rlm@257 110 (defn-memo obtain-pikachu
rlm@257 111 ([] (obtain-pikachu (go-to-lab)))
rlm@257 112 ([script]
rlm@257 113 (->> script
rlm@257 114 (scroll-text)
rlm@257 115 (play-moves
rlm@257 116 (concat
rlm@257 117 (repeat 51 [])
rlm@257 118 [[:a] []]))
rlm@257 119 (walk [↓ ↓ → → ↑])
rlm@258 120 (play-moves
rlm@258 121 (concat [[] [:a]]
rlm@258 122 (repeat 100 [])))
rlm@258 123 (scroll-text 9)
rlm@258 124 (end-text)
rlm@258 125 (scroll-text 7)
rlm@258 126
rlm@258 127 (play-moves
rlm@258 128 (concat
rlm@258 129 (repeat 42 [])
rlm@260 130 [[:b] [:b] [:b] [:b]])))))
rlm@258 131
rlm@258 132 (defn-memo begin-battle-with-rival
rlm@258 133 ([] (begin-battle-with-rival
rlm@258 134 (obtain-pikachu)))
rlm@258 135 ([script]
rlm@258 136 (->> script
rlm@260 137 (walk [↓ ↓ ↓ ↓])
rlm@260 138 (scroll-text 3)
rlm@260 139 (end-text)
rlm@260 140 (scroll-text))))
rlm@260 141
rlm@260 142 (defn search-string
rlm@260 143 [array string]
rlm@260 144 (let [codes
rlm@260 145 (str->character-codes string)
rlm@260 146 codes-length (count codes)
rlm@260 147 mem (vec array)
rlm@260 148 mem-length (count mem)]
rlm@260 149 (loop [idx 0]
rlm@260 150 (if (< (- mem-length idx) codes-length)
rlm@260 151 nil
rlm@260 152 (if (= (subvec mem idx (+ idx codes-length))
rlm@260 153 codes)
rlm@260 154 idx
rlm@260 155 (recur (inc idx)))))))
rlm@260 156
rlm@260 157 (defn critical-hit
rlm@260 158 "Put the cursor over the desired attack. This program will
rlm@260 159 determine the appropriate amount of blank frames to
rlm@260 160 insert before pressing [:a] to ensure that the attack is
rlm@260 161 a critical hit."
rlm@260 162 [script]
rlm@260 163 (loop [blanks 6]
rlm@260 164 (let [new-script
rlm@260 165 (->> script
rlm@260 166 (play-moves
rlm@260 167 (concat (repeat blanks [])
rlm@260 168 [[:a][]])))]
rlm@260 169 (if (let [future-state
rlm@260 170 (run-moves (second new-script)
rlm@260 171 (repeat 400 []))
rlm@260 172
rlm@260 173 result (search-string (memory future-state)
rlm@260 174 "Critical")]
rlm@260 175 (if result
rlm@260 176 (println "critical hit with" blanks "blank frames"))
rlm@260 177 result)
rlm@260 178 new-script
rlm@260 179 (recur (inc blanks))))))
rlm@260 180
rlm@260 181 (defn-memo battle-with-rival
rlm@260 182 ([] (battle-with-rival
rlm@260 183 (begin-battle-with-rival)))
rlm@260 184 ([script]
rlm@260 185 (->> script
rlm@260 186 (play-moves (repeat 381 []))
rlm@260 187 (play-moves [[:a]])
rlm@260 188 (critical-hit)
rlm@260 189 (play-moves (repeat 100 []))
rlm@260 190 (scroll-text)
rlm@258 191 (play-moves
rlm@260 192 (concat (repeat 275 []) [[:a]]))
rlm@260 193 (critical-hit)
rlm@260 194 (play-moves (repeat 100 []))
rlm@260 195 (scroll-text)
rlm@258 196 (play-moves
rlm@260 197 (concat (repeat 270 []) [[:a]]))
rlm@260 198 (play-moves [[][][][][][][][][:a]]))))
rlm@260 199
rlm@260 200 (defn-memo finish-rival-text
rlm@260 201 ([] (finish-rival-text
rlm@260 202 (battle-with-rival)))
rlm@260 203 ([script]
rlm@260 204 (->> script
rlm@260 205 (scroll-text 2)
rlm@260 206 (end-text)
rlm@260 207 (scroll-text 9)
rlm@260 208 (end-text))))
rlm@260 209
rlm@262 210 (defn do-nothing [n script]
rlm@262 211 (->> script
rlm@262 212 (play-moves
rlm@262 213 (repeat n []))))
rlm@260 214
rlm@262 215 (defn-memo pikachu-comes-out
rlm@262 216 ([] (pikachu-comes-out
rlm@262 217 (finish-rival-text)))
rlm@262 218 ([script]
rlm@262 219 (->> script
rlm@262 220 (do-nothing 177)
rlm@262 221 (end-text)
rlm@262 222 (scroll-text 7)
rlm@262 223 (end-text))))
rlm@260 224
rlm@262 225 (defn-memo leave-oaks-lab
rlm@262 226 ([] (leave-oaks-lab
rlm@262 227 (pikachu-comes-out)))
rlm@262 228 ([script]
rlm@262 229 (->> script
rlm@262 230 (walk [← ← ↓ ↓ ↓ ↓ ↓ ↓]))))
rlm@257 231
rlm@271 232 (defn-memo oaks-lab->pallet-town-edge
rlm@262 233 ([] (oaks-lab->pallet-town-edge
rlm@262 234 (leave-oaks-lab)))
rlm@262 235 ([script]
rlm@262 236 (->> script
rlm@262 237 (walk [← ← ← ←
rlm@262 238 ↑ ↑ ↑ ↑
rlm@262 239 ↑ ↑ ↑ ↑ ↑ ↑
rlm@262 240 → ↑]))))
rlm@264 241
rlm@264 242 (defn move-thru-grass
rlm@264 243 [direction script]
rlm@264 244 (loop [blanks 0]
rlm@264 245 (let [new-script
rlm@264 246 (->> script
rlm@264 247 (play-moves (repeat blanks []))
rlm@264 248 (move direction))
rlm@264 249
rlm@264 250 future-state
rlm@264 251 (run-moves (second new-script)
rlm@264 252 (repeat 600 []))
rlm@264 253
rlm@264 254 result (search-string (memory future-state)
rlm@264 255 "Wild")]
rlm@264 256 (if (nil? result)
rlm@278 257 (do
rlm@278 258 (if (< 0 blanks)
rlm@278 259 (do(println "avoided pokemon with" blanks "blank frames")))
rlm@278 260 new-script)
rlm@264 261 (recur (inc blanks))))))
rlm@264 262
rlm@264 263 (defn walk-thru-grass
rlm@264 264 [directions script]
rlm@264 265 (reduce (fn [script direction]
rlm@264 266 (move-thru-grass direction script))
rlm@264 267 script directions))
rlm@264 268
rlm@264 269 (defn-memo pallet-edge->viridian-mart
rlm@271 270 ([] (pallet-edge->viridian-mart true
rlm@264 271 (oaks-lab->pallet-town-edge)))
rlm@271 272 ([dodge-stupid-guy? script]
rlm@271 273 (let [dodge-1 (if dodge-stupid-guy?
rlm@271 274 [→ →]
rlm@271 275 [→])
rlm@271 276 dodge-2 (if dodge-stupid-guy?
rlm@271 277 [↑ ↑ ←]
rlm@271 278 [↑ ↑ ←])]
rlm@271 279
rlm@271 280 (->> script
rlm@264 281 ;; leave straight grass
rlm@264 282 (walk-thru-grass
rlm@264 283 [↑ ↑ ↑ ↑ ↑])
rlm@264 284
rlm@264 285 (walk [↑ ↑ ↑ ↑])
rlm@264 286
rlm@264 287 (walk-thru-grass
rlm@264 288 [← ← ↑])
rlm@264 289 (walk [↑ ↑ ↑ ↑ → → → ])
rlm@264 290
rlm@264 291 (walk-thru-grass
rlm@264 292 [→ ↑ ↑ ←])
rlm@264 293
rlm@264 294 (walk
rlm@264 295 [← ←
rlm@264 296 ↑ ↑ ↑ ↑ ↑ ↑ ↑ ↑
rlm@264 297 → → → → ])
rlm@264 298
rlm@271 299 ;; this part is dependent on that
rlm@266 300 ;; stupid NPC in the grass patch
rlm@264 301 (walk-thru-grass
rlm@271 302 (concat dodge-1
rlm@271 303 [↑ ↑ ↑ ↑ ↑ ↑ ↑ ↑ ]))
rlm@271 304
rlm@264 305 (walk
rlm@271 306 (concat
rlm@271 307 dodge-2
rlm@271 308 [← ← ←
rlm@271 309 ↑ ↑ ↑ ↑ ↑ ↑ ↑ ↑ ↑ ↑
rlm@271 310 ← ←
rlm@271 311 ↑ ↑ ↑ ↑
rlm@271 312 → → → → → → → → → →
rlm@271 313 ↑ ↑ ↑ ↑ ↑ ↑ ↑]))))))
rlm@264 314
rlm@266 315 (defn-memo get-oaks-parcel
rlm@266 316 ([] (get-oaks-parcel
rlm@266 317 (pallet-edge->viridian-mart)))
rlm@266 318 ([script]
rlm@266 319 (->> script
rlm@266 320 (end-text)
rlm@266 321 (scroll-text 3)
rlm@266 322 (do-nothing 197)
rlm@266 323 (play-moves [[:a] []])
rlm@266 324 (walk [↓ ↓ → ↓]))))
rlm@266 325
rlm@269 326 (defn-memo viridian-store->oaks-lab
rlm@269 327 ([] (viridian-store->oaks-lab
rlm@269 328 (get-oaks-parcel)))
rlm@269 329 ([script]
rlm@269 330 (->> script
rlm@269 331 (walk [↓ ↓ ↓ ↓ ↓ ↓ ↓ ↓ ↓ ↓
rlm@269 332 ← ← ← ← ← ← ← ← ← ←
rlm@269 333 ↓ ↓ ↓ ↓ ↓ ↓ ↓ ↓
rlm@269 334 ← ←
rlm@269 335 ↓ ↓ ↓ ↓ ↓ ↓ ↓ ↓
rlm@269 336 ↓ ↓ ↓ ↓ ↓ ↓ ↓
rlm@269 337 → → → → → → → →
rlm@269 338 ↓ ↓ ↓ ↓
rlm@269 339 ← ← ← ← ←
rlm@269 340 ↓ ↓ ↓ ↓])
rlm@266 341
rlm@269 342 (walk-thru-grass
rlm@269 343 [↓ ↓ ↓ ↓ ↓ ↓ ↓])
rlm@269 344
rlm@269 345 (walk [↓ ↓ ← ↓ ↓ ↓ ←
rlm@269 346 ↓ ↓ ↓ ↓ ↓
rlm@269 347 → → → ↑]))))
rlm@269 348
rlm@269 349 (defn-memo viridian-store->oaks-lab-like-a-boss
rlm@269 350 ([] (viridian-store->oaks-lab-like-a-boss
rlm@269 351 (get-oaks-parcel)))
rlm@269 352 ([script]
rlm@269 353 (->> script
rlm@269 354 (walk [↓ ↓ ↓ ↓ ↓ ↓ ↓ ↓ ↓ ↓
rlm@269 355 ← ← ← ← ← ← ← ← ← ←
rlm@269 356 ↓ ↓ ↓ ↓ ↓ ↓ ↓ ↓ ↓])
rlm@269 357
rlm@269 358 (walk-thru-grass
rlm@269 359 [↓ ↓ ↓ ↓ ↓])
rlm@269 360
rlm@269 361 (walk
rlm@269 362 [↓ ↓ ← ↓
rlm@269 363 ↓ ↓ ↓ ↓ ↓ ↓ ↓ ↓
rlm@269 364 → →])
rlm@269 365
rlm@269 366 (walk-thru-grass
rlm@269 367 [→ ↓ ↓ ↓])
rlm@269 368
rlm@269 369 (walk [↓ ← ← ↓ ↓ ↓ ↓ ↓ ↓])
rlm@269 370
rlm@269 371 (walk-thru-grass
rlm@269 372 [↓ ↓ ↓ ↓ ↓ ↓ ↓])
rlm@269 373
rlm@269 374 (walk [↓ ↓ ← ↓ ↓ ↓ ←
rlm@269 375 ↓ ↓ ↓ ↓ ↓
rlm@269 376 → → → ↑]))))
rlm@270 377
rlm@270 378 (defn-memo deliver-oaks-parcel
rlm@270 379 ([] (deliver-oaks-parcel
rlm@270 380 (viridian-store->oaks-lab-like-a-boss)))
rlm@270 381 ([script]
rlm@270 382 (->> script
rlm@270 383 (walk [↑ ↑ ↑ ↑ ↑ ↑ ↑ ↑])
rlm@270 384 (play-moves [[:a]])
rlm@270 385 (scroll-text 11)
rlm@270 386 (end-text)
rlm@270 387 (end-text)
rlm@270 388 (do-nothing 200)
rlm@270 389 (end-text)
rlm@270 390 (scroll-text 3)
rlm@270 391 (end-text)
rlm@270 392 (scroll-text 2)
rlm@270 393 (end-text)
rlm@270 394 (scroll-text 5)
rlm@270 395 (end-text)
rlm@270 396 (scroll-text 2)
rlm@270 397 (end-text)
rlm@270 398 (scroll-text 9)
rlm@270 399 (end-text)
rlm@270 400 (scroll-text 7)
rlm@270 401 (end-text)
rlm@271 402 (walk [← ← ↓ ↓ ↓ ↓ ↓ ↓ ↓ ↓ ↓]))))
rlm@271 403
rlm@271 404 (defn-memo return-to-viridian-mart
rlm@271 405 ([] (return-to-viridian-mart
rlm@271 406 (deliver-oaks-parcel)))
rlm@271 407 ([script]
rlm@271 408 (->> script
rlm@271 409 oaks-lab->pallet-town-edge
rlm@274 410 (pallet-edge->viridian-mart false))))
rlm@274 411
rlm@274 412 (defn-memo walk-to-counter
rlm@274 413 ([] (walk-to-counter
rlm@274 414 (return-to-viridian-mart)))
rlm@274 415 ([script]
rlm@274 416 (->> script
rlm@274 417 (walk [↑ ↑ ← ←]))))
rlm@275 418
rlm@275 419 (defn buy-item
rlm@275 420 "Assumes that the main item-screen is up, and buys
rlm@275 421 quantity of the nth item in the list, assuming that you
rlm@275 422 have enough money."
rlm@275 423 [n quantity script]
rlm@275 424 (if (= 0 quantity)
rlm@275 425 script
rlm@275 426 (let [after-initial-pause
rlm@275 427 (do-nothing 20 script)
rlm@275 428 move-to-item
rlm@275 429 (reduce (fn [script _]
rlm@275 430 (->> script
rlm@275 431 (play-moves [[:d]])
rlm@275 432 (do-nothing 3)))
rlm@275 433 after-initial-pause
rlm@275 434 (range n))
rlm@275 435 select-item
rlm@275 436 (play-moves [[:a]] move-to-item)
rlm@275 437 request-items
rlm@275 438 (reduce (fn [script _]
rlm@275 439 (->> script
rlm@275 440 (play-moves [[:u]])
rlm@275 441 (do-nothing 1)))
rlm@275 442 select-item
rlm@275 443 (range (dec quantity)))
rlm@275 444 buy-items
rlm@275 445 (->> request-items
rlm@284 446 (do-nothing 10)
rlm@275 447 (play-moves [[:a]])
rlm@275 448 (scroll-text)
rlm@275 449 (scroll-text)
rlm@284 450 (do-nothing 10)
rlm@275 451 (play-moves [[:a]])
rlm@275 452 (scroll-text))]
rlm@275 453 buy-items)))
rlm@275 454
rlm@275 455
rlm@275 456 (defn buy-items
rlm@275 457 "Given a list of [item-no quantity], buys the quantity
rlm@275 458 from the shop's list. Assumes that the item list is
rlm@275 459 already up."
rlm@275 460 [item-pairs script]
rlm@275 461 (let [item-lookup (into {0 0 1 0 2 0 3 0 4 0} item-pairs)
rlm@275 462 initial-purchase
rlm@275 463 (->> script
rlm@275 464 (buy-item 0 (item-lookup 0))
rlm@275 465 (buy-item 1 (item-lookup 1))
rlm@275 466 (buy-item 2 (item-lookup 2)))]
rlm@275 467 (cond
rlm@275 468 (and
rlm@275 469 (not= 0 (item-lookup 3))
rlm@275 470 (not= 0 (item-lookup 4)))
rlm@275 471 (->> initial-purchase
rlm@275 472 (do-nothing 20)
rlm@275 473 (play-moves [[:d]])
rlm@275 474 (do-nothing 3)
rlm@275 475 (play-moves [[:d]])
rlm@275 476 (do-nothing 3)
rlm@275 477 (play-moves [[:d]])
rlm@275 478 (do-nothing 10)
rlm@275 479 (buy-item 0 (item-lookup 3))
rlm@275 480 (do-nothing 20)
rlm@275 481 (play-moves [[:d]])
rlm@275 482 (do-nothing 3)
rlm@275 483 (play-moves [[:d]])
rlm@275 484 (do-nothing 3)
rlm@275 485 (play-moves [[:d]])
rlm@275 486 (do-nothing 10)
rlm@275 487 (buy-item 0 (item-lookup 4)))
rlm@275 488 (and (= 0 (item-lookup 3))
rlm@275 489 (not= 0 (item-lookup 4)))
rlm@275 490 (->> initial-purchase
rlm@275 491 (do-nothing 20)
rlm@275 492 (play-moves [[:d]])
rlm@275 493 (do-nothing 3)
rlm@275 494 (play-moves [[:d]])
rlm@275 495 (do-nothing 3)
rlm@275 496 (play-moves [[:d]])
rlm@275 497 (do-nothing 10)
rlm@275 498 (play-moves [[:d]])
rlm@275 499 (do-nothing 10)
rlm@275 500 (buy-item 0 (item-lookup 4)))
rlm@275 501 (and (not= 0 (item-lookup 3))
rlm@275 502 (= 0 (item-lookup 4)))
rlm@275 503 (->> initial-purchase
rlm@275 504 (do-nothing 20)
rlm@275 505 (play-moves [[:d]])
rlm@275 506 (do-nothing 3)
rlm@275 507 (play-moves [[:d]])
rlm@275 508 (do-nothing 3)
rlm@275 509 (play-moves [[:d]])
rlm@275 510 (do-nothing 10)
rlm@284 511 (buy-item 0 (item-lookup 3)))
rlm@284 512 (and (= 0 (item-lookup 3))
rlm@284 513 (= 0 (item-lookup 4)))
rlm@284 514 initial-purchase)))
rlm@275 515
rlm@275 516
rlm@275 517 (defn test-buy-items
rlm@277 518 ([] (test-buy-items
rlm@274 519 (walk-to-counter)))
rlm@274 520 ([script]
rlm@275 521 (->> [(first script) (set-money (second script)
rlm@275 522 999999)]
rlm@274 523 (play-moves
rlm@274 524 [[] [:a] []])
rlm@274 525 (scroll-text)
rlm@274 526 (do-nothing 100)
rlm@274 527 (play-moves [[:a]])
rlm@274 528 (do-nothing 100)
rlm@275 529 (buy-items
rlm@275 530 [[0 1]
rlm@275 531 [1 15]
rlm@275 532 [2 1]
rlm@275 533 [3 20]
rlm@275 534 [4 95]
rlm@275 535 ]))))
rlm@275 536
rlm@275 537 (defn-memo buy-initial-items
rlm@275 538 ([] (buy-initial-items
rlm@275 539 (walk-to-counter)))
rlm@275 540 ([script]
rlm@275 541 (->> script
rlm@275 542 (play-moves
rlm@275 543 [[] [:a] []])
rlm@274 544 (scroll-text)
rlm@274 545 (do-nothing 100)
rlm@274 546 (play-moves [[:a]])
rlm@274 547 (do-nothing 100)
rlm@275 548 (buy-items
rlm@275 549 [[0 1]
rlm@275 550 [1 1]
rlm@275 551 [2 1]
rlm@275 552 [3 1]
rlm@279 553 [4 1]])
rlm@279 554 (do-nothing 100)
rlm@279 555 (play-moves [[:b]])
rlm@279 556 (do-nothing 100)
rlm@279 557 (play-moves [[:b]])
rlm@279 558 (do-nothing 100)
rlm@284 559 (play-moves [[:b] []])
rlm@284 560 (advance [:b] [:b :start]))))
rlm@274 561
rlm@274 562
rlm@280 563 (defn-memo do-save-corruption
rlm@279 564 ([] (do-save-corruption
rlm@279 565 (buy-initial-items)))
rlm@279 566 ([script]
rlm@279 567 (->> script
rlm@280 568 (advance [] [:d])
rlm@280 569 (play-moves [[] [] [] [:d]
rlm@280 570 [] [] [] [:d]
rlm@280 571 [] [] [] [:d]
rlm@280 572 [] [] [:a]])
rlm@280 573 scroll-text
rlm@280 574 (play-moves
rlm@280 575 ;; this section is copied from speedrun-2942 and corrupts
rlm@290 576 ;; the save so that the total number of pokemon is set to
rlm@290 577 ;; 0xFF, allowing manipulation of non-pokemon data in RAM
rlm@290 578 ;; via the pokemon interface.
rlm@280 579 [[] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
rlm@280 580 [] [] [] [] [] [] [] [] [] [] [] [:select] [:restart]])
rlm@280 581 (title)
rlm@280 582 (advance [] [:start])
rlm@280 583 (advance [] [:a])
rlm@280 584 (advance [:a] [:a :start]))))
rlm@280 585
rlm@284 586 (def menu walk)
rlm@284 587
rlm@284 588 (defn-memo corrupt-item-list
rlm@284 589 ([] (corrupt-item-list
rlm@284 590 (do-save-corruption)))
rlm@284 591 ([script]
rlm@284 592 (->> script
rlm@284 593 (do-nothing 200)
rlm@284 594 (menu [↓ [:a]]) ; select "POKEMON" from
rlm@284 595 ; from main menu
rlm@284 596 (menu [↓ ↓ ↓ ↓ ↓ ↓ ; go to 6th pokemon
rlm@284 597 [:a] ↓ [:a] ; select "switch"
rlm@284 598 ↓ ↓ ↓ [:a]]) ; switch with 9th "pokemon"
rlm@284 599
rlm@284 600 (do-nothing 1))))
rlm@284 601
rlm@284 602
rlm@284 603 (defn slowly
rlm@284 604 [delay moves script]
rlm@284 605 (reduce
rlm@284 606 (fn [script move]
rlm@284 607 (->> script
rlm@284 608 (do-nothing delay)
rlm@284 609 (play-moves (vector move))))
rlm@284 610 script moves))
rlm@284 611
rlm@284 612 (defn-memo get-burn-heals
rlm@284 613 ([] (get-burn-heals
rlm@284 614 (corrupt-item-list)))
rlm@284 615 ([script]
rlm@284 616 (->> script
rlm@284 617 (menu [[:b] [:b]])
rlm@284 618 (menu [[:a]])
rlm@284 619 (do-nothing 100)
rlm@284 620 (menu [↓ [:a]])
rlm@284 621 (do-nothing 100)
rlm@284 622 (menu [[:a] ↓ [:a]])
rlm@284 623 (scroll-text)
rlm@284 624 (menu [[:b][:b]])
rlm@284 625 (menu [[:a]])
rlm@284 626
rlm@284 627 (do-nothing 50)
rlm@284 628 (buy-items [[0 1]])
rlm@284 629 (do-nothing 60)
rlm@284 630 (menu [[:a]])
rlm@284 631 (scroll-text)
rlm@284 632
rlm@284 633 (do-nothing 50)
rlm@284 634 (buy-items [[0 1]])
rlm@284 635 (do-nothing 60)
rlm@284 636 ;;(menu [[:a]])
rlm@284 637 ;;(scroll-text)
rlm@284 638
rlm@284 639 ;;(do-nothing 300)
rlm@284 640 ;;(menu [[:b] [:b]])
rlm@284 641 ;;(do-nothing 300)
rlm@284 642
rlm@284 643 (buy-items [[0 1]
rlm@284 644 [1 1]
rlm@284 645 [1 1]
rlm@284 646 [2 1]
rlm@284 647 [3 1]
rlm@284 648 [4 97]])
rlm@284 649
rlm@284 650 (do-nothing 10))))
rlm@284 651
rlm@284 652 (defn save-game-properly
rlm@284 653 [number-down script]
rlm@284 654 (->>
rlm@284 655 (reduce (fn [script _]
rlm@284 656 (->> script
rlm@284 657 (advance [] [:d])))
rlm@284 658 script
rlm@284 659 (range number-down))
rlm@284 660 (play-moves [[] [] [:a]])
rlm@284 661 (scroll-text)
rlm@284 662 (do-nothing 300)))
rlm@284 663
rlm@284 664 (defn-memo corrupt-item-list-again
rlm@284 665 ([] (corrupt-item-list-again (get-burn-heals)))
rlm@284 666 ([script]
rlm@284 667 (->> script
rlm@284 668 (do-nothing 10)
rlm@284 669 (play-moves [[:b]])
rlm@284 670 (do-nothing 100)
rlm@284 671 (play-moves [[:b]])
rlm@284 672 (do-nothing 40)
rlm@284 673 (play-moves [[:b]])
rlm@284 674 (advance [:b] [:start :b])
rlm@284 675 (menu [[:a] ↑ ↑ ↑ ↑ ↑ ; get fifth pokemon
rlm@284 676 [:a] ↓ [:a] ; and corrupt the
rlm@284 677 ↓ ↓ ↓ ↓ ↓ [:a]]) ; item list again by
rlm@284 678 ; switching it to
rlm@284 679 ))) ; tenth place.
rlm@284 680
rlm@284 681
rlm@280 682
rlm@290 683 (defn-memo viridian-store->viridian-poke-center
rlm@290 684 ([] (viridian-store->viridian-poke-center
rlm@290 685 (corrupt-item-list-again)))
rlm@290 686 ([script]
rlm@290 687 (->> script
rlm@290 688 (do-nothing 100)
rlm@290 689 (play-moves [[:b]])
rlm@290 690 (do-nothing 100)
rlm@290 691 (play-moves [[:b]])
rlm@290 692 (do-nothing 40)
rlm@290 693 ;; leave store
rlm@290 694 (walk [↓ ↓
rlm@290 695 → ↓ ↓])
rlm@290 696 (walk [← ← ← ←
rlm@290 697 ↓ ↓ ↓ ↓ ↓ ↓
rlm@290 698 ← ← ← ↑]))))
rlm@290 699
rlm@291 700 (defn-memo to-poke-center-computer
rlm@290 701 ([] (to-poke-center-computer
rlm@290 702 (viridian-store->viridian-poke-center)))
rlm@290 703 ([script]
rlm@290 704 (->> script
rlm@290 705 (walk [→ →
rlm@290 706 ↑ ↑ ↑
rlm@290 707 → → → → → → → → → ↑])
rlm@290 708 (do-nothing 1))))
rlm@291 709
rlm@291 710 (defn-memo begin-deposits
rlm@291 711 ([] (begin-deposits
rlm@291 712 (to-poke-center-computer)))
rlm@291 713 ([script]
rlm@291 714 (->> script
rlm@291 715 ;; access PC
rlm@291 716 (scroll-text 2)
rlm@291 717
rlm@291 718 ;; access item storage
rlm@291 719 (menu [[:a] [:d] [:a]])
rlm@291 720 (scroll-text 2)
rlm@291 721
rlm@291 722 ;; begin deposit
rlm@291 723 (menu [[:d] [:a]])
rlm@291 724 (do-nothing 40))))
rlm@291 725
rlm@291 726
rlm@291 727 (defn multiple-times
rlm@291 728 ([n command args script]
rlm@291 729 (reduce (fn [script _]
rlm@291 730 (apply command (concat args [script])))
rlm@291 731 script
rlm@291 732 (range n)))
rlm@291 733 ([n command script]
rlm@291 734 (multiple-times n command [] script)))
rlm@291 735
rlm@293 736 (defn deposit-n-items
rlm@293 737 [n script]
rlm@293 738 (->> script
rlm@293 739 (do-nothing 100)
rlm@293 740 (play-moves [[:a]])
rlm@293 741 (do-nothing 80)
rlm@293 742 (multiple-times
rlm@293 743 (dec n)
rlm@293 744 (fn [script]
rlm@293 745 (->> script
rlm@293 746 (play-moves [[:u]])
rlm@293 747 (do-nothing 1))))
rlm@293 748 (play-moves [[:a]])
rlm@293 749 (scroll-text)))
rlm@296 750
rlm@296 751 (defn deposit-one-item
rlm@296 752 [script]
rlm@296 753 (->> script
rlm@296 754 (do-nothing 100)
rlm@296 755 (play-moves [[:a]])
rlm@296 756 (do-nothing 80)
rlm@296 757 (play-moves [[:a]])
rlm@296 758 (scroll-text)))
rlm@293 759
rlm@293 760 (defn-memo create-header
rlm@291 761 ([] (create-header (begin-deposits)))
rlm@291 762 ([script]
rlm@291 763 (->> script
rlm@293 764 (multiple-times 33 deposit-one-item)
rlm@291 765 (do-nothing 1))))
rlm@297 766
rlm@297 767 (defn bootstrap-init []
rlm@297 768 [(read-moves "bootstrap-init")
rlm@297 769 (read-state "bootstrap-init")])
rlm@296 770
rlm@296 771 (defn create-bootstrap-program
rlm@296 772 ([] (create-bootstrap-program
rlm@296 773 (create-header)))
rlm@296 774 ([script]
rlm@296 775 (->> script
rlm@296 776 (do-nothing 120)
rlm@296 777 (menu [↓ ↓ ↓ ↓ ↓ ↓ ↓])
rlm@296 778 ;;(deposit-n-items 33)
rlm@296 779
rlm@296 780 (menu (repeat 17 ↓))
rlm@296 781
rlm@296 782
rlm@296 783
rlm@296 784 (do-nothing 1))))
rlm@296 785
rlm@297 786
rlm@302 787 (defn test-pc-item-program []
rlm@302 788 (-> (read-state "bootstrap-init")
rlm@302 789 (set-memory pc-item-list-start 50)
rlm@302 790 (set-memory-range
rlm@305 791 map-function-address-start [0x8B 0xD5])
rlm@304 792 (set-memory-range
rlm@302 793 (inc pc-item-list-start)
rlm@302 794 (flatten
rlm@304 795 [(repeat
rlm@303 796 28
rlm@302 797 [0xFF 0x01])
rlm@303 798 [;; second part of item manipulation program
rlm@303 799 0x00 ;; this starts at address 0xD56C
rlm@303 800 0x2A ;; save (HL)=(target) to A, increment HL
rlm@302 801
rlm@302 802 0x00
rlm@303 803 0x47 ;; save A to B
rlm@302 804
rlm@302 805 0x00
rlm@303 806 0x3A ;; save (target+1) to A, decrement HL
rlm@302 807
rlm@302 808 0x00
rlm@303 809 0x22 ;; A -> target, increment HL [(target+1) -> target]
rlm@302 810
rlm@303 811 0x00
rlm@303 812 0x70 ;; load B into target+1 [(target) -> target+1]
rlm@303 813
rlm@303 814 0x00
rlm@303 815 0xC3 ;; first part of absolute jump
rlm@303 816
rlm@303 817 0x0C ;; return control to pokemon kernel
rlm@302 818 0x5F]
rlm@302 819 (repeat
rlm@303 820 5
rlm@302 821 [0xFF 0x01])
rlm@302 822
rlm@303 823 [;; first part of item manipulation program
rlm@303 824 0x00
rlm@303 825 0x21 ;; load target into HL
rlm@302 826
rlm@303 827 0x94 ;; this is the target address
rlm@302 828 0xD5
rlm@302 829
rlm@303 830 0x00 ;; relative jump back to first part
rlm@303 831 0x18
rlm@302 832
rlm@303 833 0xE1 ;; of program
rlm@302 834 0x01
rlm@302 835
rlm@303 836 0xFF ;; spacer
rlm@302 837 0x01
rlm@302 838
rlm@303 839 0x04 ;; target ID (pokeball)
rlm@303 840 0x3E ;; target Quantity (lemonade)
rlm@302 841 ]]))))