Mercurial > vba-clojure

annotate clojure/com/aurellem/run/image.clj @ 514:a00981db92da

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
can now display black and white images (still working on color).
author Robert McIntyre <rlm@mit.edu>
date Fri, 22 Jun 2012 21:03:04 -0500
parents 3dbb863eb801
children f68d600b089c
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@500 236 target (File. user-home "proj/vba-clojure/gb-color-map-unique.png")]
rlm@500 237 (dorun (for [x (range 68) y (range 69)]
rlm@500 238 (let [[r g b] (get pix (+ x (* 68 y)) [0 0 0])
rlm@499 239 rgb (+ (bit-shift-left r 16)
rlm@499 240 (bit-shift-left g 8)
rlm@499 241 b)]
rlm@505 242 (.setRGB im x y rgb))))
rlm@505 243 ;;(view im)
rlm@499 244 (doto
rlm@499 245 (.next (ImageIO/getImageWritersByFormatName "png"))
rlm@499 246 (.setOutput (FileImageOutputStream. target))
rlm@499 247 (.write (IIOImage. im nil nil))
rlm@499 248 (.dispose))
rlm@499 249 im))
rlm@499 250
rlm@499 251 (defn gen-gb-color-image*! []
rlm@499 252 (let [im (BufferedImage. 213 213 BufferedImage/TYPE_INT_RGB)
rlm@499 253 squares
rlm@499 254 (vec
rlm@499 255 (for [r (range 32)]
rlm@499 256 (vec
rlm@499 257 (for [b (range 32) g (range 32)]
rlm@499 258 (gb-color-map [r g b])))))
rlm@505 259 ;;view (cortex.sense/view-image)
rlm@499 260 target (File. user-home "proj/vba-clojure/gb-color-map.png")]
rlm@499 261
rlm@499 262 (dorun
rlm@499 263 (for [s-index (range 32)]
rlm@499 264 (dorun
rlm@499 265 (for [x (range 32) y (range 32)]
rlm@499 266
rlm@499 267 (let [[r g b] ((squares s-index) (+ x (* 32 y)))
rlm@499 268 rgb (+ (bit-shift-left r 16)
rlm@499 269 (bit-shift-left g 8)
rlm@499 270 b)]
rlm@499 271 (.setRGB im
rlm@499 272 (+ 3 (* 35 (rem s-index 6)) x)
rlm@499 273 (+ 3 (* 35 (int (/ s-index 6))) y)
rlm@499 274 rgb))))))
rlm@505 275 ;;(view im)
rlm@499 276 (doto
rlm@499 277 (.next (ImageIO/getImageWritersByFormatName "png"))
rlm@499 278 (.setOutput (FileImageOutputStream. target))
rlm@499 279 (.write (IIOImage. im nil nil))
rlm@499 280 (.dispose))
rlm@499 281 im))
rlm@501 282
rlm@502 283 (def test-image
rlm@502 284 (ImageIO/read
rlm@502 285 (File. user-home "/proj/vba-clojure/images/test-gb-image.png")))
rlm@502 286
rlm@514 287 (def test-image-2
rlm@514 288 (ImageIO/read
rlm@514 289 (File. user-home "/proj/vba-clojure/images/test-gb-image-2.png")))
rlm@514 290
rlm@514 291
rlm@514 292
rlm@502 293 (defn rgb->triplet [rgb]
rlm@502 294 (let [r (bit-shift-right (bit-and rgb 0xFF0000) 16)
rlm@502 295 g (bit-shift-right (bit-and rgb 0xFF00) 8)
rlm@502 296 b (bit-and rgb 0xFF)]
rlm@502 297 [r g b]))
rlm@502 298
rlm@502 299 (def reverse-gb-color-map
rlm@502 300 (zipmap (vals gb-color-map)
rlm@502 301 (keys gb-color-map)))
rlm@502 302
rlm@502 303 (defn vga-rgb->gb-rgb [[r g b]]
rlm@502 304 (reverse-gb-color-map [r g b]))
rlm@502 305
rlm@502 306 (defn gb-tiles [^BufferedImage image]
rlm@502 307 (for [tile (range 360)]
rlm@514 308 (for [y (range 8) x (range 8)]
rlm@502 309 (vga-rgb->gb-rgb
rlm@502 310 (rgb->triplet
rlm@503 311 (.getRGB image (+ x (* 8 (rem tile 20)))
rlm@503 312 (+ y (* 8 (int (/ tile 20))))))))))
rlm@503 313
rlm@503 314 (defn tile->palette [tile]
rlm@506 315 (vec (sort (set tile))))
rlm@503 316
rlm@503 317 (require 'clojure.set)
rlm@503 318
rlm@503 319 (defn absorb-contract [objs]
rlm@503 320 (reduce
rlm@503 321 (fn [accepted new-element]
rlm@503 322 (if (some
rlm@503 323 (fn [obj]
rlm@503 324 (clojure.set/subset? (set new-element) (set obj)))
rlm@503 325 accepted)
rlm@503 326 accepted
rlm@503 327 (conj accepted new-element)))
rlm@503 328 []
rlm@503 329 (sort-by (comp - count) objs)))
rlm@503 330
rlm@503 331 (defn palettes [^BufferedImage image]
rlm@503 332 (let [palettes (map tile->palette (gb-tiles image))
rlm@503 333 unique-palettes (absorb-contract (set palettes))]
rlm@503 334 unique-palettes))
rlm@505 335
rlm@506 336 (defn tile-pallete
rlm@506 337 "find the first appropirate palette for the tile in the
rlm@506 338 provided list of palettes."
rlm@506 339 [tile palettes]
rlm@506 340 (let [tile-colors (set tile)]
rlm@506 341 (swank.util/find-first
rlm@506 342 #(clojure.set/subset? tile-colors (set %))
rlm@506 343 palettes)))
rlm@506 344
rlm@506 345
rlm@506 346 (defn image->gb-image
rlm@506 347 "Returns the image in a format amenable to the gameboy's
rlm@506 348 internal representation. The format is:
rlm@506 349 {:width -- width of the image
rlm@506 350 :height -- height of the image
rlm@506 351 :palettes -- vector of all the palettes the image
rlm@506 352 needs, in proper order
rlm@506 353 :tiles -- vector of all the tiles the image needs,
rlm@506 354 in proper order. A tile is 64 palette
rlm@506 355 indices.
rlm@506 356 :data -- vector of pairs of the format:
rlm@506 357 [tile-index, palette-index]
rlm@506 358 in row-oriented order}"
rlm@506 359 [^BufferedImage image]
rlm@506 360 (let [image-palettes (palettes image)
rlm@506 361 palette-index (zipmap
rlm@506 362 image-palettes
rlm@506 363 (range (count image-palettes)))
rlm@506 364 tiles (gb-tiles image)
rlm@506 365 unique-tiles (vec (distinct tiles))
rlm@506 366 tile-index (zipmap unique-tiles
rlm@506 367 (range (count unique-tiles)))]
rlm@506 368 {:width (.getWidth image)
rlm@506 369 :height (.getHeight image)
rlm@506 370 :palettes image-palettes
rlm@506 371 :tiles
rlm@506 372 (vec
rlm@506 373 (for [tile unique-tiles]
rlm@506 374 (let [colors
rlm@506 375 (vec (tile-pallete tile image-palettes))
rlm@506 376 color-index
rlm@506 377 (zipmap colors (range (count colors)))]
rlm@506 378 (mapv color-index tile))))
rlm@506 379 :data
rlm@506 380 (vec
rlm@506 381 (for [tile tiles]
rlm@506 382 (let [tile-colors (set (tile->palette tile))]
rlm@506 383 [(tile-index tile)
rlm@506 384 (palette-index
rlm@506 385 (tile-pallete tile image-palettes))])))}))
rlm@506 386
rlm@505 387 (defn wait-until-v-blank
rlm@505 388 "Modified version of frame-metronome. waits untill LY == 144,
rlm@505 389 indicating start of v-blank period."
rlm@505 390 []
rlm@505 391 (let [timing-loop
rlm@505 392 [0x01 ; \
rlm@505 393 0x44 ; | load 0xFF44 into BC
rlm@505 394 0xFF ; /
rlm@505 395 0x0A] ;; (BC) -> A, now A = LY (vertical line coord)
rlm@505 396 continue-if-144
rlm@505 397 [0xFE
rlm@505 398 144 ;; compare LY (in A) with 144
rlm@505 399 0x20 ;; jump back to beginning if LY != 144 (not-v-blank)
rlm@505 400 (->signed-8-bit
rlm@505 401 (+ -4 (- (count timing-loop))))]]
rlm@505 402 (concat timing-loop continue-if-144)))
rlm@503 403
rlm@507 404 (def bg-character-data 0x9000)
rlm@507 405
rlm@507 406 (defn gb-tile->bytes
rlm@507 407 "Tile is a vector of 64 numbers between 0 and 3 that
rlm@507 408 represent a single 8x8 color tile in the GB screen.
rlm@507 409 It gets bit-packed into to 16 8-bit numbers in the following
rlm@507 410 form:
rlm@507 411
rlm@507 412 0-low 1-low ... 7-low
rlm@507 413 0-high 1-high ... 7-high
rlm@507 414 .
rlm@507 415 .
rlm@507 416 .
rlm@507 417 55-low ........ 63-low
rlm@507 418 55-high ........ 63-high"
rlm@507 419 [tile]
rlm@507 420 (let [row->bits
rlm@507 421 (fn [row]
rlm@507 422 (mapv
rlm@507 423 (fn [row*]
rlm@507 424 (Integer/parseInt (apply str row*) 2))
rlm@507 425 [(map #(bit-and 0x01 %) row)
rlm@507 426 (map #(bit-shift-right (bit-and 0x02 %) 1)
rlm@507 427 row)]))]
rlm@507 428 (vec
rlm@507 429 (flatten
rlm@507 430 (map row->bits
rlm@507 431 (partition 8 tile))))))
rlm@507 432
rlm@508 433 (defn write-data
rlm@508 434 "Efficient assembly to write a sequence of values to
rlm@508 435 memory, starting at a target address."
rlm@508 436 [base-address target-address data]
rlm@510 437 (let [len (count data)
rlm@510 438 program-length 21] ;; change this if program length
rlm@510 439 ;; below changes!
rlm@508 440 (flatten
rlm@508 441 [0x21 ;; load data address start into HL
rlm@510 442 (reverse (disect-bytes-2 (+ base-address program-length)))
rlm@508 443
rlm@508 444 0x01 ;; load target address into BC
rlm@508 445 (reverse (disect-bytes-2 target-address))
rlm@508 446
rlm@510 447 0x11 ;; load len into DE
rlm@510 448 (reverse (disect-bytes-2 len))
rlm@508 449
rlm@508 450
rlm@508 451 ;; data x-fer loop start
rlm@508 452 0x2A ;; (HL) -> A; HL++;
rlm@508 453 0x02 ;; A -> (BC);
rlm@508 454 0x03 ;; INC BC;
rlm@510 455 0x1B ;; DEC DE
rlm@508 456
rlm@510 457 0xAF
rlm@510 458 0xB2 ;; (OR D E) -> A
rlm@510 459 0xB3
rlm@510 460
rlm@508 461
rlm@510 462 0x20 ;; if DE is not now 0,
rlm@510 463 (->signed-8-bit -9) ;; GOTO start
rlm@508 464
rlm@510 465 0xC3
rlm@510 466 (reverse
rlm@510 467 (disect-bytes-2
rlm@510 468 (+ len base-address program-length)))
rlm@510 469 data])))
rlm@510 470
rlm@512 471 (defn write-image
rlm@514 472 "Assume the image data is specified as 360 blocks."
rlm@512 473 [base-address target-address image-data]
rlm@512 474
rlm@512 475 (let [len (count image-data)
rlm@512 476 gen-program
rlm@512 477 (fn [program-length]
rlm@512 478 (flatten
rlm@513 479 [0x01 ;; load data address start into BC
rlm@512 480 (reverse
rlm@512 481 (disect-bytes-2 (+ base-address program-length)))
rlm@512 482
rlm@513 483 0x21 ;; load target address into HL
rlm@512 484 (reverse (disect-bytes-2 target-address))
rlm@512 485
rlm@512 486 0x1E ;; total-rows (18) -> E
rlm@513 487 18
rlm@512 488
rlm@512 489 0x16 ;; total columns (20) -> D
rlm@512 490 20
rlm@512 491
rlm@513 492 ;; data x-fer loop start
rlm@513 493 0x0A ;; (BC) -> A;
rlm@513 494 0x03 ;; INC BC;
rlm@513 495 0x22 ;; A -> (HL); HL++;
rlm@512 496
rlm@512 497
rlm@512 498
rlm@512 499 0x15 ;; dec D
rlm@512 500 0x20
rlm@513 501 (->signed-8-bit -6) ;; continue writing row
rlm@512 502
rlm@512 503 ;; row is complete, advance to next row
rlm@513 504 ;; HL += 12
rlm@512 505
rlm@512 506 0xC5 ;; push BC
rlm@512 507
rlm@512 508 0x06 ;; 0 -> B
rlm@512 509 0
rlm@512 510
rlm@512 511 0x0E
rlm@513 512 12 ;; 12 -> C
rlm@512 513
rlm@512 514 0x09 ;; HL + BC -> HL
rlm@512 515
rlm@512 516 0xC1 ;; pop BC
rlm@512 517
rlm@512 518 0x1D ;; dec E
rlm@512 519 0x20
rlm@514 520 (->signed-8-bit -18) ;; contunue writing image
rlm@512 521
rlm@512 522 0xC3
rlm@512 523 (reverse
rlm@512 524 (disect-bytes-2
rlm@512 525 (+ len base-address program-length)))]))]
rlm@512 526 (flatten (concat
rlm@512 527 (gen-program (count (gen-program 0)))
rlm@512 528 image-data))))
rlm@508 529
rlm@508 530 (defn test-write-data []
rlm@510 531 (let [test-data (concat (range 256)
rlm@510 532 (reverse (range 256)))
rlm@510 533 base-address 0xC000
rlm@510 534 target-address 0xD000
rlm@508 535
rlm@508 536 test-kernel
rlm@508 537 (flatten
rlm@508 538 [0xF3 ;; disable interrupts
rlm@508 539 (write-data (+ 1 base-address)
rlm@508 540 target-address test-data)
rlm@508 541 (infinite-loop)])]
rlm@509 542 (assert
rlm@509 543 (= test-data
rlm@509 544 (-> (mid-game)
rlm@509 545 tick tick tick
rlm@509 546 (set-memory-range base-address test-kernel)
rlm@509 547 (PC! base-address)
rlm@509 548 (run-moves (repeat 100 []))
rlm@509 549 (memory)
rlm@509 550 vec
rlm@509 551 (subvec target-address
rlm@509 552 (+ target-address
rlm@509 553 (count test-data))))))))
rlm@508 554
rlm@511 555 (def LCD-bank-select-address 0xFF4F)
rlm@511 556
rlm@511 557 (def BG-1-address 0x9800)
rlm@511 558 (def BG-2-address 0x9C00)
rlm@511 559 (def character-data-address 0x8000)
rlm@511 560
rlm@511 561 (def LCD-control-register 0xFF40)
rlm@511 562 (def STAT-register 0xFF41)
rlm@511 563
rlm@511 564 (def SCX-register 0xFF42)
rlm@511 565 (def SCY-register 0xFF43)
rlm@511 566
rlm@511 567 (defn select-LCD-bank [n]
rlm@511 568 (assert (or (= n 0) (= n 1)))
rlm@511 569 (write-byte LCD-bank-select-address n))
rlm@511 570
rlm@512 571 (defn write-image* [_ _ _] [])
rlm@512 572
rlm@508 573 (defn display-image-kernel [base-address ^BufferedImage image]
rlm@511 574 (let [gb-image (image->gb-image image)
rlm@511 575
rlm@511 576 A [(clear-music-registers)
rlm@512 577
rlm@511 578 ;; [X] disable LCD protection circuit.
rlm@511 579 (write-byte LCD-control-register 0x00)
rlm@511 580 ;; now we can write to all video RAM anytime with
rlm@511 581 ;; impunity.
rlm@511 582
rlm@512 583 ;; [ ] We're only using background palettes; just set the
rlm@512 584 ;; minimum required bg palettes for this image, starting
rlm@512 585 ;; with palette #0.
rlm@502 586
rlm@511 587 (set-palettes bg-palette-select bg-palette-data
rlm@511 588 (:palettes gb-image))
rlm@507 589
rlm@511 590 ;; [X] switch to bank 0 to set BG character data.
rlm@511 591 (select-LCD-bank 0)
rlm@511 592 ;; [X] set SCX and SCY to 0
rlm@511 593 (write-byte SCX-register 0)
rlm@511 594 (write-byte SCY-register 0)
rlm@511 595 ]
rlm@511 596 A (flatten A)
rlm@507 597
rlm@511 598 B [;; [X] write minimum amount of tiles to BG character
rlm@511 599 ;; section
rlm@511 600 (write-data
rlm@511 601 (+ base-address (count A))
rlm@511 602 character-data-address
rlm@511 603 (flatten
rlm@511 604 (map gb-tile->bytes (:tiles gb-image))))]
rlm@511 605 B (flatten B)
rlm@507 606
rlm@511 607
rlm@511 608 C [;; [ ] write image to the screen in terms of tiles
rlm@512 609 (write-image
rlm@511 610 (+ base-address (+ (count A) (count B)))
rlm@511 611 BG-1-address
rlm@511 612 (map first (:data gb-image)))]
rlm@507 613
rlm@511 614 C (flatten C)
rlm@507 615
rlm@511 616 D [;; [ ] specifiy pallets for each character
rlm@511 617 (select-LCD-bank 1)
rlm@514 618 ;;(write-image
rlm@514 619 ;; (+ base-address (+ (count A) (count B) (count C)))
rlm@514 620 ;; BG-1-address
rlm@514 621 ;;(map second (:data gb-image)))
rlm@507 622
rlm@505 623
rlm@511 624 ;; [X] reactivate the LCD display
rlm@511 625 ;; we're using only BG images, located at
rlm@511 626 ;; BG-1 (0x9800), with background character data
rlm@511 627 ;; stored starting at 0x8000
rlm@505 628
rlm@511 629 (write-byte
rlm@511 630 LCD-control-register
rlm@511 631 (Integer/parseInt
rlm@511 632 (str
rlm@511 633 "1" ;; LCDC on/off
rlm@511 634 "0" ;; Window code area
rlm@511 635 "0" ;; Windowing on?
rlm@511 636 "1" ;; BG tile base (1 = 0x8000)
rlm@511 637 "0" ;; BG-1 or BG-2 ?
rlm@511 638 "0" ;; OBJ-block composition
rlm@511 639 "0" ;; OBJ-on flag
rlm@511 640 "1") ;; no-effect
rlm@511 641 2))
rlm@505 642
rlm@511 643 (infinite-loop)]
rlm@511 644 D (flatten D)]
rlm@511 645
rlm@511 646 (concat A B C D)))
rlm@511 647
rlm@511 648 (defn display-image [#^BufferedImage image]
rlm@511 649 (let [kernel-address 0xB000]
rlm@511 650 (-> (tick (tick (tick (mid-game))))
rlm@511 651 (set-memory-range
rlm@511 652 kernel-address
rlm@511 653 (display-image-kernel kernel-address image))
rlm@511 654 (PC! kernel-address))))