Mercurial > vba-clojure

annotate clojure/com/aurellem/run/image.clj @ 552:9068685e7d96

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
moduralized main-bootstrap-program
author Robert McIntyre <rlm@mit.edu>
date Thu, 30 Aug 2012 12:09:15 -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