view clojure/com/aurellem/run/image.clj @ 518:bb4434c5a8f3

generated gameboy palette for gimp for Dylan.
author Robert McIntyre <rlm@mit.edu>
date Sat, 23 Jun 2012 14:27:01 -0500
parents bc24e4d605e9
children fd1ae0047a1a
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 (defn gen-gimp-palette! []
285 (let [target
286 (File. user-home "proj/vba-clojure/Gameboy-Color.gpl")]
287 (spit
288 target
289 (apply
290 str
291 (concat
292 ["GIMP Palette\n"
293 "Name: GameBoy\n"
294 "#\n"]
295 (map (fn [[r g b]]
296 (format "%3d %3d %3d\n" r g b))
297 (sort (set (vals gb-color-map)))))))))
299 (def test-image
300 (ImageIO/read
301 (File. user-home "/proj/vba-clojure/images/test-gb-image.png")))
303 (def test-image-2
304 (ImageIO/read
305 (File. user-home "/proj/vba-clojure/images/test-gb-image-2.png")))
307 (def test-image-color
308 (ImageIO/read
309 (File. user-home "/proj/vba-clojure/images/colors-test.png")))
311 (defn rgb->triplet [rgb]
312 (let [r (bit-shift-right (bit-and rgb 0xFF0000) 16)
313 g (bit-shift-right (bit-and rgb 0xFF00) 8)
314 b (bit-and rgb 0xFF)]
315 [r g b]))
317 (def reverse-gb-color-map
318 (zipmap (vals gb-color-map)
319 (keys gb-color-map)))
321 (defn vga-rgb->gb-rgb [[r g b]]
322 (reverse-gb-color-map [r g b]))
324 (defn gb-tiles [^BufferedImage image]
325 (for [tile (range 360)]
326 (for [y (range 8) x (range 8)]
327 (vga-rgb->gb-rgb
328 (rgb->triplet
329 (.getRGB image (+ x (* 8 (rem tile 20)))
330 (+ y (* 8 (int (/ tile 20))))))))))
332 (defn tile->palette [tile]
333 (vec (sort (set tile))))
335 (require 'clojure.set)
337 (defn absorb-contract [objs]
338 (reduce
339 (fn [accepted new-element]
340 (if (some
341 (fn [obj]
342 (clojure.set/subset? (set new-element) (set obj)))
343 accepted)
344 accepted
345 (conj accepted new-element)))
346 []
347 (sort-by (comp - count) objs)))
349 (defn palettes [^BufferedImage image]
350 (let [palettes (map tile->palette (gb-tiles image))
351 unique-palettes (absorb-contract (set palettes))]
352 unique-palettes))
354 (defn tile-pallete
355 "find the first appropirate palette for the tile in the
356 provided list of palettes."
357 [tile palettes]
358 (let [tile-colors (set tile)]
359 (swank.util/find-first
360 #(clojure.set/subset? tile-colors (set %))
361 palettes)))
364 (defn image->gb-image
365 "Returns the image in a format amenable to the gameboy's
366 internal representation. The format is:
367 {:width -- width of the image
368 :height -- height of the image
369 :palettes -- vector of all the palettes the image
370 needs, in proper order
371 :tiles -- vector of all the tiles the image needs,
372 in proper order. A tile is 64 palette
373 indices.
374 :data -- vector of pairs of the format:
375 [tile-index, palette-index]
376 in row-oriented order}"
377 [^BufferedImage image]
378 (let [image-palettes (palettes image)
379 palette-index (zipmap
380 image-palettes
381 (range (count image-palettes)))
382 tiles (gb-tiles image)
383 unique-tiles (vec (distinct tiles))
384 tile-index (zipmap unique-tiles
385 (range (count unique-tiles)))]
386 {:width (.getWidth image)
387 :height (.getHeight image)
388 :palettes image-palettes
389 :tiles
390 (vec
391 (for [tile unique-tiles]
392 (let [colors
393 (vec (tile-pallete tile image-palettes))
394 color-index
395 (zipmap colors (range (count colors)))]
396 (mapv color-index tile))))
397 :data
398 (vec
399 (for [tile tiles]
400 (let [tile-colors (set (tile->palette tile))]
401 [(tile-index tile)
402 (palette-index
403 (tile-pallete tile image-palettes))])))}))
405 (defn wait-until-v-blank
406 "Modified version of frame-metronome. waits untill LY == 144,
407 indicating start of v-blank period."
408 []
409 (let [timing-loop
410 [0x01 ; \
411 0x44 ; | load 0xFF44 into BC
412 0xFF ; /
413 0x0A] ;; (BC) -> A, now A = LY (vertical line coord)
414 continue-if-144
415 [0xFE
416 144 ;; compare LY (in A) with 144
417 0x20 ;; jump back to beginning if LY != 144 (not-v-blank)
418 (->signed-8-bit
419 (+ -4 (- (count timing-loop))))]]
420 (concat timing-loop continue-if-144)))
422 (def bg-character-data 0x9000)
424 (defn gb-tile->bytes
425 "Tile is a vector of 64 numbers between 0 and 3 that
426 represent a single 8x8 color tile in the GB screen.
427 It gets bit-packed into to 16 8-bit numbers in the following
428 form:
430 0-low 1-low ... 7-low
431 0-high 1-high ... 7-high
432 .
433 .
434 .
435 55-low ........ 63-low
436 55-high ........ 63-high"
437 [tile]
438 (let [row->bits
439 (fn [row]
440 (mapv
441 (fn [row*]
442 (Integer/parseInt (apply str row*) 2))
443 [(map #(bit-and 0x01 %) row)
444 (map #(bit-shift-right (bit-and 0x02 %) 1)
445 row)]))]
446 (vec
447 (flatten
448 (map row->bits
449 (partition 8 tile))))))
451 (defn write-data
452 "Efficient assembly to write a sequence of values to
453 memory, starting at a target address."
454 [base-address target-address data]
455 (let [len (count data)
456 program-length 21] ;; change this if program length
457 ;; below changes!
458 (flatten
459 [0x21 ;; load data address start into HL
460 (reverse (disect-bytes-2 (+ base-address program-length)))
462 0x01 ;; load target address into BC
463 (reverse (disect-bytes-2 target-address))
465 0x11 ;; load len into DE
466 (reverse (disect-bytes-2 len))
469 ;; data x-fer loop start
470 0x2A ;; (HL) -> A; HL++;
471 0x02 ;; A -> (BC);
472 0x03 ;; INC BC;
473 0x1B ;; DEC DE
475 0xAF
476 0xB2 ;; (OR D E) -> A
477 0xB3
480 0x20 ;; if DE is not now 0,
481 (->signed-8-bit -9) ;; GOTO start
483 0xC3
484 (reverse
485 (disect-bytes-2
486 (+ len base-address program-length)))
487 data])))
489 (defn write-image
490 "Assume the image data is specified as 360 blocks."
491 [base-address target-address image-data]
493 (let [len (count image-data)
494 gen-program
495 (fn [program-length]
496 (flatten
497 [0x01 ;; load data address start into BC
498 (reverse
499 (disect-bytes-2 (+ base-address program-length)))
501 0x21 ;; load target address into HL
502 (reverse (disect-bytes-2 target-address))
504 0x1E ;; total-rows (18) -> E
505 18
507 0x16 ;; total columns (20) -> D
508 20
510 ;; data x-fer loop start
511 0x0A ;; (BC) -> A;
512 0x03 ;; INC BC;
513 0x22 ;; A -> (HL); HL++;
517 0x15 ;; dec D
518 0x20
519 (->signed-8-bit -6) ;; continue writing row
521 ;; row is complete, advance to next row
522 ;; HL += 12
524 0xC5 ;; push BC
526 0x06 ;; 0 -> B
527 0
529 0x0E
530 12 ;; 12 -> C
532 0x09 ;; HL + BC -> HL
534 0xC1 ;; pop BC
536 0x1D ;; dec E
537 0x20
538 (->signed-8-bit -18) ;; contunue writing image
540 0xC3
541 (reverse
542 (disect-bytes-2
543 (+ len base-address program-length)))]))]
544 (flatten (concat
545 (gen-program (count (gen-program 0)))
546 image-data))))
548 (defn test-write-data []
549 (let [test-data (concat (range 256)
550 (reverse (range 256)))
551 base-address 0xC000
552 target-address 0xD000
554 test-kernel
555 (flatten
556 [0xF3 ;; disable interrupts
557 (write-data (+ 1 base-address)
558 target-address test-data)
559 (infinite-loop)])]
560 (assert
561 (= test-data
562 (-> (mid-game)
563 tick tick tick
564 (set-memory-range base-address test-kernel)
565 (PC! base-address)
566 (run-moves (repeat 100 []))
567 (memory)
568 vec
569 (subvec target-address
570 (+ target-address
571 (count test-data))))))))
573 (def LCD-bank-select-address 0xFF4F)
575 (def BG-1-address 0x9800)
576 (def BG-2-address 0x9C00)
577 (def character-data-address 0x8000)
579 (def LCD-control-register 0xFF40)
580 (def STAT-register 0xFF41)
582 (def SCX-register 0xFF42)
583 (def SCY-register 0xFF43)
585 (defn select-LCD-bank [n]
586 (assert (or (= n 0) (= n 1)))
587 (write-byte LCD-bank-select-address n))
589 (defn write-image* [_ _ _] [])
591 (defn display-image-kernel [base-address ^BufferedImage image]
592 (let [gb-image (image->gb-image image)
594 A [(clear-music-registers)
596 ;; [X] disable LCD protection circuit.
597 (write-byte LCD-control-register 0x00)
598 ;; now we can write to all video RAM anytime with
599 ;; impunity.
601 ;; [ ] We're only using background palettes; just set the
602 ;; minimum required bg palettes for this image, starting
603 ;; with palette #0.
605 (set-palettes bg-palette-select bg-palette-data
606 (:palettes gb-image))
608 ;; [X] switch to bank 0 to set BG character data.
609 (select-LCD-bank 0)
610 ;; [X] set SCX and SCY to 0
611 (write-byte SCX-register 0)
612 (write-byte SCY-register 0)
613 ]
614 A (flatten A)
616 B [;; [X] write minimum amount of tiles to BG character
617 ;; section
618 (write-data
619 (+ base-address (count A))
620 character-data-address
621 (flatten
622 (map gb-tile->bytes (:tiles gb-image))))
623 (select-LCD-bank 0)]
624 B (flatten B)
627 C [;; [X] write image to the screen in terms of tiles
628 (write-image
629 (+ base-address (+ (count A) (count B)))
630 BG-1-address
631 (map first (:data gb-image)))
632 (select-LCD-bank 1)]
634 C (flatten C)
636 D [;; [X] specifiy pallets for each character
637 (write-image
638 (+ base-address (+ (count A) (count B) (count C)))
639 BG-1-address
640 (map second (:data gb-image)))
643 ;; [X] reactivate the LCD display
644 ;; we're using only BG images, located at
645 ;; BG-1 (0x9800), with background character data
646 ;; stored starting at 0x8000
648 (write-byte
649 LCD-control-register
650 (Integer/parseInt
651 (str
652 "1" ;; LCDC on/off
653 "0" ;; Window code area
654 "0" ;; Windowing on?
655 "1" ;; BG tile base (1 = 0x8000)
656 "0" ;; BG-1 or BG-2 ?
657 "0" ;; OBJ-block composition
658 "0" ;; OBJ-on flag
659 "1") ;; no-effect
660 2))
662 (infinite-loop)]
663 D (flatten D)]
665 (concat A B C D)))
667 (defn display-image [#^BufferedImage image]
668 (let [kernel-address 0xB000]
669 (-> (tick (tick (tick (mid-game))))
670 (set-memory-range
671 kernel-address
672 (display-image-kernel kernel-address image))
673 (PC! kernel-address))))