Mercurial > vba-clojure

annotate clojure/com/aurellem/run/image.clj @ 545:2b6cdea9bcdb

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
audio now syncs properly, but moves no longer sync with main display.
author Robert McIntyre <rlm@mit.edu>
date Wed, 27 Jun 2012 13:41:01 -0500
parents 7f8030812ac2
children
rev   line source
rlm@488 1 (ns com.aurellem.run.image
rlm@486 2 (:use (com.aurellem.gb saves gb-driver util constants
rlm@486 3 items vbm characters money
rlm@486 4 rlm-assembly))
rlm@492 5 (:use (com.aurellem.run util music title save-corruption
rlm@486 6 bootstrap-0 bootstrap-1))
rlm@486 7 (:require clojure.string)
rlm@486 8 (:import [com.aurellem.gb.gb_driver SaveState])
rlm@522 9 (:import java.awt.image.BufferedImage)
rlm@486 10 (:import java.io.File))
rlm@486 11
rlm@486 12 ;; want to display an image onto the screen.
rlm@486 13 ;; probably will be the six ponies, possibly with scrolling.
rlm@486 14
rlm@486 15 ;; probably don't need hi-color mode since the images shuld be
rlm@486 16 ;; simple.
rlm@486 17
rlm@486 18 ;; use background tiles? they provide greater color depth than
rlm@486 19 ;; sprites, and can still be scrolled, so why not?
rlm@486 20
rlm@490 21 ;; could also use sprites to get 3 more colors per tile for a total of
rlm@490 22 ;; 7 colors per tile, although not for all tiles...
rlm@486 23
rlm@486 24
rlm@486 25
rlm@490 26 ;; want a function to
rlm@486 27
rlm@490 28 ;; 1. read an image
rlm@490 29 ;; 2. split into a grid of 8x8 pixels
rlm@490 30 ;; 3. convert all RGB colors to gb-RGB colors
rlm@490 31 ;; 4. determine efficient color palletes for the image
rlm@490 32 ;; 5. output efficient assembly code to draw the image to the gb
rlm@490 33 ;; screen.
rlm@486 34
rlm@488 35
rlm@491 36 (def image-program-target 0xB000)
rlm@486 37
rlm@491 38 (def display-width 160)
rlm@491 39 (def display-height 144)
rlm@491 40
rlm@491 41
rlm@491 42
rlm@491 43 ;{:r :g :b }
rlm@491 44
rlm@491 45 (def character-data 0x8000)
rlm@491 46 (def character-data-end 0x97FF)
rlm@491 47
rlm@491 48
rlm@491 49
rlm@491 50
rlm@491 51 (def BG-data-1 0x9800)
rlm@491 52
rlm@491 53 (def BG-data-2 0x9C00)
rlm@491 54
rlm@491 55 (def OAM 0xFE00)
rlm@491 56
rlm@491 57
rlm@491 58
rlm@491 59 (def video-bank-select-register 0xFF4F)
rlm@491 60
rlm@492 61 (defn gb-rgb->bits [[r g b]]
rlm@492 62 (assert (<= 0 r 31))
rlm@492 63 (assert (<= 0 g 31))
rlm@492 64 (assert (<= 0 b 31))
rlm@491 65 [(bit-and
rlm@491 66 0xFF
rlm@491 67 (+
rlm@491 68 r
rlm@491 69 (bit-shift-left g 5)))
rlm@491 70 (+
rlm@491 71 (bit-shift-right g 3)
rlm@491 72 (bit-shift-left b 2))])
rlm@491 73
rlm@492 74
rlm@492 75 (def bg-palette-select 0xFF68)
rlm@492 76 (def bg-palette-data 0xFF69)
rlm@492 77
rlm@492 78 (def obj-palette-select 0xFF6A)
rlm@492 79 (def obj-palette-data 0xFF6B)
rlm@492 80
rlm@492 81 (def max-palettes 8)
rlm@492 82
rlm@511 83 (defn write-byte [target data]
rlm@492 84 (flatten
rlm@492 85 [0x3E ;; load literal to A
rlm@492 86 data
rlm@492 87 0xEA ;; load A into target
rlm@493 88 (reverse (disect-bytes-2 target))]))
rlm@492 89
rlm@492 90 (defn begin-sequential-palette-write
rlm@492 91 [palette-num palette-select-address]
rlm@492 92 (assert (<= 0 palette-num max-palettes))
rlm@492 93 (assert
rlm@492 94 (or (= palette-select-address bg-palette-select)
rlm@492 95 (= palette-select-address obj-palette-select)))
rlm@492 96 (let [palette-write-data
rlm@492 97 (Integer/parseInt
rlm@492 98 (str "1" ;; auto increment
rlm@492 99 "0" ;; not used
rlm@492 100 (format
rlm@492 101 "%03d"
rlm@492 102 (Integer/parseInt
rlm@492 103 (Integer/toBinaryString palette-num) 10))
rlm@492 104 "00" ;; color num
rlm@492 105 "0" ;; H/L
rlm@492 106 ) 2)]
rlm@511 107 (write-byte palette-select-address palette-write-data)))
rlm@492 108
rlm@492 109 (defn set-palettes [palette-select palette-data palettes]
rlm@492 110 (assert (<= (count palettes)) max-palettes)
rlm@492 111 (flatten
rlm@492 112 [(begin-sequential-palette-write 0 palette-select)
rlm@511 113
rlm@511 114 0x21 ;; target address to HL
rlm@511 115 (reverse (disect-bytes-2 palette-data))
rlm@511 116
rlm@511 117
rlm@511 118 (for [palette palettes]
rlm@511 119 (map (fn [byte]
rlm@511 120 [0x3E ;; literal to A
rlm@511 121 byte
rlm@511 122 0x77]) ;; A -> (HL)
rlm@511 123
rlm@511 124 (flatten
rlm@511 125 (map #(gb-rgb->bits (get palette % [0 0 0]))
rlm@511 126 (range 4)))))]))
rlm@511 127
rlm@492 128
rlm@491 129 (defn display-one-color
rlm@507 130 "Displayes a single color onto the gameboy screen. Input rgb in
rlm@491 131 gameboy rgb."
rlm@498 132 ([state [r g b]]
rlm@498 133 ;; construct a kernel that displays a single color
rlm@498 134 (let
rlm@511 135 [palettes (repeat 8 [[r g b] [r g b] [r g b] [r g b]])
rlm@498 136 kernel-address 0xC000
rlm@498 137 kernel
rlm@498 138 [0xF3 ;; disable interrupts
rlm@498 139 (clear-music-registers)
rlm@498 140 (frame-metronome)
rlm@511 141 ;;(set-palettes
rlm@511 142 ;; obj-palette-select obj-palette-data palettes)
rlm@511 143 (set-palettes
rlm@511 144 bg-palette-select bg-palette-data palettes)
rlm@498 145 (infinite-loop)]]
rlm@498 146 (-> (set-memory-range state
rlm@498 147 kernel-address (flatten kernel))
rlm@498 148 (PC! kernel-address))))
rlm@498 149 ([[r g b]]
rlm@498 150 (display-one-color @current-state [r g b])))
rlm@492 151
rlm@505 152 ;;(require 'cortex.sense)
rlm@522 153
rlm@492 154
rlm@505 155 ;; (defn show-screenshot []
rlm@505 156 ;; (let [im (BufferedImage. 160 144 BufferedImage/TYPE_INT_RGB)
rlm@505 157 ;; pix (vec (pixels))
rlm@505 158 ;; view (cortex.sense/view-image)]
rlm@505 159 ;; (dorun (for [x (range 160) y (range 144)]
rlm@505 160 ;; (.setRGB im x y (pix (+ x (* 160 y))))))
rlm@505 161 ;; (view im)))
rlm@496 162
rlm@500 163 (defn gb-rgb->vga-rgb [[r g b]]
rlm@498 164 (let [vga-rgb
rlm@498 165 (first (pixels
rlm@498 166 (run-moves
rlm@498 167 (display-one-color
rlm@498 168 (tick @current-state)
rlm@498 169 [r g b])
rlm@498 170 [[][]])))]
rlm@498 171 [(bit-shift-right (bit-and vga-rgb 0xFF0000) 16)
rlm@498 172 (bit-shift-right (bit-and vga-rgb 0xFF00) 8)
rlm@498 173 (bit-and vga-rgb 0xFF)]))
rlm@491 174
rlm@498 175 (defn generate-gb-color-map []
rlm@498 176 (set-state! (mid-game))
rlm@498 177 (let [gb-colors
rlm@498 178 (for [r (range 32)
rlm@498 179 g (range 32)
rlm@498 180 b (range 32)]
rlm@498 181 [r g b])]
rlm@498 182 (zipmap gb-colors
rlm@498 183 (map gb-rgb->vga-rgb
rlm@498 184 gb-colors))))
rlm@491 185
rlm@498 186 (import java.io.FileWriter)
rlm@491 187
rlm@498 188 (def gb-color-map-file
rlm@498 189 (File. user-home "proj/vba-clojure/gb-color-map"))
rlm@495 190
rlm@498 191 (defn write-gb-color-map! []
rlm@498 192 (binding [*out*(FileWriter. gb-color-map-file)]
rlm@498 193 (let [out-str
rlm@498 194 (.replace
rlm@498 195 (str
rlm@498 196 (into (sorted-map) (generate-gb-color-map)))
rlm@498 197 "," ",\n")]
rlm@498 198 (println out-str))))
rlm@498 199
rlm@499 200 (def gb-color-map
rlm@499 201 (read-string (slurp gb-color-map-file)))
rlm@499 202
rlm@499 203 (import javax.imageio.stream.FileImageOutputStream)
rlm@499 204 (import '(javax.imageio ImageWriteParam IIOImage ImageIO))
rlm@499 205
rlm@499 206
rlm@522 207 (defn write-image! [^BufferedImage image ^File target]
rlm@522 208 (doto
rlm@522 209 (.next (ImageIO/getImageWritersByFormatName "png"))
rlm@522 210 (.setOutput (FileImageOutputStream. target))
rlm@522 211 (.write (IIOImage. image nil nil))
rlm@522 212 (.dispose))
rlm@522 213 image)
rlm@522 214
rlm@522 215
rlm@499 216 (defn gen-gb-color-image! []
rlm@500 217 (let [im (BufferedImage. 68 69 BufferedImage/TYPE_INT_RGB)
rlm@499 218 pix (vec
rlm@499 219
rlm@499 220 (reduce
rlm@499 221 concat
rlm@499 222 (map (partial
rlm@499 223 sort-by
rlm@499 224 (fn [[r g b]]
rlm@499 225 (let [s (max r g b)
rlm@499 226 det
rlm@499 227 (cond
rlm@499 228 (= s r)
rlm@499 229 (+ -1000 (- g) b)
rlm@499 230 (= s b)
rlm@499 231 (+ (- r) g)
rlm@499 232 (= s g)
rlm@499 233 (+ 1000 (- b) r))]
rlm@499 234 det)))
rlm@499 235 (partition
rlm@500 236 68 68 []
rlm@499 237 (sort-by
rlm@499 238 (fn euclidean-distance [[r g b]]
rlm@499 239 (Math/sqrt (+ (* r r) (* g g) (* b b))))
rlm@501 240 (filter
rlm@501 241 (fn [[r g b]]
rlm@501 242 (= (max r g b) b ))
rlm@501 243
rlm@501 244 (seq (set (vals gb-color-map)))))))))
rlm@505 245 ;;view (cortex.sense/view-image)
rlm@515 246 target
rlm@515 247 (File. user-home "proj/vba-clojure/gb-color-map-unique.png")]
rlm@500 248 (dorun (for [x (range 68) y (range 69)]
rlm@500 249 (let [[r g b] (get pix (+ x (* 68 y)) [0 0 0])
rlm@499 250 rgb (+ (bit-shift-left r 16)
rlm@499 251 (bit-shift-left g 8)
rlm@499 252 b)]
rlm@505 253 (.setRGB im x y rgb))))
rlm@505 254 ;;(view im)
rlm@522 255 (write-image! im target)))
rlm@522 256
rlm@522 257
rlm@499 258 (defn gen-gb-color-image*! []
rlm@499 259 (let [im (BufferedImage. 213 213 BufferedImage/TYPE_INT_RGB)
rlm@499 260 squares
rlm@499 261 (vec
rlm@499 262 (for [r (range 32)]
rlm@499 263 (vec
rlm@499 264 (for [b (range 32) g (range 32)]
rlm@499 265 (gb-color-map [r g b])))))
rlm@505 266 ;;view (cortex.sense/view-image)
rlm@499 267 target (File. user-home "proj/vba-clojure/gb-color-map.png")]
rlm@499 268
rlm@499 269 (dorun
rlm@499 270 (for [s-index (range 32)]
rlm@499 271 (dorun
rlm@499 272 (for [x (range 32) y (range 32)]
rlm@499 273
rlm@499 274 (let [[r g b] ((squares s-index) (+ x (* 32 y)))
rlm@499 275 rgb (+ (bit-shift-left r 16)
rlm@499 276 (bit-shift-left g 8)
rlm@499 277 b)]
rlm@499 278 (.setRGB im
rlm@499 279 (+ 3 (* 35 (rem s-index 6)) x)
rlm@499 280 (+ 3 (* 35 (int (/ s-index 6))) y)
rlm@499 281 rgb))))))
rlm@505 282 ;;(view im)
rlm@522 283 (write-image! im target)))
rlm@501 284
rlm@518 285 (defn gen-gimp-palette! []
rlm@518 286 (let [target
rlm@518 287 (File. user-home "proj/vba-clojure/Gameboy-Color.gpl")]
rlm@518 288 (spit
rlm@518 289 target
rlm@518 290 (apply
rlm@518 291 str
rlm@518 292 (concat
rlm@518 293 ["GIMP Palette\n"
rlm@518 294 "Name: GameBoy\n"
rlm@518 295 "#\n"]
rlm@518 296 (map (fn [[r g b]]
rlm@518 297 (format "%3d %3d %3d\n" r g b))
rlm@518 298 (sort (set (vals gb-color-map)))))))))
rlm@518 299
rlm@502 300 (def test-image
rlm@502 301 (ImageIO/read
rlm@502 302 (File. user-home "/proj/vba-clojure/images/test-gb-image.png")))
rlm@502 303
rlm@514 304 (def test-image-2
rlm@514 305 (ImageIO/read
rlm@514 306 (File. user-home "/proj/vba-clojure/images/test-gb-image-2.png")))
rlm@514 307
rlm@515 308 (def test-image-color
rlm@515 309 (ImageIO/read
rlm@515 310 (File. user-home "/proj/vba-clojure/images/colors-test.png")))
rlm@515 311
rlm@519 312 (def pinkie-pie-mark
rlm@519 313 (ImageIO/read
rlm@519 314 (File. user-home "/proj/vba-clojure/images/pinkie-pie-cutie-mark.png")))
rlm@519 315
rlm@519 316
rlm@502 317 (defn rgb->triplet [rgb]
rlm@502 318 (let [r (bit-shift-right (bit-and rgb 0xFF0000) 16)
rlm@502 319 g (bit-shift-right (bit-and rgb 0xFF00) 8)
rlm@502 320 b (bit-and rgb 0xFF)]
rlm@502 321 [r g b]))
rlm@502 322
rlm@502 323 (def reverse-gb-color-map
rlm@502 324 (zipmap (vals gb-color-map)
rlm@502 325 (keys gb-color-map)))
rlm@502 326
rlm@502 327 (defn vga-rgb->gb-rgb [[r g b]]
rlm@502 328 (reverse-gb-color-map [r g b]))
rlm@502 329
rlm@502 330 (defn gb-tiles [^BufferedImage image]
rlm@502 331 (for [tile (range 360)]
rlm@514 332 (for [y (range 8) x (range 8)]
rlm@502 333 (vga-rgb->gb-rgb
rlm@502 334 (rgb->triplet
rlm@503 335 (.getRGB image (+ x (* 8 (rem tile 20)))
rlm@503 336 (+ y (* 8 (int (/ tile 20))))))))))
rlm@503 337
rlm@503 338 (defn tile->palette [tile]
rlm@506 339 (vec (sort (set tile))))
rlm@503 340
rlm@503 341 (require 'clojure.set)
rlm@503 342
rlm@503 343 (defn absorb-contract [objs]
rlm@503 344 (reduce
rlm@503 345 (fn [accepted new-element]
rlm@503 346 (if (some
rlm@503 347 (fn [obj]
rlm@503 348 (clojure.set/subset? (set new-element) (set obj)))
rlm@503 349 accepted)
rlm@503 350 accepted
rlm@503 351 (conj accepted new-element)))
rlm@503 352 []
rlm@503 353 (sort-by (comp - count) objs)))
rlm@503 354
rlm@503 355 (defn palettes [^BufferedImage image]
rlm@503 356 (let [palettes (map tile->palette (gb-tiles image))
rlm@503 357 unique-palettes (absorb-contract (set palettes))]
rlm@503 358 unique-palettes))
rlm@505 359
rlm@506 360 (defn tile-pallete
rlm@506 361 "find the first appropirate palette for the tile in the
rlm@506 362 provided list of palettes."
rlm@506 363 [tile palettes]
rlm@506 364 (let [tile-colors (set tile)]
rlm@506 365 (swank.util/find-first
rlm@506 366 #(clojure.set/subset? tile-colors (set %))
rlm@506 367 palettes)))
rlm@506 368
rlm@506 369
rlm@506 370 (defn image->gb-image
rlm@506 371 "Returns the image in a format amenable to the gameboy's
rlm@506 372 internal representation. The format is:
rlm@506 373 {:width -- width of the image
rlm@506 374 :height -- height of the image
rlm@506 375 :palettes -- vector of all the palettes the image
rlm@506 376 needs, in proper order
rlm@506 377 :tiles -- vector of all the tiles the image needs,
rlm@506 378 in proper order. A tile is 64 palette
rlm@506 379 indices.
rlm@506 380 :data -- vector of pairs of the format:
rlm@506 381 [tile-index, palette-index]
rlm@506 382 in row-oriented order}"
rlm@506 383 [^BufferedImage image]
rlm@506 384 (let [image-palettes (palettes image)
rlm@506 385 palette-index (zipmap
rlm@506 386 image-palettes
rlm@506 387 (range (count image-palettes)))
rlm@506 388 tiles (gb-tiles image)
rlm@506 389 unique-tiles (vec (distinct tiles))
rlm@506 390 tile-index (zipmap unique-tiles
rlm@506 391 (range (count unique-tiles)))]
rlm@506 392 {:width (.getWidth image)
rlm@506 393 :height (.getHeight image)
rlm@506 394 :palettes image-palettes
rlm@506 395 :tiles
rlm@506 396 (vec
rlm@506 397 (for [tile unique-tiles]
rlm@506 398 (let [colors
rlm@506 399 (vec (tile-pallete tile image-palettes))
rlm@506 400 color-index
rlm@506 401 (zipmap colors (range (count colors)))]
rlm@506 402 (mapv color-index tile))))
rlm@506 403 :data
rlm@506 404 (vec
rlm@506 405 (for [tile tiles]
rlm@506 406 (let [tile-colors (set (tile->palette tile))]
rlm@506 407 [(tile-index tile)
rlm@506 408 (palette-index
rlm@506 409 (tile-pallete tile image-palettes))])))}))
rlm@506 410
rlm@505 411 (defn wait-until-v-blank
rlm@505 412 "Modified version of frame-metronome. waits untill LY == 144,
rlm@505 413 indicating start of v-blank period."
rlm@505 414 []
rlm@505 415 (let [timing-loop
rlm@505 416 [0x01 ; \
rlm@505 417 0x44 ; | load 0xFF44 into BC
rlm@505 418 0xFF ; /
rlm@505 419 0x0A] ;; (BC) -> A, now A = LY (vertical line coord)
rlm@505 420 continue-if-144
rlm@505 421 [0xFE
rlm@505 422 144 ;; compare LY (in A) with 144
rlm@505 423 0x20 ;; jump back to beginning if LY != 144 (not-v-blank)
rlm@505 424 (->signed-8-bit
rlm@505 425 (+ -4 (- (count timing-loop))))]]
rlm@505 426 (concat timing-loop continue-if-144)))
rlm@503 427
rlm@507 428 (def bg-character-data 0x9000)
rlm@507 429
rlm@507 430 (defn gb-tile->bytes
rlm@507 431 "Tile is a vector of 64 numbers between 0 and 3 that
rlm@507 432 represent a single 8x8 color tile in the GB screen.
rlm@507 433 It gets bit-packed into to 16 8-bit numbers in the following
rlm@507 434 form:
rlm@507 435
rlm@507 436 0-low 1-low ... 7-low
rlm@507 437 0-high 1-high ... 7-high
rlm@507 438 .
rlm@507 439 .
rlm@507 440 .
rlm@507 441 55-low ........ 63-low
rlm@507 442 55-high ........ 63-high"
rlm@507 443 [tile]
rlm@507 444 (let [row->bits
rlm@507 445 (fn [row]
rlm@507 446 (mapv
rlm@507 447 (fn [row*]
rlm@507 448 (Integer/parseInt (apply str row*) 2))
rlm@507 449 [(map #(bit-and 0x01 %) row)
rlm@507 450 (map #(bit-shift-right (bit-and 0x02 %) 1)
rlm@507 451 row)]))]
rlm@507 452 (vec
rlm@507 453 (flatten
rlm@507 454 (map row->bits
rlm@507 455 (partition 8 tile))))))
rlm@507 456
rlm@508 457 (defn write-data
rlm@508 458 "Efficient assembly to write a sequence of values to
rlm@508 459 memory, starting at a target address."
rlm@508 460 [base-address target-address data]
rlm@510 461 (let [len (count data)
rlm@510 462 program-length 21] ;; change this if program length
rlm@510 463 ;; below changes!
rlm@508 464 (flatten
rlm@508 465 [0x21 ;; load data address start into HL
rlm@510 466 (reverse (disect-bytes-2 (+ base-address program-length)))
rlm@508 467
rlm@508 468 0x01 ;; load target address into BC
rlm@508 469 (reverse (disect-bytes-2 target-address))
rlm@508 470
rlm@510 471 0x11 ;; load len into DE
rlm@510 472 (reverse (disect-bytes-2 len))
rlm@508 473
rlm@508 474
rlm@508 475 ;; data x-fer loop start
rlm@508 476 0x2A ;; (HL) -> A; HL++;
rlm@508 477 0x02 ;; A -> (BC);
rlm@508 478 0x03 ;; INC BC;
rlm@510 479 0x1B ;; DEC DE
rlm@508 480
rlm@510 481 0xAF
rlm@510 482 0xB2 ;; (OR D E) -> A
rlm@510 483 0xB3
rlm@510 484
rlm@508 485
rlm@510 486 0x20 ;; if DE is not now 0,
rlm@510 487 (->signed-8-bit -9) ;; GOTO start
rlm@508 488
rlm@510 489 0xC3
rlm@510 490 (reverse
rlm@510 491 (disect-bytes-2
rlm@510 492 (+ len base-address program-length)))
rlm@510 493 data])))
rlm@510 494
rlm@512 495 (defn write-image
rlm@514 496 "Assume the image data is specified as 360 blocks."
rlm@512 497 [base-address target-address image-data]
rlm@512 498
rlm@512 499 (let [len (count image-data)
rlm@512 500 gen-program
rlm@512 501 (fn [program-length]
rlm@512 502 (flatten
rlm@513 503 [0x01 ;; load data address start into BC
rlm@512 504 (reverse
rlm@512 505 (disect-bytes-2 (+ base-address program-length)))
rlm@512 506
rlm@513 507 0x21 ;; load target address into HL
rlm@512 508 (reverse (disect-bytes-2 target-address))
rlm@512 509
rlm@512 510 0x1E ;; total-rows (18) -> E
rlm@513 511 18
rlm@512 512
rlm@512 513 0x16 ;; total columns (20) -> D
rlm@512 514 20
rlm@512 515
rlm@513 516 ;; data x-fer loop start
rlm@513 517 0x0A ;; (BC) -> A;
rlm@513 518 0x03 ;; INC BC;
rlm@513 519 0x22 ;; A -> (HL); HL++;
rlm@512 520
rlm@512 521
rlm@512 522
rlm@512 523 0x15 ;; dec D
rlm@512 524 0x20
rlm@513 525 (->signed-8-bit -6) ;; continue writing row
rlm@512 526
rlm@512 527 ;; row is complete, advance to next row
rlm@513 528 ;; HL += 12
rlm@512 529
rlm@512 530 0xC5 ;; push BC
rlm@512 531
rlm@512 532 0x06 ;; 0 -> B
rlm@512 533 0
rlm@512 534
rlm@512 535 0x0E
rlm@513 536 12 ;; 12 -> C
rlm@512 537
rlm@512 538 0x09 ;; HL + BC -> HL
rlm@512 539
rlm@512 540 0xC1 ;; pop BC
rlm@512 541
rlm@512 542 0x1D ;; dec E
rlm@512 543 0x20
rlm@514 544 (->signed-8-bit -18) ;; contunue writing image
rlm@512 545
rlm@512 546 0xC3
rlm@512 547 (reverse
rlm@512 548 (disect-bytes-2
rlm@512 549 (+ len base-address program-length)))]))]
rlm@512 550 (flatten (concat
rlm@512 551 (gen-program (count (gen-program 0)))
rlm@512 552 image-data))))
rlm@508 553
rlm@508 554 (defn test-write-data []
rlm@510 555 (let [test-data (concat (range 256)
rlm@510 556 (reverse (range 256)))
rlm@510 557 base-address 0xC000
rlm@510 558 target-address 0xD000
rlm@508 559
rlm@508 560 test-kernel
rlm@508 561 (flatten
rlm@508 562 [0xF3 ;; disable interrupts
rlm@508 563 (write-data (+ 1 base-address)
rlm@508 564 target-address test-data)
rlm@508 565 (infinite-loop)])]
rlm@509 566 (assert
rlm@509 567 (= test-data
rlm@509 568 (-> (mid-game)
rlm@509 569 tick tick tick
rlm@509 570 (set-memory-range base-address test-kernel)
rlm@509 571 (PC! base-address)
rlm@509 572 (run-moves (repeat 100 []))
rlm@509 573 (memory)
rlm@509 574 vec
rlm@509 575 (subvec target-address
rlm@509 576 (+ target-address
rlm@509 577 (count test-data))))))))
rlm@508 578
rlm@511 579 (def LCD-bank-select-address 0xFF4F)
rlm@511 580
rlm@511 581 (def BG-1-address 0x9800)
rlm@511 582 (def BG-2-address 0x9C00)
rlm@511 583 (def character-data-address 0x8000)
rlm@511 584
rlm@511 585 (def LCD-control-register 0xFF40)
rlm@511 586 (def STAT-register 0xFF41)
rlm@511 587
rlm@511 588 (def SCX-register 0xFF42)
rlm@511 589 (def SCY-register 0xFF43)
rlm@511 590
rlm@511 591 (defn select-LCD-bank [n]
rlm@511 592 (assert (or (= n 0) (= n 1)))
rlm@511 593 (write-byte LCD-bank-select-address n))
rlm@511 594
rlm@512 595 (defn write-image* [_ _ _] [])
rlm@512 596
rlm@508 597 (defn display-image-kernel [base-address ^BufferedImage image]
rlm@511 598 (let [gb-image (image->gb-image image)
rlm@511 599
rlm@511 600 A [(clear-music-registers)
rlm@512 601
rlm@511 602 ;; [X] disable LCD protection circuit.
rlm@511 603 (write-byte LCD-control-register 0x00)
rlm@511 604 ;; now we can write to all video RAM anytime with
rlm@511 605 ;; impunity.
rlm@511 606
rlm@512 607 ;; [ ] We're only using background palettes; just set the
rlm@512 608 ;; minimum required bg palettes for this image, starting
rlm@512 609 ;; with palette #0.
rlm@502 610
rlm@511 611 (set-palettes bg-palette-select bg-palette-data
rlm@511 612 (:palettes gb-image))
rlm@507 613
rlm@511 614 ;; [X] switch to bank 0 to set BG character data.
rlm@511 615 (select-LCD-bank 0)
rlm@511 616 ;; [X] set SCX and SCY to 0
rlm@511 617 (write-byte SCX-register 0)
rlm@511 618 (write-byte SCY-register 0)
rlm@511 619 ]
rlm@511 620 A (flatten A)
rlm@507 621
rlm@511 622 B [;; [X] write minimum amount of tiles to BG character
rlm@511 623 ;; section
rlm@511 624 (write-data
rlm@511 625 (+ base-address (count A))
rlm@511 626 character-data-address
rlm@511 627 (flatten
rlm@515 628 (map gb-tile->bytes (:tiles gb-image))))
rlm@517 629 (select-LCD-bank 0)]
rlm@511 630 B (flatten B)
rlm@507 631
rlm@511 632
rlm@517 633 C [;; [X] write image to the screen in terms of tiles
rlm@512 634 (write-image
rlm@511 635 (+ base-address (+ (count A) (count B)))
rlm@511 636 BG-1-address
rlm@517 637 (map first (:data gb-image)))
rlm@517 638 (select-LCD-bank 1)]
rlm@507 639
rlm@511 640 C (flatten C)
rlm@507 641
rlm@517 642 D [;; [X] specifiy pallets for each character
rlm@515 643 (write-image
rlm@515 644 (+ base-address (+ (count A) (count B) (count C)))
rlm@515 645 BG-1-address
rlm@517 646 (map second (:data gb-image)))
rlm@515 647
rlm@505 648
rlm@511 649 ;; [X] reactivate the LCD display
rlm@511 650 ;; we're using only BG images, located at
rlm@511 651 ;; BG-1 (0x9800), with background character data
rlm@511 652 ;; stored starting at 0x8000
rlm@505 653
rlm@511 654 (write-byte
rlm@511 655 LCD-control-register
rlm@511 656 (Integer/parseInt
rlm@511 657 (str
rlm@511 658 "1" ;; LCDC on/off
rlm@511 659 "0" ;; Window code area
rlm@511 660 "0" ;; Windowing on?
rlm@511 661 "1" ;; BG tile base (1 = 0x8000)
rlm@511 662 "0" ;; BG-1 or BG-2 ?
rlm@511 663 "0" ;; OBJ-block composition
rlm@511 664 "0" ;; OBJ-on flag
rlm@511 665 "1") ;; no-effect
rlm@511 666 2))
rlm@540 667 ]
rlm@505 668
rlm@511 669 D (flatten D)]
rlm@511 670
rlm@511 671 (concat A B C D)))
rlm@511 672
rlm@511 673 (defn display-image [#^BufferedImage image]
rlm@522 674 (let [kernel-address 0xB500]
rlm@511 675 (-> (tick (tick (tick (mid-game))))
rlm@511 676 (set-memory-range
rlm@511 677 kernel-address
rlm@540 678 (concat (display-image-kernel kernel-address image)
rlm@540 679 (infinite-loop)))
rlm@511 680 (PC! kernel-address))))
rlm@522 681