Mercurial > vba-clojure

annotate clojure/com/aurellem/run/image.clj @ 508:e6c02264dc9c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
trying to track down pesky assembly bug.
author Robert McIntyre <rlm@mit.edu>
date Wed, 20 Jun 2012 21:41:38 -0500
parents 24b459a95b46
children d2c40a12de28
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@488 35
rlm@488 36
rlm@488 37
rlm@488 38
rlm@488 39
rlm@488 40
rlm@488 41
rlm@488 42
rlm@488 43
rlm@488 44
rlm@488 45
rlm@491 46 (def image-program-target 0xB000)
rlm@486 47
rlm@491 48 (def display-width 160)
rlm@491 49 (def display-height 144)
rlm@491 50
rlm@491 51
rlm@491 52
rlm@491 53 ;{:r :g :b }
rlm@491 54
rlm@491 55 (def character-data 0x8000)
rlm@491 56 (def character-data-end 0x97FF)
rlm@491 57
rlm@491 58
rlm@491 59
rlm@491 60
rlm@491 61 (def BG-data-1 0x9800)
rlm@491 62
rlm@491 63 (def BG-data-2 0x9C00)
rlm@491 64
rlm@491 65 (def OAM 0xFE00)
rlm@491 66
rlm@491 67
rlm@491 68
rlm@491 69 (def video-bank-select-register 0xFF4F)
rlm@491 70
rlm@492 71 (defn gb-rgb->bits [[r g b]]
rlm@492 72 (assert (<= 0 r 31))
rlm@492 73 (assert (<= 0 g 31))
rlm@492 74 (assert (<= 0 b 31))
rlm@491 75 [(bit-and
rlm@491 76 0xFF
rlm@491 77 (+
rlm@491 78 r
rlm@491 79 (bit-shift-left g 5)))
rlm@491 80 (+
rlm@491 81 (bit-shift-right g 3)
rlm@491 82 (bit-shift-left b 2))])
rlm@491 83
rlm@492 84
rlm@492 85 (def bg-palette-select 0xFF68)
rlm@492 86 (def bg-palette-data 0xFF69)
rlm@492 87
rlm@492 88 (def obj-palette-select 0xFF6A)
rlm@492 89 (def obj-palette-data 0xFF6B)
rlm@492 90
rlm@492 91 (def max-palettes 8)
rlm@492 92
rlm@492 93 (defn write-data [target data]
rlm@492 94 (flatten
rlm@492 95 [0x3E ;; load literal to A
rlm@492 96 data
rlm@492 97 0xEA ;; load A into target
rlm@493 98 (reverse (disect-bytes-2 target))]))
rlm@492 99
rlm@492 100 (defn begin-sequential-palette-write
rlm@492 101 [palette-num palette-select-address]
rlm@492 102 (assert (<= 0 palette-num max-palettes))
rlm@492 103 (assert
rlm@492 104 (or (= palette-select-address bg-palette-select)
rlm@492 105 (= palette-select-address obj-palette-select)))
rlm@492 106 (let [palette-write-data
rlm@492 107 (Integer/parseInt
rlm@492 108 (str "1" ;; auto increment
rlm@492 109 "0" ;; not used
rlm@492 110 (format
rlm@492 111 "%03d"
rlm@492 112 (Integer/parseInt
rlm@492 113 (Integer/toBinaryString palette-num) 10))
rlm@492 114 "00" ;; color num
rlm@492 115 "0" ;; H/L
rlm@492 116 ) 2)]
rlm@492 117 (write-data palette-select-address palette-write-data)))
rlm@492 118
rlm@492 119 (defn set-palettes [palette-select palette-data palettes]
rlm@492 120 (assert (<= (count palettes)) max-palettes)
rlm@492 121 (flatten
rlm@492 122 [(begin-sequential-palette-write 0 palette-select)
rlm@492 123 (map (partial write-data palette-data)
rlm@492 124 (flatten (map gb-rgb->bits palettes)))]))
rlm@492 125
rlm@491 126 (defn display-one-color
rlm@507 127 "Displayes a single color onto the gameboy screen. Input rgb in
rlm@491 128 gameboy rgb."
rlm@498 129 ([state [r g b]]
rlm@498 130 ;; construct a kernel that displays a single color
rlm@498 131 (let
rlm@498 132 [palettes (repeat 8 [r g b])
rlm@498 133 kernel-address 0xC000
rlm@498 134 kernel
rlm@498 135 [0xF3 ;; disable interrupts
rlm@498 136 (clear-music-registers)
rlm@498 137 (frame-metronome)
rlm@498 138 (set-palettes obj-palette-select obj-palette-data palettes)
rlm@498 139 (set-palettes bg-palette-select bg-palette-data palettes)
rlm@498 140 (infinite-loop)]]
rlm@498 141 (-> (set-memory-range state
rlm@498 142 kernel-address (flatten kernel))
rlm@498 143 (PC! kernel-address))))
rlm@498 144 ([[r g b]]
rlm@498 145 (display-one-color @current-state [r g b])))
rlm@492 146
rlm@505 147 ;;(require 'cortex.sense)
rlm@496 148 (import java.awt.image.BufferedImage)
rlm@492 149
rlm@505 150 ;; (defn show-screenshot []
rlm@505 151 ;; (let [im (BufferedImage. 160 144 BufferedImage/TYPE_INT_RGB)
rlm@505 152 ;; pix (vec (pixels))
rlm@505 153 ;; view (cortex.sense/view-image)]
rlm@505 154 ;; (dorun (for [x (range 160) y (range 144)]
rlm@505 155 ;; (.setRGB im x y (pix (+ x (* 160 y))))))
rlm@505 156 ;; (view im)))
rlm@496 157
rlm@500 158 (defn gb-rgb->vga-rgb [[r g b]]
rlm@498 159 (let [vga-rgb
rlm@498 160 (first (pixels
rlm@498 161 (run-moves
rlm@498 162 (display-one-color
rlm@498 163 (tick @current-state)
rlm@498 164 [r g b])
rlm@498 165 [[][]])))]
rlm@498 166 [(bit-shift-right (bit-and vga-rgb 0xFF0000) 16)
rlm@498 167 (bit-shift-right (bit-and vga-rgb 0xFF00) 8)
rlm@498 168 (bit-and vga-rgb 0xFF)]))
rlm@491 169
rlm@498 170 (defn generate-gb-color-map []
rlm@498 171 (set-state! (mid-game))
rlm@498 172 (let [gb-colors
rlm@498 173 (for [r (range 32)
rlm@498 174 g (range 32)
rlm@498 175 b (range 32)]
rlm@498 176 [r g b])]
rlm@498 177 (zipmap gb-colors
rlm@498 178 (map gb-rgb->vga-rgb
rlm@498 179 gb-colors))))
rlm@491 180
rlm@498 181 (import java.io.FileWriter)
rlm@491 182
rlm@498 183 (def gb-color-map-file
rlm@498 184 (File. user-home "proj/vba-clojure/gb-color-map"))
rlm@495 185
rlm@498 186 (defn write-gb-color-map! []
rlm@498 187 (binding [*out*(FileWriter. gb-color-map-file)]
rlm@498 188 (let [out-str
rlm@498 189 (.replace
rlm@498 190 (str
rlm@498 191 (into (sorted-map) (generate-gb-color-map)))
rlm@498 192 "," ",\n")]
rlm@498 193 (println out-str))))
rlm@498 194
rlm@499 195 (def gb-color-map
rlm@499 196 (read-string (slurp gb-color-map-file)))
rlm@499 197
rlm@499 198 (import javax.imageio.stream.FileImageOutputStream)
rlm@499 199 (import '(javax.imageio ImageWriteParam IIOImage ImageIO))
rlm@499 200
rlm@499 201
rlm@499 202 (defn gen-gb-color-image! []
rlm@500 203 (let [im (BufferedImage. 68 69 BufferedImage/TYPE_INT_RGB)
rlm@499 204 pix (vec
rlm@499 205
rlm@499 206 (reduce
rlm@499 207 concat
rlm@499 208 (map (partial
rlm@499 209 sort-by
rlm@499 210 (fn [[r g b]]
rlm@499 211 (let [s (max r g b)
rlm@499 212 det
rlm@499 213 (cond
rlm@499 214 (= s r)
rlm@499 215 (+ -1000 (- g) b)
rlm@499 216 (= s b)
rlm@499 217 (+ (- r) g)
rlm@499 218 (= s g)
rlm@499 219 (+ 1000 (- b) r))]
rlm@499 220 det)))
rlm@499 221 (partition
rlm@500 222 68 68 []
rlm@499 223 (sort-by
rlm@499 224 (fn euclidean-distance [[r g b]]
rlm@499 225 (Math/sqrt (+ (* r r) (* g g) (* b b))))
rlm@501 226 (filter
rlm@501 227 (fn [[r g b]]
rlm@501 228 (= (max r g b) b ))
rlm@501 229
rlm@501 230 (seq (set (vals gb-color-map)))))))))
rlm@505 231 ;;view (cortex.sense/view-image)
rlm@500 232 target (File. user-home "proj/vba-clojure/gb-color-map-unique.png")]
rlm@500 233 (dorun (for [x (range 68) y (range 69)]
rlm@500 234 (let [[r g b] (get pix (+ x (* 68 y)) [0 0 0])
rlm@499 235 rgb (+ (bit-shift-left r 16)
rlm@499 236 (bit-shift-left g 8)
rlm@499 237 b)]
rlm@505 238 (.setRGB im x y rgb))))
rlm@505 239 ;;(view im)
rlm@499 240 (doto
rlm@499 241 (.next (ImageIO/getImageWritersByFormatName "png"))
rlm@499 242 (.setOutput (FileImageOutputStream. target))
rlm@499 243 (.write (IIOImage. im nil nil))
rlm@499 244 (.dispose))
rlm@499 245 im))
rlm@499 246
rlm@499 247 (defn gen-gb-color-image*! []
rlm@499 248 (let [im (BufferedImage. 213 213 BufferedImage/TYPE_INT_RGB)
rlm@499 249 squares
rlm@499 250 (vec
rlm@499 251 (for [r (range 32)]
rlm@499 252 (vec
rlm@499 253 (for [b (range 32) g (range 32)]
rlm@499 254 (gb-color-map [r g b])))))
rlm@505 255 ;;view (cortex.sense/view-image)
rlm@499 256 target (File. user-home "proj/vba-clojure/gb-color-map.png")]
rlm@499 257
rlm@499 258 (dorun
rlm@499 259 (for [s-index (range 32)]
rlm@499 260 (dorun
rlm@499 261 (for [x (range 32) y (range 32)]
rlm@499 262
rlm@499 263 (let [[r g b] ((squares s-index) (+ x (* 32 y)))
rlm@499 264 rgb (+ (bit-shift-left r 16)
rlm@499 265 (bit-shift-left g 8)
rlm@499 266 b)]
rlm@499 267 (.setRGB im
rlm@499 268 (+ 3 (* 35 (rem s-index 6)) x)
rlm@499 269 (+ 3 (* 35 (int (/ s-index 6))) y)
rlm@499 270 rgb))))))
rlm@505 271 ;;(view im)
rlm@499 272 (doto
rlm@499 273 (.next (ImageIO/getImageWritersByFormatName "png"))
rlm@499 274 (.setOutput (FileImageOutputStream. target))
rlm@499 275 (.write (IIOImage. im nil nil))
rlm@499 276 (.dispose))
rlm@499 277 im))
rlm@501 278
rlm@502 279 (def test-image
rlm@502 280 (ImageIO/read
rlm@502 281 (File. user-home "/proj/vba-clojure/images/test-gb-image.png")))
rlm@502 282
rlm@502 283 (defn rgb->triplet [rgb]
rlm@502 284 (let [r (bit-shift-right (bit-and rgb 0xFF0000) 16)
rlm@502 285 g (bit-shift-right (bit-and rgb 0xFF00) 8)
rlm@502 286 b (bit-and rgb 0xFF)]
rlm@502 287 [r g b]))
rlm@502 288
rlm@502 289 (def reverse-gb-color-map
rlm@502 290 (zipmap (vals gb-color-map)
rlm@502 291 (keys gb-color-map)))
rlm@502 292
rlm@502 293 (defn vga-rgb->gb-rgb [[r g b]]
rlm@502 294 (reverse-gb-color-map [r g b]))
rlm@502 295
rlm@502 296 (defn gb-tiles [^BufferedImage image]
rlm@502 297 (for [tile (range 360)]
rlm@502 298 (for [x (range 8) y (range 8)]
rlm@502 299 (vga-rgb->gb-rgb
rlm@502 300 (rgb->triplet
rlm@503 301 (.getRGB image (+ x (* 8 (rem tile 20)))
rlm@503 302 (+ y (* 8 (int (/ tile 20))))))))))
rlm@503 303
rlm@503 304 (defn tile->palette [tile]
rlm@506 305 (vec (sort (set tile))))
rlm@503 306
rlm@503 307 (require 'clojure.set)
rlm@503 308
rlm@503 309 (defn absorb-contract [objs]
rlm@503 310 (reduce
rlm@503 311 (fn [accepted new-element]
rlm@503 312 (if (some
rlm@503 313 (fn [obj]
rlm@503 314 (clojure.set/subset? (set new-element) (set obj)))
rlm@503 315 accepted)
rlm@503 316 accepted
rlm@503 317 (conj accepted new-element)))
rlm@503 318 []
rlm@503 319 (sort-by (comp - count) objs)))
rlm@503 320
rlm@503 321 (defn absorb-combine-4 [objs]
rlm@504 322
rlm@503 323 )
rlm@503 324
rlm@503 325 (defn palettes [^BufferedImage image]
rlm@503 326 (let [palettes (map tile->palette (gb-tiles image))
rlm@503 327 unique-palettes (absorb-contract (set palettes))]
rlm@503 328 unique-palettes))
rlm@505 329
rlm@506 330 (defn tile-pallete
rlm@506 331 "find the first appropirate palette for the tile in the
rlm@506 332 provided list of palettes."
rlm@506 333 [tile palettes]
rlm@506 334 (let [tile-colors (set tile)]
rlm@506 335 (swank.util/find-first
rlm@506 336 #(clojure.set/subset? tile-colors (set %))
rlm@506 337 palettes)))
rlm@506 338
rlm@506 339
rlm@506 340 (defn image->gb-image
rlm@506 341 "Returns the image in a format amenable to the gameboy's
rlm@506 342 internal representation. The format is:
rlm@506 343 {:width -- width of the image
rlm@506 344 :height -- height of the image
rlm@506 345 :palettes -- vector of all the palettes the image
rlm@506 346 needs, in proper order
rlm@506 347 :tiles -- vector of all the tiles the image needs,
rlm@506 348 in proper order. A tile is 64 palette
rlm@506 349 indices.
rlm@506 350 :data -- vector of pairs of the format:
rlm@506 351 [tile-index, palette-index]
rlm@506 352 in row-oriented order}"
rlm@506 353 [^BufferedImage image]
rlm@506 354 (let [image-palettes (palettes image)
rlm@506 355 palette-index (zipmap
rlm@506 356 image-palettes
rlm@506 357 (range (count image-palettes)))
rlm@506 358 tiles (gb-tiles image)
rlm@506 359 unique-tiles (vec (distinct tiles))
rlm@506 360 tile-index (zipmap unique-tiles
rlm@506 361 (range (count unique-tiles)))]
rlm@506 362 {:width (.getWidth image)
rlm@506 363 :height (.getHeight image)
rlm@506 364 :palettes image-palettes
rlm@506 365 :tiles
rlm@506 366 (vec
rlm@506 367 (for [tile unique-tiles]
rlm@506 368 (let [colors
rlm@506 369 (vec (tile-pallete tile image-palettes))
rlm@506 370 color-index
rlm@506 371 (zipmap colors (range (count colors)))]
rlm@506 372 (mapv color-index tile))))
rlm@506 373 :data
rlm@506 374 (vec
rlm@506 375 (for [tile tiles]
rlm@506 376 (let [tile-colors (set (tile->palette tile))]
rlm@506 377 [(tile-index tile)
rlm@506 378 (palette-index
rlm@506 379 (tile-pallete tile image-palettes))])))}))
rlm@506 380
rlm@506 381
rlm@506 382
rlm@505 383 (defn wait-until-v-blank
rlm@505 384 "Modified version of frame-metronome. waits untill LY == 144,
rlm@505 385 indicating start of v-blank period."
rlm@505 386 []
rlm@505 387 (let [timing-loop
rlm@505 388 [0x01 ; \
rlm@505 389 0x44 ; | load 0xFF44 into BC
rlm@505 390 0xFF ; /
rlm@505 391 0x0A] ;; (BC) -> A, now A = LY (vertical line coord)
rlm@505 392 continue-if-144
rlm@505 393 [0xFE
rlm@505 394 144 ;; compare LY (in A) with 144
rlm@505 395 0x20 ;; jump back to beginning if LY != 144 (not-v-blank)
rlm@505 396 (->signed-8-bit
rlm@505 397 (+ -4 (- (count timing-loop))))]]
rlm@505 398 (concat timing-loop continue-if-144)))
rlm@503 399
rlm@503 400
rlm@507 401 (def bg-character-data 0x9000)
rlm@507 402
rlm@507 403 (defn gb-tile->bytes
rlm@507 404 "Tile is a vector of 64 numbers between 0 and 3 that
rlm@507 405 represent a single 8x8 color tile in the GB screen.
rlm@507 406 It gets bit-packed into to 16 8-bit numbers in the following
rlm@507 407 form:
rlm@507 408
rlm@507 409 0-low 1-low ... 7-low
rlm@507 410 0-high 1-high ... 7-high
rlm@507 411 .
rlm@507 412 .
rlm@507 413 .
rlm@507 414 55-low ........ 63-low
rlm@507 415 55-high ........ 63-high"
rlm@507 416 [tile]
rlm@507 417 (let [row->bits
rlm@507 418 (fn [row]
rlm@507 419 (mapv
rlm@507 420 (fn [row*]
rlm@507 421 (Integer/parseInt (apply str row*) 2))
rlm@507 422 [(map #(bit-and 0x01 %) row)
rlm@507 423 (map #(bit-shift-right (bit-and 0x02 %) 1)
rlm@507 424 row)]))]
rlm@507 425 (vec
rlm@507 426 (flatten
rlm@507 427 (map row->bits
rlm@507 428 (partition 8 tile))))))
rlm@507 429
rlm@502 430
rlm@508 431 (defn write-data
rlm@508 432 "Efficient assembly to write a sequence of values to
rlm@508 433 memory, starting at a target address."
rlm@508 434 [base-address target-address data]
rlm@508 435 (let [len (count data)]
rlm@508 436 (flatten
rlm@508 437 (if (<= len 255)
rlm@508 438 [0x21 ;; load data address start into HL
rlm@508 439 (reverse (disect-bytes-2 (+ 16 base-address)))
rlm@508 440
rlm@508 441 0x01 ;; load target address into BC
rlm@508 442 (reverse (disect-bytes-2 target-address))
rlm@508 443
rlm@508 444 0x16 ;; load len into D
rlm@508 445 len
rlm@508 446
rlm@508 447
rlm@508 448 ;; data x-fer loop start
rlm@508 449 0x2A ;; (HL) -> A; HL++;
rlm@508 450 0x02 ;; A -> (BC);
rlm@508 451 0x03 ;; INC BC;
rlm@508 452 0x15 ;; DEC D
rlm@508 453
rlm@508 454 0x20 ;; if D is not now 0,
rlm@508 455 (->signed-8-bit -6) ;; GOTO start
rlm@508 456
rlm@508 457 0x18
rlm@508 458 len
rlm@508 459
rlm@508 460 data]
rlm@508 461 (let [first-part (write-data base-address target-address
rlm@508 462 (take 255 data))]
rlm@508 463 [first-part
rlm@508 464 (write-data (+ base-address (count first-part))
rlm@508 465 (+ target-address 255)
rlm@508 466 (drop 255 data))])))))
rlm@508 467
rlm@508 468 (defn test-write-data []
rlm@508 469 (let [test-data (repeat 3 0xD3)
rlm@508 470 base-address 0xA000
rlm@508 471 target-address 0xA500
rlm@508 472
rlm@508 473 test-kernel
rlm@508 474 (flatten
rlm@508 475 [0xF3 ;; disable interrupts
rlm@508 476 (write-data (+ 1 base-address)
rlm@508 477 target-address test-data)
rlm@508 478 (infinite-loop)])]
rlm@508 479 ;; (assert
rlm@508 480 ;; (= test-data
rlm@508 481 (-> (mid-game)
rlm@508 482 tick tick tick
rlm@508 483 (set-memory-range base-address test-kernel)
rlm@508 484 (PC! base-address)
rlm@508 485
rlm@508 486 ;;(run-moves (repeat 100 []))
rlm@508 487 ;;(memory)
rlm@508 488 ;;vec
rlm@508 489 ;;(subvec target-address
rlm@508 490 ;; (+ target-address
rlm@508 491 ;; (count test-data)))
rlm@508 492 ;;println
rlm@508 493 )))
rlm@508 494
rlm@508 495
rlm@508 496
rlm@508 497
rlm@508 498
rlm@508 499
rlm@508 500
rlm@508 501 (defn display-image-kernel [base-address ^BufferedImage image]
rlm@507 502 (let [gb-image (image->gb-image image)]
rlm@507 503
rlm@507 504 [(clear-music-registers)
rlm@502 505
rlm@507 506 ;; [ ] disable LCD protection circuit.
rlm@507 507
rlm@507 508 ;; now we can write to all video RAM anytime with
rlm@507 509 ;; impunity.
rlm@507 510
rlm@507 511
rlm@507 512
rlm@507 513 ;; we're only using background palettes; just set the
rlm@507 514 ;; minimum required bg palettes for this image,
rlm@507 515 ;; starting with palette #0.
rlm@507 516
rlm@507 517 (set-palettes bg-palette-select bg-palette-data
rlm@507 518 (:palettes gb-image))
rlm@507 519
rlm@507 520 ;; [ ] switch to bank 0 to set BG character data.
rlm@507 521
rlm@507 522
rlm@507 523 ;; [ ] write minimum amount of tiles to BG character
rlm@507 524 ;; section
rlm@507 525
rlm@507 526
rlm@507 527 ;; [ ] disable the display of OBJ tiles.
rlm@507 528
rlm@507 529
rlm@507 530 ;; [ ] reactivate the LCD display
rlm@507 531
rlm@507 532
rlm@508 533 (infinite-loop)]
rlm@507 534
rlm@507 535
rlm@508 536 ))
rlm@505 537
rlm@505 538
rlm@505 539