Mercurial > vba-clojure

annotate clojure/com/aurellem/run/image.clj @ 516:7eac27143ab9

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