Mercurial > vba-clojure
view clojure/com/aurellem/run/image.clj @ 572:58a25fa15176
minor formatting changes.
author | Robert McIntyre <rlm@mit.edu> |
---|---|
date | Sat, 01 Sep 2012 03:42:16 -0500 |
parents | 7f8030812ac2 |
children |
line wrap: on
line source
1 (ns com.aurellem.run.image2 (:use (com.aurellem.gb saves gb-driver util constants3 items vbm characters money4 rlm-assembly))5 (:use (com.aurellem.run util music title save-corruption6 bootstrap-0 bootstrap-1))7 (:require clojure.string)8 (:import [com.aurellem.gb.gb_driver SaveState])9 (:import java.awt.image.BufferedImage)10 (:import java.io.File))12 ;; want to display an image onto the screen.13 ;; probably will be the six ponies, possibly with scrolling.15 ;; probably don't need hi-color mode since the images shuld be16 ;; simple.18 ;; use background tiles? they provide greater color depth than19 ;; sprites, and can still be scrolled, so why not?21 ;; could also use sprites to get 3 more colors per tile for a total of22 ;; 7 colors per tile, although not for all tiles...26 ;; want a function to28 ;; 1. read an image29 ;; 2. split into a grid of 8x8 pixels30 ;; 3. convert all RGB colors to gb-RGB colors31 ;; 4. determine efficient color palletes for the image32 ;; 5. output efficient assembly code to draw the image to the gb33 ;; screen.36 (def image-program-target 0xB000)38 (def display-width 160)39 (def display-height 144)43 ;{:r :g :b }45 (def character-data 0x8000)46 (def character-data-end 0x97FF)51 (def BG-data-1 0x9800)53 (def BG-data-2 0x9C00)55 (def OAM 0xFE00)59 (def video-bank-select-register 0xFF4F)61 (defn gb-rgb->bits [[r g b]]62 (assert (<= 0 r 31))63 (assert (<= 0 g 31))64 (assert (<= 0 b 31))65 [(bit-and66 0xFF67 (+68 r69 (bit-shift-left g 5)))70 (+71 (bit-shift-right g 3)72 (bit-shift-left b 2))])75 (def bg-palette-select 0xFF68)76 (def bg-palette-data 0xFF69)78 (def obj-palette-select 0xFF6A)79 (def obj-palette-data 0xFF6B)81 (def max-palettes 8)83 (defn write-byte [target data]84 (flatten85 [0x3E ;; load literal to A86 data87 0xEA ;; load A into target88 (reverse (disect-bytes-2 target))]))90 (defn begin-sequential-palette-write91 [palette-num palette-select-address]92 (assert (<= 0 palette-num max-palettes))93 (assert94 (or (= palette-select-address bg-palette-select)95 (= palette-select-address obj-palette-select)))96 (let [palette-write-data97 (Integer/parseInt98 (str "1" ;; auto increment99 "0" ;; not used100 (format101 "%03d"102 (Integer/parseInt103 (Integer/toBinaryString palette-num) 10))104 "00" ;; color num105 "0" ;; H/L106 ) 2)]107 (write-byte palette-select-address palette-write-data)))109 (defn set-palettes [palette-select palette-data palettes]110 (assert (<= (count palettes)) max-palettes)111 (flatten112 [(begin-sequential-palette-write 0 palette-select)114 0x21 ;; target address to HL115 (reverse (disect-bytes-2 palette-data))118 (for [palette palettes]119 (map (fn [byte]120 [0x3E ;; literal to A121 byte122 0x77]) ;; A -> (HL)124 (flatten125 (map #(gb-rgb->bits (get palette % [0 0 0]))126 (range 4)))))]))129 (defn display-one-color130 "Displayes a single color onto the gameboy screen. Input rgb in131 gameboy rgb."132 ([state [r g b]]133 ;; construct a kernel that displays a single color134 (let135 [palettes (repeat 8 [[r g b] [r g b] [r g b] [r g b]])136 kernel-address 0xC000137 kernel138 [0xF3 ;; disable interrupts139 (clear-music-registers)140 (frame-metronome)141 ;;(set-palettes142 ;; obj-palette-select obj-palette-data palettes)143 (set-palettes144 bg-palette-select bg-palette-data palettes)145 (infinite-loop)]]146 (-> (set-memory-range state147 kernel-address (flatten kernel))148 (PC! kernel-address))))149 ([[r g b]]150 (display-one-color @current-state [r g b])))152 ;;(require 'cortex.sense)155 ;; (defn show-screenshot []156 ;; (let [im (BufferedImage. 160 144 BufferedImage/TYPE_INT_RGB)157 ;; pix (vec (pixels))158 ;; view (cortex.sense/view-image)]159 ;; (dorun (for [x (range 160) y (range 144)]160 ;; (.setRGB im x y (pix (+ x (* 160 y))))))161 ;; (view im)))163 (defn gb-rgb->vga-rgb [[r g b]]164 (let [vga-rgb165 (first (pixels166 (run-moves167 (display-one-color168 (tick @current-state)169 [r g b])170 [[][]])))]171 [(bit-shift-right (bit-and vga-rgb 0xFF0000) 16)172 (bit-shift-right (bit-and vga-rgb 0xFF00) 8)173 (bit-and vga-rgb 0xFF)]))175 (defn generate-gb-color-map []176 (set-state! (mid-game))177 (let [gb-colors178 (for [r (range 32)179 g (range 32)180 b (range 32)]181 [r g b])]182 (zipmap gb-colors183 (map gb-rgb->vga-rgb184 gb-colors))))186 (import java.io.FileWriter)188 (def gb-color-map-file189 (File. user-home "proj/vba-clojure/gb-color-map"))191 (defn write-gb-color-map! []192 (binding [*out*(FileWriter. gb-color-map-file)]193 (let [out-str194 (.replace195 (str196 (into (sorted-map) (generate-gb-color-map)))197 "," ",\n")]198 (println out-str))))200 (def gb-color-map201 (read-string (slurp gb-color-map-file)))203 (import javax.imageio.stream.FileImageOutputStream)204 (import '(javax.imageio ImageWriteParam IIOImage ImageIO))207 (defn write-image! [^BufferedImage image ^File target]208 (doto209 (.next (ImageIO/getImageWritersByFormatName "png"))210 (.setOutput (FileImageOutputStream. target))211 (.write (IIOImage. image nil nil))212 (.dispose))213 image)216 (defn gen-gb-color-image! []217 (let [im (BufferedImage. 68 69 BufferedImage/TYPE_INT_RGB)218 pix (vec220 (reduce221 concat222 (map (partial223 sort-by224 (fn [[r g b]]225 (let [s (max r g b)226 det227 (cond228 (= s r)229 (+ -1000 (- g) b)230 (= s b)231 (+ (- r) g)232 (= s g)233 (+ 1000 (- b) r))]234 det)))235 (partition236 68 68 []237 (sort-by238 (fn euclidean-distance [[r g b]]239 (Math/sqrt (+ (* r r) (* g g) (* b b))))240 (filter241 (fn [[r g b]]242 (= (max r g b) b ))244 (seq (set (vals gb-color-map)))))))))245 ;;view (cortex.sense/view-image)246 target247 (File. user-home "proj/vba-clojure/gb-color-map-unique.png")]248 (dorun (for [x (range 68) y (range 69)]249 (let [[r g b] (get pix (+ x (* 68 y)) [0 0 0])250 rgb (+ (bit-shift-left r 16)251 (bit-shift-left g 8)252 b)]253 (.setRGB im x y rgb))))254 ;;(view im)255 (write-image! im target)))258 (defn gen-gb-color-image*! []259 (let [im (BufferedImage. 213 213 BufferedImage/TYPE_INT_RGB)260 squares261 (vec262 (for [r (range 32)]263 (vec264 (for [b (range 32) g (range 32)]265 (gb-color-map [r g b])))))266 ;;view (cortex.sense/view-image)267 target (File. user-home "proj/vba-clojure/gb-color-map.png")]269 (dorun270 (for [s-index (range 32)]271 (dorun272 (for [x (range 32) y (range 32)]274 (let [[r g b] ((squares s-index) (+ x (* 32 y)))275 rgb (+ (bit-shift-left r 16)276 (bit-shift-left g 8)277 b)]278 (.setRGB im279 (+ 3 (* 35 (rem s-index 6)) x)280 (+ 3 (* 35 (int (/ s-index 6))) y)281 rgb))))))282 ;;(view im)283 (write-image! im target)))285 (defn gen-gimp-palette! []286 (let [target287 (File. user-home "proj/vba-clojure/Gameboy-Color.gpl")]288 (spit289 target290 (apply291 str292 (concat293 ["GIMP Palette\n"294 "Name: GameBoy\n"295 "#\n"]296 (map (fn [[r g b]]297 (format "%3d %3d %3d\n" r g b))298 (sort (set (vals gb-color-map)))))))))300 (def test-image301 (ImageIO/read302 (File. user-home "/proj/vba-clojure/images/test-gb-image.png")))304 (def test-image-2305 (ImageIO/read306 (File. user-home "/proj/vba-clojure/images/test-gb-image-2.png")))308 (def test-image-color309 (ImageIO/read310 (File. user-home "/proj/vba-clojure/images/colors-test.png")))312 (def pinkie-pie-mark313 (ImageIO/read314 (File. user-home "/proj/vba-clojure/images/pinkie-pie-cutie-mark.png")))317 (defn rgb->triplet [rgb]318 (let [r (bit-shift-right (bit-and rgb 0xFF0000) 16)319 g (bit-shift-right (bit-and rgb 0xFF00) 8)320 b (bit-and rgb 0xFF)]321 [r g b]))323 (def reverse-gb-color-map324 (zipmap (vals gb-color-map)325 (keys gb-color-map)))327 (defn vga-rgb->gb-rgb [[r g b]]328 (reverse-gb-color-map [r g b]))330 (defn gb-tiles [^BufferedImage image]331 (for [tile (range 360)]332 (for [y (range 8) x (range 8)]333 (vga-rgb->gb-rgb334 (rgb->triplet335 (.getRGB image (+ x (* 8 (rem tile 20)))336 (+ y (* 8 (int (/ tile 20))))))))))338 (defn tile->palette [tile]339 (vec (sort (set tile))))341 (require 'clojure.set)343 (defn absorb-contract [objs]344 (reduce345 (fn [accepted new-element]346 (if (some347 (fn [obj]348 (clojure.set/subset? (set new-element) (set obj)))349 accepted)350 accepted351 (conj accepted new-element)))352 []353 (sort-by (comp - count) objs)))355 (defn palettes [^BufferedImage image]356 (let [palettes (map tile->palette (gb-tiles image))357 unique-palettes (absorb-contract (set palettes))]358 unique-palettes))360 (defn tile-pallete361 "find the first appropirate palette for the tile in the362 provided list of palettes."363 [tile palettes]364 (let [tile-colors (set tile)]365 (swank.util/find-first366 #(clojure.set/subset? tile-colors (set %))367 palettes)))370 (defn image->gb-image371 "Returns the image in a format amenable to the gameboy's372 internal representation. The format is:373 {:width -- width of the image374 :height -- height of the image375 :palettes -- vector of all the palettes the image376 needs, in proper order377 :tiles -- vector of all the tiles the image needs,378 in proper order. A tile is 64 palette379 indices.380 :data -- vector of pairs of the format:381 [tile-index, palette-index]382 in row-oriented order}"383 [^BufferedImage image]384 (let [image-palettes (palettes image)385 palette-index (zipmap386 image-palettes387 (range (count image-palettes)))388 tiles (gb-tiles image)389 unique-tiles (vec (distinct tiles))390 tile-index (zipmap unique-tiles391 (range (count unique-tiles)))]392 {:width (.getWidth image)393 :height (.getHeight image)394 :palettes image-palettes395 :tiles396 (vec397 (for [tile unique-tiles]398 (let [colors399 (vec (tile-pallete tile image-palettes))400 color-index401 (zipmap colors (range (count colors)))]402 (mapv color-index tile))))403 :data404 (vec405 (for [tile tiles]406 (let [tile-colors (set (tile->palette tile))]407 [(tile-index tile)408 (palette-index409 (tile-pallete tile image-palettes))])))}))411 (defn wait-until-v-blank412 "Modified version of frame-metronome. waits untill LY == 144,413 indicating start of v-blank period."414 []415 (let [timing-loop416 [0x01 ; \417 0x44 ; | load 0xFF44 into BC418 0xFF ; /419 0x0A] ;; (BC) -> A, now A = LY (vertical line coord)420 continue-if-144421 [0xFE422 144 ;; compare LY (in A) with 144423 0x20 ;; jump back to beginning if LY != 144 (not-v-blank)424 (->signed-8-bit425 (+ -4 (- (count timing-loop))))]]426 (concat timing-loop continue-if-144)))428 (def bg-character-data 0x9000)430 (defn gb-tile->bytes431 "Tile is a vector of 64 numbers between 0 and 3 that432 represent a single 8x8 color tile in the GB screen.433 It gets bit-packed into to 16 8-bit numbers in the following434 form:436 0-low 1-low ... 7-low437 0-high 1-high ... 7-high438 .439 .440 .441 55-low ........ 63-low442 55-high ........ 63-high"443 [tile]444 (let [row->bits445 (fn [row]446 (mapv447 (fn [row*]448 (Integer/parseInt (apply str row*) 2))449 [(map #(bit-and 0x01 %) row)450 (map #(bit-shift-right (bit-and 0x02 %) 1)451 row)]))]452 (vec453 (flatten454 (map row->bits455 (partition 8 tile))))))457 (defn write-data458 "Efficient assembly to write a sequence of values to459 memory, starting at a target address."460 [base-address target-address data]461 (let [len (count data)462 program-length 21] ;; change this if program length463 ;; below changes!464 (flatten465 [0x21 ;; load data address start into HL466 (reverse (disect-bytes-2 (+ base-address program-length)))468 0x01 ;; load target address into BC469 (reverse (disect-bytes-2 target-address))471 0x11 ;; load len into DE472 (reverse (disect-bytes-2 len))475 ;; data x-fer loop start476 0x2A ;; (HL) -> A; HL++;477 0x02 ;; A -> (BC);478 0x03 ;; INC BC;479 0x1B ;; DEC DE481 0xAF482 0xB2 ;; (OR D E) -> A483 0xB3486 0x20 ;; if DE is not now 0,487 (->signed-8-bit -9) ;; GOTO start489 0xC3490 (reverse491 (disect-bytes-2492 (+ len base-address program-length)))493 data])))495 (defn write-image496 "Assume the image data is specified as 360 blocks."497 [base-address target-address image-data]499 (let [len (count image-data)500 gen-program501 (fn [program-length]502 (flatten503 [0x01 ;; load data address start into BC504 (reverse505 (disect-bytes-2 (+ base-address program-length)))507 0x21 ;; load target address into HL508 (reverse (disect-bytes-2 target-address))510 0x1E ;; total-rows (18) -> E511 18513 0x16 ;; total columns (20) -> D514 20516 ;; data x-fer loop start517 0x0A ;; (BC) -> A;518 0x03 ;; INC BC;519 0x22 ;; A -> (HL); HL++;523 0x15 ;; dec D524 0x20525 (->signed-8-bit -6) ;; continue writing row527 ;; row is complete, advance to next row528 ;; HL += 12530 0xC5 ;; push BC532 0x06 ;; 0 -> B533 0535 0x0E536 12 ;; 12 -> C538 0x09 ;; HL + BC -> HL540 0xC1 ;; pop BC542 0x1D ;; dec E543 0x20544 (->signed-8-bit -18) ;; contunue writing image546 0xC3547 (reverse548 (disect-bytes-2549 (+ len base-address program-length)))]))]550 (flatten (concat551 (gen-program (count (gen-program 0)))552 image-data))))554 (defn test-write-data []555 (let [test-data (concat (range 256)556 (reverse (range 256)))557 base-address 0xC000558 target-address 0xD000560 test-kernel561 (flatten562 [0xF3 ;; disable interrupts563 (write-data (+ 1 base-address)564 target-address test-data)565 (infinite-loop)])]566 (assert567 (= test-data568 (-> (mid-game)569 tick tick tick570 (set-memory-range base-address test-kernel)571 (PC! base-address)572 (run-moves (repeat 100 []))573 (memory)574 vec575 (subvec target-address576 (+ target-address577 (count test-data))))))))579 (def LCD-bank-select-address 0xFF4F)581 (def BG-1-address 0x9800)582 (def BG-2-address 0x9C00)583 (def character-data-address 0x8000)585 (def LCD-control-register 0xFF40)586 (def STAT-register 0xFF41)588 (def SCX-register 0xFF42)589 (def SCY-register 0xFF43)591 (defn select-LCD-bank [n]592 (assert (or (= n 0) (= n 1)))593 (write-byte LCD-bank-select-address n))595 (defn write-image* [_ _ _] [])597 (defn display-image-kernel [base-address ^BufferedImage image]598 (let [gb-image (image->gb-image image)600 A [(clear-music-registers)602 ;; [X] disable LCD protection circuit.603 (write-byte LCD-control-register 0x00)604 ;; now we can write to all video RAM anytime with605 ;; impunity.607 ;; [ ] We're only using background palettes; just set the608 ;; minimum required bg palettes for this image, starting609 ;; with palette #0.611 (set-palettes bg-palette-select bg-palette-data612 (:palettes gb-image))614 ;; [X] switch to bank 0 to set BG character data.615 (select-LCD-bank 0)616 ;; [X] set SCX and SCY to 0617 (write-byte SCX-register 0)618 (write-byte SCY-register 0)619 ]620 A (flatten A)622 B [;; [X] write minimum amount of tiles to BG character623 ;; section624 (write-data625 (+ base-address (count A))626 character-data-address627 (flatten628 (map gb-tile->bytes (:tiles gb-image))))629 (select-LCD-bank 0)]630 B (flatten B)633 C [;; [X] write image to the screen in terms of tiles634 (write-image635 (+ base-address (+ (count A) (count B)))636 BG-1-address637 (map first (:data gb-image)))638 (select-LCD-bank 1)]640 C (flatten C)642 D [;; [X] specifiy pallets for each character643 (write-image644 (+ base-address (+ (count A) (count B) (count C)))645 BG-1-address646 (map second (:data gb-image)))649 ;; [X] reactivate the LCD display650 ;; we're using only BG images, located at651 ;; BG-1 (0x9800), with background character data652 ;; stored starting at 0x8000654 (write-byte655 LCD-control-register656 (Integer/parseInt657 (str658 "1" ;; LCDC on/off659 "0" ;; Window code area660 "0" ;; Windowing on?661 "1" ;; BG tile base (1 = 0x8000)662 "0" ;; BG-1 or BG-2 ?663 "0" ;; OBJ-block composition664 "0" ;; OBJ-on flag665 "1") ;; no-effect666 2))667 ]669 D (flatten D)]671 (concat A B C D)))673 (defn display-image [#^BufferedImage image]674 (let [kernel-address 0xB500]675 (-> (tick (tick (tick (mid-game))))676 (set-memory-range677 kernel-address678 (concat (display-image-kernel kernel-address image)679 (infinite-loop)))680 (PC! kernel-address))))