view clojure/com/aurellem/run/image.clj @ 526:2620d6318e8d

sound recording complete.
author Robert McIntyre <rlm@mit.edu>
date Sun, 24 Jun 2012 13:34:15 -0500
parents 5596cd4a3fc6
children 7f8030812ac2
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.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 be
16 ;; simple.
18 ;; use background tiles? they provide greater color depth than
19 ;; sprites, and can still be scrolled, so why not?
21 ;; could also use sprites to get 3 more colors per tile for a total of
22 ;; 7 colors per tile, although not for all tiles...
26 ;; want a function to
28 ;; 1. read an image
29 ;; 2. split into a grid of 8x8 pixels
30 ;; 3. convert all RGB colors to gb-RGB colors
31 ;; 4. determine efficient color palletes for the image
32 ;; 5. output efficient assembly code to draw the image to the gb
33 ;; 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-and
66 0xFF
67 (+
68 r
69 (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 (flatten
85 [0x3E ;; load literal to A
86 data
87 0xEA ;; load A into target
88 (reverse (disect-bytes-2 target))]))
90 (defn begin-sequential-palette-write
91 [palette-num palette-select-address]
92 (assert (<= 0 palette-num max-palettes))
93 (assert
94 (or (= palette-select-address bg-palette-select)
95 (= palette-select-address obj-palette-select)))
96 (let [palette-write-data
97 (Integer/parseInt
98 (str "1" ;; auto increment
99 "0" ;; not used
100 (format
101 "%03d"
102 (Integer/parseInt
103 (Integer/toBinaryString palette-num) 10))
104 "00" ;; color num
105 "0" ;; H/L
106 ) 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 (flatten
112 [(begin-sequential-palette-write 0 palette-select)
114 0x21 ;; target address to HL
115 (reverse (disect-bytes-2 palette-data))
118 (for [palette palettes]
119 (map (fn [byte]
120 [0x3E ;; literal to A
121 byte
122 0x77]) ;; A -> (HL)
124 (flatten
125 (map #(gb-rgb->bits (get palette % [0 0 0]))
126 (range 4)))))]))
129 (defn display-one-color
130 "Displayes a single color onto the gameboy screen. Input rgb in
131 gameboy rgb."
132 ([state [r g b]]
133 ;; construct a kernel that displays a single color
134 (let
135 [palettes (repeat 8 [[r g b] [r g b] [r g b] [r g b]])
136 kernel-address 0xC000
137 kernel
138 [0xF3 ;; disable interrupts
139 (clear-music-registers)
140 (frame-metronome)
141 ;;(set-palettes
142 ;; obj-palette-select obj-palette-data palettes)
143 (set-palettes
144 bg-palette-select bg-palette-data palettes)
145 (infinite-loop)]]
146 (-> (set-memory-range state
147 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-rgb
165 (first (pixels
166 (run-moves
167 (display-one-color
168 (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-colors
178 (for [r (range 32)
179 g (range 32)
180 b (range 32)]
181 [r g b])]
182 (zipmap gb-colors
183 (map gb-rgb->vga-rgb
184 gb-colors))))
186 (import java.io.FileWriter)
188 (def gb-color-map-file
189 (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-str
194 (.replace
195 (str
196 (into (sorted-map) (generate-gb-color-map)))
197 "," ",\n")]
198 (println out-str))))
200 (def gb-color-map
201 (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 (doto
209 (.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 (vec
220 (reduce
221 concat
222 (map (partial
223 sort-by
224 (fn [[r g b]]
225 (let [s (max r g b)
226 det
227 (cond
228 (= s r)
229 (+ -1000 (- g) b)
230 (= s b)
231 (+ (- r) g)
232 (= s g)
233 (+ 1000 (- b) r))]
234 det)))
235 (partition
236 68 68 []
237 (sort-by
238 (fn euclidean-distance [[r g b]]
239 (Math/sqrt (+ (* r r) (* g g) (* b b))))
240 (filter
241 (fn [[r g b]]
242 (= (max r g b) b ))
244 (seq (set (vals gb-color-map)))))))))
245 ;;view (cortex.sense/view-image)
246 target
247 (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 squares
261 (vec
262 (for [r (range 32)]
263 (vec
264 (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 (dorun
270 (for [s-index (range 32)]
271 (dorun
272 (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 im
279 (+ 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 [target
287 (File. user-home "proj/vba-clojure/Gameboy-Color.gpl")]
288 (spit
289 target
290 (apply
291 str
292 (concat
293 ["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-image
301 (ImageIO/read
302 (File. user-home "/proj/vba-clojure/images/test-gb-image.png")))
304 (def test-image-2
305 (ImageIO/read
306 (File. user-home "/proj/vba-clojure/images/test-gb-image-2.png")))
308 (def test-image-color
309 (ImageIO/read
310 (File. user-home "/proj/vba-clojure/images/colors-test.png")))
312 (def pinkie-pie-mark
313 (ImageIO/read
314 (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-map
324 (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-rgb
334 (rgb->triplet
335 (.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 (reduce
345 (fn [accepted new-element]
346 (if (some
347 (fn [obj]
348 (clojure.set/subset? (set new-element) (set obj)))
349 accepted)
350 accepted
351 (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-pallete
361 "find the first appropirate palette for the tile in the
362 provided list of palettes."
363 [tile palettes]
364 (let [tile-colors (set tile)]
365 (swank.util/find-first
366 #(clojure.set/subset? tile-colors (set %))
367 palettes)))
370 (defn image->gb-image
371 "Returns the image in a format amenable to the gameboy's
372 internal representation. The format is:
373 {:width -- width of the image
374 :height -- height of the image
375 :palettes -- vector of all the palettes the image
376 needs, in proper order
377 :tiles -- vector of all the tiles the image needs,
378 in proper order. A tile is 64 palette
379 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 (zipmap
386 image-palettes
387 (range (count image-palettes)))
388 tiles (gb-tiles image)
389 unique-tiles (vec (distinct tiles))
390 tile-index (zipmap unique-tiles
391 (range (count unique-tiles)))]
392 {:width (.getWidth image)
393 :height (.getHeight image)
394 :palettes image-palettes
395 :tiles
396 (vec
397 (for [tile unique-tiles]
398 (let [colors
399 (vec (tile-pallete tile image-palettes))
400 color-index
401 (zipmap colors (range (count colors)))]
402 (mapv color-index tile))))
403 :data
404 (vec
405 (for [tile tiles]
406 (let [tile-colors (set (tile->palette tile))]
407 [(tile-index tile)
408 (palette-index
409 (tile-pallete tile image-palettes))])))}))
411 (defn wait-until-v-blank
412 "Modified version of frame-metronome. waits untill LY == 144,
413 indicating start of v-blank period."
414 []
415 (let [timing-loop
416 [0x01 ; \
417 0x44 ; | load 0xFF44 into BC
418 0xFF ; /
419 0x0A] ;; (BC) -> A, now A = LY (vertical line coord)
420 continue-if-144
421 [0xFE
422 144 ;; compare LY (in A) with 144
423 0x20 ;; jump back to beginning if LY != 144 (not-v-blank)
424 (->signed-8-bit
425 (+ -4 (- (count timing-loop))))]]
426 (concat timing-loop continue-if-144)))
428 (def bg-character-data 0x9000)
430 (defn gb-tile->bytes
431 "Tile is a vector of 64 numbers between 0 and 3 that
432 represent a single 8x8 color tile in the GB screen.
433 It gets bit-packed into to 16 8-bit numbers in the following
434 form:
436 0-low 1-low ... 7-low
437 0-high 1-high ... 7-high
438 .
439 .
440 .
441 55-low ........ 63-low
442 55-high ........ 63-high"
443 [tile]
444 (let [row->bits
445 (fn [row]
446 (mapv
447 (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 (vec
453 (flatten
454 (map row->bits
455 (partition 8 tile))))))
457 (defn write-data
458 "Efficient assembly to write a sequence of values to
459 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 length
463 ;; below changes!
464 (flatten
465 [0x21 ;; load data address start into HL
466 (reverse (disect-bytes-2 (+ base-address program-length)))
468 0x01 ;; load target address into BC
469 (reverse (disect-bytes-2 target-address))
471 0x11 ;; load len into DE
472 (reverse (disect-bytes-2 len))
475 ;; data x-fer loop start
476 0x2A ;; (HL) -> A; HL++;
477 0x02 ;; A -> (BC);
478 0x03 ;; INC BC;
479 0x1B ;; DEC DE
481 0xAF
482 0xB2 ;; (OR D E) -> A
483 0xB3
486 0x20 ;; if DE is not now 0,
487 (->signed-8-bit -9) ;; GOTO start
489 0xC3
490 (reverse
491 (disect-bytes-2
492 (+ len base-address program-length)))
493 data])))
495 (defn write-image
496 "Assume the image data is specified as 360 blocks."
497 [base-address target-address image-data]
499 (let [len (count image-data)
500 gen-program
501 (fn [program-length]
502 (flatten
503 [0x01 ;; load data address start into BC
504 (reverse
505 (disect-bytes-2 (+ base-address program-length)))
507 0x21 ;; load target address into HL
508 (reverse (disect-bytes-2 target-address))
510 0x1E ;; total-rows (18) -> E
511 18
513 0x16 ;; total columns (20) -> D
514 20
516 ;; data x-fer loop start
517 0x0A ;; (BC) -> A;
518 0x03 ;; INC BC;
519 0x22 ;; A -> (HL); HL++;
523 0x15 ;; dec D
524 0x20
525 (->signed-8-bit -6) ;; continue writing row
527 ;; row is complete, advance to next row
528 ;; HL += 12
530 0xC5 ;; push BC
532 0x06 ;; 0 -> B
533 0
535 0x0E
536 12 ;; 12 -> C
538 0x09 ;; HL + BC -> HL
540 0xC1 ;; pop BC
542 0x1D ;; dec E
543 0x20
544 (->signed-8-bit -18) ;; contunue writing image
546 0xC3
547 (reverse
548 (disect-bytes-2
549 (+ len base-address program-length)))]))]
550 (flatten (concat
551 (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 0xC000
558 target-address 0xD000
560 test-kernel
561 (flatten
562 [0xF3 ;; disable interrupts
563 (write-data (+ 1 base-address)
564 target-address test-data)
565 (infinite-loop)])]
566 (assert
567 (= test-data
568 (-> (mid-game)
569 tick tick tick
570 (set-memory-range base-address test-kernel)
571 (PC! base-address)
572 (run-moves (repeat 100 []))
573 (memory)
574 vec
575 (subvec target-address
576 (+ target-address
577 (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 with
605 ;; impunity.
607 ;; [ ] We're only using background palettes; just set the
608 ;; minimum required bg palettes for this image, starting
609 ;; with palette #0.
611 (set-palettes bg-palette-select bg-palette-data
612 (: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 0
617 (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 character
623 ;; section
624 (write-data
625 (+ base-address (count A))
626 character-data-address
627 (flatten
628 (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 tiles
634 (write-image
635 (+ base-address (+ (count A) (count B)))
636 BG-1-address
637 (map first (:data gb-image)))
638 (select-LCD-bank 1)]
640 C (flatten C)
642 D [;; [X] specifiy pallets for each character
643 (write-image
644 (+ base-address (+ (count A) (count B) (count C)))
645 BG-1-address
646 (map second (:data gb-image)))
649 ;; [X] reactivate the LCD display
650 ;; we're using only BG images, located at
651 ;; BG-1 (0x9800), with background character data
652 ;; stored starting at 0x8000
654 (write-byte
655 LCD-control-register
656 (Integer/parseInt
657 (str
658 "1" ;; LCDC on/off
659 "0" ;; Window code area
660 "0" ;; Windowing on?
661 "1" ;; BG tile base (1 = 0x8000)
662 "0" ;; BG-1 or BG-2 ?
663 "0" ;; OBJ-block composition
664 "0" ;; OBJ-on flag
665 "1") ;; no-effect
666 2))
668 (infinite-loop)]
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-range
677 kernel-address
678 (display-image-kernel kernel-address image))
679 (PC! kernel-address))))