Mercurial > vba-clojure

annotate clojure/com/aurellem/run/adv_choreo.clj @ 583:21e4ab461506

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
fixed glyph display bug, going to apply cosmetic corrections now and remove testing cruft.
author Robert McIntyre <rlm@mit.edu>
date Sat, 01 Sep 2012 09:54:48 -0500
parents 393b49a83394
children bbed03870072
rev   line source
rlm@550 1 ;;;; "Advanced Choreography" -- this is the final video for this project.
rlm@550 2
rlm@550 3 (ns com.aurellem.run.adv-choreo
rlm@550 4 (:use (com.aurellem.gb saves gb-driver util constants
rlm@550 5 items vbm characters money
rlm@550 6 rlm-assembly))
rlm@550 7 (:use (com.aurellem.run util music title save-corruption
rlm@550 8 bootstrap-0 bootstrap-1 image
rlm@550 9 ram-display final-cut basic-choreo))
rlm@550 10 (:require clojure.string)
rlm@553 11 (:import java.awt.image.BufferedImage)
rlm@553 12 (:import (javax.imageio ImageWriteParam IIOImage ImageIO))
rlm@550 13 (:import [com.aurellem.gb.gb_driver SaveState])
rlm@550 14 (:import java.io.File))
rlm@550 15
rlm@550 16
rlm@550 17
rlm@550 18 ;; Use the gameboy's screen to display the new programming
rlm@550 19 ;; instead of a side window. This will make it look much
rlm@550 20 ;; cooler and create a terminal-like effect as the game is
rlm@550 21 ;; being reprogramed. To do this, use a fixed data entry
rlm@550 22 ;; region in ram, and run a program that translates this
rlm@550 23 ;; region into the screen. Every time this data entry region
rlm@550 24 ;; is full, run a program that copies the data to the
rlm@550 25 ;; appropriate region in memory. This will cost ~15 seconds
rlm@550 26 ;; at the beginning to set up, and then should have minimal
rlm@550 27 ;; overhead (~5%) for the rest of the data transfer, but
rlm@550 28 ;; will have a good psychological effect for the viewer
rlm@550 29 ;; since he can see that something is actually happening in
rlm@550 30 ;; the game.
rlm@550 31
rlm@550 32
rlm@551 33 ;; Symbol size and type.
rlm@551 34
rlm@551 35 ;; use fonts from zophar's domain:
rlm@551 36 ;; http://www.zophar.net/utilities/fonts/8x8-font-archive.html
rlm@551 37
rlm@551 38 ;; Green font on black background for matrix look.
rlm@551 39
rlm@551 40
rlm@551 41 (defn program-data [base-address]
rlm@551 42 (let [image-program
rlm@551 43 (display-image-kernel
rlm@551 44 base-address
rlm@554 45
rlm@576 46 ;;pinkie-pie-mark
rlm@576 47 test-image-color
rlm@554 48
rlm@554 49 )
rlm@554 50
rlm@551 51
rlm@551 52 music-base-address (+ (count image-program) base-address)
rlm@551 53
rlm@551 54 initial-music-data
rlm@551 55 (midi-bytes pony-csv 0 0 0 0)
rlm@551 56
rlm@551 57 data-lengths
rlm@551 58 (map (comp count :data)
rlm@551 59 [(:kernel initial-music-data)
rlm@551 60 (:voice-1 initial-music-data)
rlm@551 61 (:voice-2 initial-music-data)]);; noise not needed
rlm@551 62 addresses
rlm@551 63 (map (partial + music-base-address) (reductions + 0 data-lengths))
rlm@551 64
rlm@551 65 final-music-data
rlm@551 66 (apply (partial midi-bytes pony-csv) addresses)
rlm@551 67
rlm@551 68 music-program
rlm@551 69 (concat
rlm@551 70 (:data (:kernel final-music-data))
rlm@551 71 (:data (:voice-1 final-music-data))
rlm@551 72 (:data (:voice-2 final-music-data))
rlm@551 73 (:data (:noise final-music-data)))]
rlm@551 74
rlm@551 75 (concat
rlm@551 76 image-program ;; image program falls through to music program
rlm@554 77
rlm@576 78 (infinite-loop)
rlm@576 79 ;;music-program
rlm@554 80
rlm@554 81 )))
rlm@551 82
rlm@551 83
rlm@551 84
rlm@553 85
rlm@553 86 (def glyphs
rlm@553 87 "The sixteen 8x8 glyphs which make up the \"terminal\" font."
rlm@553 88 (mapv #(ImageIO/read
rlm@553 89 (File. user-home (str "proj/vba-clojure/font/" % ".png")))
rlm@553 90 ["0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "A" "B" "C" "D" "E" "F"]))
rlm@553 91
rlm@554 92 (defn glyph-init-program
rlm@553 93 [start-address]
rlm@553 94 (let [zero-glyph (image->gb-image (glyphs 0))
rlm@553 95
rlm@553 96 ;; write same pallet information to all pallettes
rlm@553 97 A (flatten
rlm@554 98 [(write-byte LCD-control-register 0x00);; disable LCD protection
rlm@553 99 (set-palettes bg-palette-select bg-palette-data
rlm@553 100 (repeat 8 (first (:palettes zero-glyph))))
rlm@553 101 (select-LCD-bank 0)
rlm@553 102 (write-byte SCX-register 0)
rlm@553 103 (write-byte SCY-register 0)])
rlm@553 104 B (flatten
rlm@553 105 [(write-data
rlm@553 106 (+ start-address (count A))
rlm@553 107 character-data-address
rlm@553 108 (flatten
rlm@553 109 (map (comp gb-tile->bytes first :tiles image->gb-image)
rlm@554 110 glyphs)))
rlm@553 111
rlm@554 112
rlm@554 113 (write-byte
rlm@554 114 LCD-control-register
rlm@554 115 (Integer/parseInt
rlm@554 116 (str
rlm@554 117 "1" ;; LCDC on/off
rlm@554 118 "0" ;; Window code area
rlm@554 119 "0" ;; Windowing on?
rlm@554 120 "1" ;; BG tile base (1 = 0x8000)
rlm@554 121 "0" ;; BG-1 or BG-2 ?
rlm@554 122 "0" ;; OBJ-block composition
rlm@554 123 "0" ;; OBJ-on flag
rlm@554 124 "1") ;; no-effect
rlm@554 125 2))])]
rlm@554 126 (concat A B )))
rlm@553 127
rlm@558 128
rlm@560 129
rlm@553 130 (defn glyph-display-program
rlm@577 131 [start-address]
rlm@556 132 (let [data-start (+ 2 start-address)
rlm@557 133 load-data
rlm@557 134 (flatten
rlm@557 135 [;; data region
rlm@557 136 0x18
rlm@582 137 4
rlm@582 138 0 0 0 0;; current row and column
rlm@557 139 ;; save all registers
rlm@557 140 0xC5 0xD5 0xE5 0xF5
rlm@557 141
rlm@557 142 ;; load data from data region into registers
rlm@562 143
rlm@577 144 0xF5 ;; push A, which contains current glyph
rlm@577 145
rlm@577 146 0x21
rlm@558 147 (reverse (disect-bytes-2 data-start))
rlm@577 148 ;; load row and column into DE
rlm@577 149 0x2A 0x57 ;; row -> D
rlm@577 150 0x2A 0x5F ;; column -> E
rlm@557 151
rlm@577 152
rlm@557 153 ])
rlm@557 154
rlm@560 155
rlm@562 156 display-glyph
rlm@568 157 (let [init*
rlm@563 158 (flatten
rlm@577 159 [(repeat 100 0)
rlm@565 160 ;; Reset HL to initial value
rlm@567 161
rlm@568 162 ;; clear screen if we are at 0,0
rlm@568 163 0x57 0xB3 ;; D->A, OR E A ==> (= D E 0)
rlm@571 164 0x20 ;; skip clear-screen if D and E are not both zero
rlm@572 165 :clear-screen-length])
rlm@562 166
rlm@563 167 clear-screen
rlm@568 168 (flatten
rlm@569 169 [;; save all registers
rlm@569 170 0xC5 0xD5 0xE5 0xF5
rlm@569 171
rlm@570 172 (select-LCD-bank 0)
rlm@570 173 ;; write 0x00 to memory locations
rlm@570 174 ;; 0x9800 to 0x9A34
rlm@570 175 0x21
rlm@570 176 0x00 0x98 ;; load 0x9800 into HL
rlm@570 177
rlm@570 178
rlm@570 179 0x16 3 ;; 3 -> D
rlm@570 180 0x1E 190 ;; 188 -> E
rlm@570 181
rlm@570 182 0x3E 0 ;; 0-> A
rlm@570 183
rlm@570 184 ;; begin of do-while loop
rlm@570 185 0x22 ;; load 0 to 0x9800
rlm@570 186 0x1D ;; dec E
rlm@570 187 0x20
rlm@570 188 (->signed-8-bit -4)
rlm@570 189 0x15 ;; dec D
rlm@570 190 0x1E 190 ;; 188 -> E
rlm@570 191 0x20
rlm@570 192 (->signed-8-bit -8)
rlm@570 193 ;; end of do-while-loop
rlm@572 194
rlm@569 195 ;; restore all registers
rlm@572 196 0xF1 0xE1 0xD1 0xC1])
rlm@572 197
rlm@577 198 ;; RLM: for TESTING ONLY!!!
rlm@579 199 clear-screen (repeat 10 0)
rlm@573 200 increment-row-column
rlm@573 201 [;; D contains row and E contains column
rlm@573 202
rlm@573 203 ;; every time column (E) reaches 20, set
rlm@573 204 ;; column to 0 and increment row
rlm@573 205 0x1C ;; inc E
rlm@573 206 0x3E 20 0xBB ;; compare E to 20
rlm@578 207 0x20
rlm@579 208 3
rlm@579 209 0x14
rlm@578 210 0x1E 0
rlm@578 211
rlm@579 212
rlm@579 213 0x3E 18
rlm@579 214 0xBA
rlm@579 215 0x20
rlm@579 216 2
rlm@579 217 0x16 0
rlm@573 218
rlm@578 219 ;; 0x00 ;;0x1C ;; inc E
rlm@578 220 ;; 0x3E 20 0xBB ;; compare E to 20
rlm@578 221 ;; 0x20 ;; if E is 20
rlm@578 222 ;; 3
rlm@578 223 ;; 0x1E 0 ;; set E to zero
rlm@578 224 ;; 0x00; 0x14 ;; (inc D) -> D
rlm@578 225
rlm@578 226 ;; ;; every time row (D) reaches 18, set row to 0
rlm@578 227 ;; 0x3E 18 0xBA ;; compare D to 18
rlm@578 228 ;; 0x20 ;; if D is 18
rlm@578 229 ;; 2
rlm@578 230 ;; 0x16 0
rlm@582 231 ;; set D to zero
rlm@582 232 ]
rlm@573 233
rlm@573 234 set-HL-from-row-and-column
rlm@581 235 (flatten
rlm@573 236 [;; formula for memory offset is:
rlm@577 237 ;; (+ 0x9800 (* 32 row) column) ==
rlm@577 238 ;; (+ 0x97E0 (* 32 (+ 1 row)) column)
rlm@581 239 0xD5 ;; push DE
rlm@573 240
rlm@579 241 ;; RLM: this should be 0x9800, investigate
rlm@581 242 0x21 0x00 0x98 ;; load HL with something
rlm@577 243
rlm@583 244 ;;0x06 0
rlm@583 245 ;;0x4B ;; columns (E) -> BC
rlm@583 246 ;;0x09 ;; HL += columns
rlm@573 247
rlm@579 248
rlm@579 249 0xAF ;; 0 -> A
rlm@579 250
rlm@579 251 0x06 0
rlm@579 252 0x0E 32 ;; load 32 into BC
rlm@579 253
rlm@581 254 0xBA ;; CP A D
rlm@583 255 0x28 ;; skip this next section if A == D
rlm@579 256 4
rlm@581 257 ;;(+ 32 3)
rlm@579 258 0x09 ;; HL += 32
rlm@581 259 ;;(repeat 32 0x23)
rlm@579 260 0x3C
rlm@579 261 0x18
rlm@581 262 ;;(->signed-8-bit (+ -6 -32))
rlm@579 263 (->signed-8-bit -7)
rlm@578 264 ;; 0x14 ;; inc D to handle case where D == 0
rlm@578 265 ;; ;; D will never be > 20, so this will never overflow.
rlm@578 266
rlm@578 267 ;; ;; do
rlm@578 268 ;; 0x09 ;; HL += 32
rlm@578 269 ;; 0x15 ;; dec D
rlm@578 270 ;; ;; while D != 0
rlm@578 271 ;; 0x20
rlm@578 272 ;; (->signed-8-bit -4)
rlm@577 273
rlm@581 274 0xD1 ;; pop DE
rlm@581 275 ])
rlm@573 276
rlm@572 277 render-glyph
rlm@572 278 (flatten
rlm@577 279 [;; Render each nybble of A as a character
rlm@577 280 ;; there are two characters to a glyph.
rlm@579 281 0x21
rlm@579 282 (reverse (disect-bytes-2 data-start))
rlm@579 283 ;; load row and column into DE
rlm@579 284 0x2A 0x57 ;; row -> D
rlm@579 285 0x2A 0x5F ;; column -> E
rlm@581 286
rlm@581 287
rlm@577 288 set-HL-from-row-and-column
rlm@581 289
rlm@575 290 0xF1 ;; pop A, now A is equal to key input
rlm@581 291 0x3E 0xFF ;; RLM: TESTING set A = 0xFF
rlm@575 292 0xF5 ;; save A
rlm@575 293
rlm@575 294 0xE6 0xF0 ;; clear second nybble
rlm@575 295 0xCB 0x37 ;; swap nybbles
rlm@579 296 0x77 ;; store A in video RAM as a character (pun)
rlm@577 297 increment-row-column
rlm@581 298
rlm@581 299
rlm@577 300 set-HL-from-row-and-column
rlm@581 301
rlm@575 302 0xF1 ;; restore A
rlm@575 303 0xE6 0x0F ;; select second nybble
rlm@579 304 0x77 ;; store second nybble as character
rlm@575 305 increment-row-column
rlm@577 306 ])
rlm@563 307
rlm@572 308
rlm@568 309 init (replace
rlm@568 310 {:clear-screen-length (count clear-screen)} init*)
rlm@568 311 ]
rlm@568 312
rlm@572 313 (concat init clear-screen render-glyph))
rlm@563 314
rlm@557 315 cleanup
rlm@557 316 ;; restore all registers
rlm@562 317 (flatten
rlm@582 318 [;; Reset HL to initial data-start value
rlm@582 319 0x44 0x4D ;;HL -> BC
rlm@582 320
rlm@558 321 0x21
rlm@558 322 (reverse (disect-bytes-2 data-start))
rlm@579 323 ;;0x23
rlm@582 324 ;; write variables
rlm@579 325 0x7A 0x22 ;; D -> rows -> to RAM
rlm@569 326 0x7B 0x22 ;; E -> columns
rlm@582 327
rlm@582 328 0x78 0x22 ;; RLM: testing store HL
rlm@582 329 0x79 0x22
rlm@582 330
rlm@582 331
rlm@558 332 ])
rlm@558 333
rlm@558 334 stack-cleanup
rlm@557 335 [0xF1 0xE1 0xD1 0xC1]
rlm@576 336 ]
rlm@558 337 (concat load-data
rlm@558 338 display-glyph
rlm@558 339 cleanup stack-cleanup)))
rlm@556 340
rlm@556 341 (def main-program-base-address 0xC000)
rlm@553 342
rlm@553 343 (defn glyph-bootstrap-program
rlm@553 344 [start-address delay-count total-glyph-count]
rlm@553 345 (let [init [0xAF 0x4F 0x47] ;; 0->A; 0->C; 0->B
rlm@554 346 header (concat (frame-metronome) (read-user-input))
rlm@553 347
rlm@553 348 glyph-display (glyph-display-program
rlm@559 349 (+ (count init)
rlm@562 350 (count header)
rlm@577 351 start-address))
rlm@558 352 ;;(- (count (program-data 0)) 100))
rlm@553 353
rlm@553 354 state-machine-start-address
rlm@553 355 (+ start-address (count init) (count header) (count glyph-display))
rlm@553 356 state-machine
rlm@553 357 (bootstrap-state-machine state-machine-start-address)
rlm@553 358
rlm@553 359 return-to-header
rlm@553 360 (flatten
rlm@564 361 [0xC3
rlm@564 362 (reverse (disect-bytes-2
rlm@564 363 (+ (count init) start-address)))])]
rlm@562 364 (concat init header glyph-display state-machine return-to-header)))
rlm@553 365
rlm@556 366
rlm@551 367
rlm@558 368 (defn-memo begin-glyph-bootstrap
rlm@554 369 ([] (begin-glyph-bootstrap (launch-main-bootstrap-program)))
rlm@554 370 ([script]
rlm@554 371 (let [glyph-init (glyph-init-program relocated-bootstrap-start)
rlm@554 372 main-glyph-start (+ relocated-bootstrap-start
rlm@554 373 (count glyph-init))
rlm@554 374 glyph-program (glyph-bootstrap-program
rlm@554 375 main-glyph-start 0 0)]
rlm@554 376 (->> script
rlm@554 377 (do-nothing 2)
rlm@554 378 ;; begin glyph program
rlm@554 379 (write-RAM 0xFF1A [0 0 0]) ;; silence remnant music
rlm@554 380
rlm@554 381 (write-RAM
rlm@554 382 relocated-bootstrap-start
rlm@554 383 (concat glyph-init glyph-program))
rlm@554 384 (transfer-control relocated-bootstrap-start)
rlm@555 385 (do-nothing 1)
rlm@553 386
rlm@554 387 ))))
rlm@553 388
rlm@551 389 (defn write-all-program-data
rlm@554 390 ([] (write-all-program-data (begin-glyph-bootstrap)))
rlm@551 391 ([script]
rlm@551 392 (let [base-address main-program-base-address]
rlm@551 393 (->> script
rlm@551 394 (write-RAM base-address (program-data base-address))))))
rlm@551 395
rlm@551 396 (defn activate-program
rlm@551 397 ([] (activate-program (write-all-program-data)))
rlm@551 398 ([script]
rlm@551 399 (->> script
rlm@551 400 (transfer-control main-program-base-address)
rlm@554 401 ;;(do-nothing 1800)
rlm@554 402 (do-nothing 50)
rlm@554 403 )))
rlm@552 404
rlm@552 405
rlm@552 406 ;; possible screen writing programs
rlm@552 407
rlm@552 408 ;; (program needs to stop executing at some point)
rlm@552 409 ;; maybe have total length counter or something?
rlm@552 410
rlm@552 411 ;; automatic counter that reads from program-start and clears the
rlm@552 412 ;; screen every 360 (* 18 20) gliphs
rlm@552 413
rlm@552 414 ;; advantages -- very simple and low bandwidth
rlm@552 415 ;; disadvantages -- hard to align counter
rlm@552 416
rlm@552 417 ;; implementation -- refactor main-bootstrap-program to provide a
rlm@552 418 ;; state-machine code-section which can be recombined into another
rlm@552 419 ;; program.