view clojure/com/aurellem/run/image.clj @ 509:d2c40a12de28

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