view clojure/com/aurellem/run/image.clj @ 515:f68d600b089c

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