Mercurial > vba-clojure

annotate clojure/com/aurellem/run/image.clj @ 506:130ba9f49db5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
added function to slice up an image into an appropriate representation for the GB.
author Robert McIntyre <rlm@mit.edu>
date Wed, 20 Jun 2012 16:50:36 -0500
parents f992a0a0480d
children 24b459a95b46
rev   line source
rlm@488 1 (ns com.aurellem.run.image
rlm@486 2 (:use (com.aurellem.gb saves gb-driver util constants
rlm@486 3 items vbm characters money
rlm@486 4 rlm-assembly))
rlm@492 5 (:use (com.aurellem.run util music title save-corruption
rlm@486 6 bootstrap-0 bootstrap-1))
rlm@486 7 (:require clojure.string)
rlm@486 8 (:import [com.aurellem.gb.gb_driver SaveState])
rlm@486 9 (:import java.io.File))
rlm@486 10
rlm@486 11 ;; want to display an image onto the screen.
rlm@486 12 ;; probably will be the six ponies, possibly with scrolling.
rlm@486 13
rlm@486 14 ;; probably don't need hi-color mode since the images shuld be
rlm@486 15 ;; simple.
rlm@486 16
rlm@486 17 ;; use background tiles? they provide greater color depth than
rlm@486 18 ;; sprites, and can still be scrolled, so why not?
rlm@486 19
rlm@490 20 ;; could also use sprites to get 3 more colors per tile for a total of
rlm@490 21 ;; 7 colors per tile, although not for all tiles...
rlm@486 22
rlm@486 23
rlm@486 24
rlm@490 25 ;; want a function to
rlm@486 26
rlm@490 27 ;; 1. read an image
rlm@490 28 ;; 2. split into a grid of 8x8 pixels
rlm@490 29 ;; 3. convert all RGB colors to gb-RGB colors
rlm@490 30 ;; 4. determine efficient color palletes for the image
rlm@490 31 ;; 5. output efficient assembly code to draw the image to the gb
rlm@490 32 ;; screen.
rlm@486 33
rlm@488 34
rlm@488 35
rlm@488 36
rlm@488 37
rlm@488 38
rlm@488 39
rlm@488 40
rlm@488 41
rlm@488 42
rlm@488 43
rlm@488 44
rlm@488 45
rlm@491 46 (def image-program-target 0xB000)
rlm@486 47
rlm@491 48 (def display-width 160)
rlm@491 49 (def display-height 144)
rlm@491 50
rlm@491 51
rlm@491 52
rlm@491 53 ;{:r :g :b }
rlm@491 54
rlm@491 55 (def character-data 0x8000)
rlm@491 56 (def character-data-end 0x97FF)
rlm@491 57
rlm@491 58
rlm@491 59
rlm@491 60
rlm@491 61 (def BG-data-1 0x9800)
rlm@491 62
rlm@491 63 (def BG-data-2 0x9C00)
rlm@491 64
rlm@491 65 (def OAM 0xFE00)
rlm@491 66
rlm@491 67
rlm@491 68
rlm@491 69 (def video-bank-select-register 0xFF4F)
rlm@491 70
rlm@492 71 (defn gb-rgb->bits [[r g b]]
rlm@492 72 (assert (<= 0 r 31))
rlm@492 73 (assert (<= 0 g 31))
rlm@492 74 (assert (<= 0 b 31))
rlm@491 75 [(bit-and
rlm@491 76 0xFF
rlm@491 77 (+
rlm@491 78 r
rlm@491 79 (bit-shift-left g 5)))
rlm@491 80 (+
rlm@491 81 (bit-shift-right g 3)
rlm@491 82 (bit-shift-left b 2))])
rlm@491 83
rlm@492 84
rlm@492 85 (def bg-palette-select 0xFF68)
rlm@492 86 (def bg-palette-data 0xFF69)
rlm@492 87
rlm@492 88 (def obj-palette-select 0xFF6A)
rlm@492 89 (def obj-palette-data 0xFF6B)
rlm@492 90
rlm@492 91 (def max-palettes 8)
rlm@492 92
rlm@492 93 (defn write-data [target data]
rlm@492 94 (flatten
rlm@492 95 [0x3E ;; load literal to A
rlm@492 96 data
rlm@492 97 0xEA ;; load A into target
rlm@493 98 (reverse (disect-bytes-2 target))]))
rlm@492 99
rlm@492 100 (defn begin-sequential-palette-write
rlm@492 101 [palette-num palette-select-address]
rlm@492 102 (assert (<= 0 palette-num max-palettes))
rlm@492 103 (assert
rlm@492 104 (or (= palette-select-address bg-palette-select)
rlm@492 105 (= palette-select-address obj-palette-select)))
rlm@492 106 (let [palette-write-data
rlm@492 107 (Integer/parseInt
rlm@492 108 (str "1" ;; auto increment
rlm@492 109 "0" ;; not used
rlm@492 110 (format
rlm@492 111 "%03d"
rlm@492 112 (Integer/parseInt
rlm@492 113 (Integer/toBinaryString palette-num) 10))
rlm@492 114 "00" ;; color num
rlm@492 115 "0" ;; H/L
rlm@492 116 ) 2)]
rlm@492 117 (write-data palette-select-address palette-write-data)))
rlm@492 118
rlm@492 119 (defn set-palettes [palette-select palette-data palettes]
rlm@492 120 (assert (<= (count palettes)) max-palettes)
rlm@492 121 (flatten
rlm@492 122 [(begin-sequential-palette-write 0 palette-select)
rlm@492 123 (map (partial write-data palette-data)
rlm@492 124 (flatten (map gb-rgb->bits palettes)))]))
rlm@492 125
rlm@491 126 (defn display-one-color
rlm@491 127 "Displayes a single color onto the gameboy screen. input rgb in
rlm@491 128 gameboy rgb."
rlm@498 129 ([state [r g b]]
rlm@498 130 ;; construct a kernel that displays a single color
rlm@498 131 (let
rlm@498 132 [palettes (repeat 8 [r g b])
rlm@498 133 kernel-address 0xC000
rlm@498 134 kernel
rlm@498 135 [0xF3 ;; disable interrupts
rlm@498 136 (clear-music-registers)
rlm@498 137 (frame-metronome)
rlm@498 138 (set-palettes obj-palette-select obj-palette-data palettes)
rlm@498 139 (set-palettes bg-palette-select bg-palette-data palettes)
rlm@498 140 (infinite-loop)]]
rlm@498 141 (-> (set-memory-range state
rlm@498 142 kernel-address (flatten kernel))
rlm@498 143 (PC! kernel-address))))
rlm@498 144 ([[r g b]]
rlm@498 145 (display-one-color @current-state [r g b])))
rlm@492 146
rlm@505 147 ;;(require 'cortex.sense)
rlm@496 148 (import java.awt.image.BufferedImage)
rlm@492 149
rlm@505 150 ;; (defn show-screenshot []
rlm@505 151 ;; (let [im (BufferedImage. 160 144 BufferedImage/TYPE_INT_RGB)
rlm@505 152 ;; pix (vec (pixels))
rlm@505 153 ;; view (cortex.sense/view-image)]
rlm@505 154 ;; (dorun (for [x (range 160) y (range 144)]
rlm@505 155 ;; (.setRGB im x y (pix (+ x (* 160 y))))))
rlm@505 156 ;; (view im)))
rlm@496 157
rlm@500 158 (defn gb-rgb->vga-rgb [[r g b]]
rlm@498 159 (let [vga-rgb
rlm@498 160 (first (pixels
rlm@498 161 (run-moves
rlm@498 162 (display-one-color
rlm@498 163 (tick @current-state)
rlm@498 164 [r g b])
rlm@498 165 [[][]])))]
rlm@498 166 [(bit-shift-right (bit-and vga-rgb 0xFF0000) 16)
rlm@498 167 (bit-shift-right (bit-and vga-rgb 0xFF00) 8)
rlm@498 168 (bit-and vga-rgb 0xFF)]))
rlm@491 169
rlm@498 170 (defn generate-gb-color-map []
rlm@498 171 (set-state! (mid-game))
rlm@498 172 (let [gb-colors
rlm@498 173 (for [r (range 32)
rlm@498 174 g (range 32)
rlm@498 175 b (range 32)]
rlm@498 176 [r g b])]
rlm@498 177 (zipmap gb-colors
rlm@498 178 (map gb-rgb->vga-rgb
rlm@498 179 gb-colors))))
rlm@491 180
rlm@498 181 (import java.io.FileWriter)
rlm@491 182
rlm@498 183 (def gb-color-map-file
rlm@498 184 (File. user-home "proj/vba-clojure/gb-color-map"))
rlm@495 185
rlm@498 186 (defn write-gb-color-map! []
rlm@498 187 (binding [*out*(FileWriter. gb-color-map-file)]
rlm@498 188 (let [out-str
rlm@498 189 (.replace
rlm@498 190 (str
rlm@498 191 (into (sorted-map) (generate-gb-color-map)))
rlm@498 192 "," ",\n")]
rlm@498 193 (println out-str))))
rlm@498 194
rlm@499 195 (def gb-color-map
rlm@499 196 (read-string (slurp gb-color-map-file)))
rlm@499 197
rlm@499 198 (import javax.imageio.stream.FileImageOutputStream)
rlm@499 199 (import '(javax.imageio ImageWriteParam IIOImage ImageIO))
rlm@499 200
rlm@499 201
rlm@499 202 (defn gen-gb-color-image! []
rlm@500 203 (let [im (BufferedImage. 68 69 BufferedImage/TYPE_INT_RGB)
rlm@499 204 pix (vec
rlm@499 205
rlm@499 206 (reduce
rlm@499 207 concat
rlm@499 208 (map (partial
rlm@499 209 sort-by
rlm@499 210 (fn [[r g b]]
rlm@499 211 (let [s (max r g b)
rlm@499 212 det
rlm@499 213 (cond
rlm@499 214 (= s r)
rlm@499 215 (+ -1000 (- g) b)
rlm@499 216 (= s b)
rlm@499 217 (+ (- r) g)
rlm@499 218 (= s g)
rlm@499 219 (+ 1000 (- b) r))]
rlm@499 220 det)))
rlm@499 221 (partition
rlm@500 222 68 68 []
rlm@499 223 (sort-by
rlm@499 224 (fn euclidean-distance [[r g b]]
rlm@499 225 (Math/sqrt (+ (* r r) (* g g) (* b b))))
rlm@501 226 (filter
rlm@501 227 (fn [[r g b]]
rlm@501 228 (= (max r g b) b ))
rlm@501 229
rlm@501 230 (seq (set (vals gb-color-map)))))))))
rlm@505 231 ;;view (cortex.sense/view-image)
rlm@500 232 target (File. user-home "proj/vba-clojure/gb-color-map-unique.png")]
rlm@500 233 (dorun (for [x (range 68) y (range 69)]
rlm@500 234 (let [[r g b] (get pix (+ x (* 68 y)) [0 0 0])
rlm@499 235 rgb (+ (bit-shift-left r 16)
rlm@499 236 (bit-shift-left g 8)
rlm@499 237 b)]
rlm@505 238 (.setRGB im x y rgb))))
rlm@505 239 ;;(view im)
rlm@499 240 (doto
rlm@499 241 (.next (ImageIO/getImageWritersByFormatName "png"))
rlm@499 242 (.setOutput (FileImageOutputStream. target))
rlm@499 243 (.write (IIOImage. im nil nil))
rlm@499 244 (.dispose))
rlm@499 245 im))
rlm@499 246
rlm@499 247 (defn gen-gb-color-image*! []
rlm@499 248 (let [im (BufferedImage. 213 213 BufferedImage/TYPE_INT_RGB)
rlm@499 249 squares
rlm@499 250 (vec
rlm@499 251 (for [r (range 32)]
rlm@499 252 (vec
rlm@499 253 (for [b (range 32) g (range 32)]
rlm@499 254 (gb-color-map [r g b])))))
rlm@505 255 ;;view (cortex.sense/view-image)
rlm@499 256 target (File. user-home "proj/vba-clojure/gb-color-map.png")]
rlm@499 257
rlm@499 258 (dorun
rlm@499 259 (for [s-index (range 32)]
rlm@499 260 (dorun
rlm@499 261 (for [x (range 32) y (range 32)]
rlm@499 262
rlm@499 263 (let [[r g b] ((squares s-index) (+ x (* 32 y)))
rlm@499 264 rgb (+ (bit-shift-left r 16)
rlm@499 265 (bit-shift-left g 8)
rlm@499 266 b)]
rlm@499 267 (.setRGB im
rlm@499 268 (+ 3 (* 35 (rem s-index 6)) x)
rlm@499 269 (+ 3 (* 35 (int (/ s-index 6))) y)
rlm@499 270 rgb))))))
rlm@505 271 ;;(view im)
rlm@499 272 (doto
rlm@499 273 (.next (ImageIO/getImageWritersByFormatName "png"))
rlm@499 274 (.setOutput (FileImageOutputStream. target))
rlm@499 275 (.write (IIOImage. im nil nil))
rlm@499 276 (.dispose))
rlm@499 277 im))
rlm@501 278
rlm@501 279
rlm@501 280 (count
rlm@501 281 (filter
rlm@501 282 (fn [[r g b]]
rlm@501 283 (= (max r g b) r ))(set (vals gb-color-map))))
rlm@502 284
rlm@502 285 (def test-image
rlm@502 286 (ImageIO/read
rlm@502 287 (File. user-home "/proj/vba-clojure/images/test-gb-image.png")))
rlm@502 288
rlm@502 289 (defn rgb->triplet [rgb]
rlm@502 290 (let [r (bit-shift-right (bit-and rgb 0xFF0000) 16)
rlm@502 291 g (bit-shift-right (bit-and rgb 0xFF00) 8)
rlm@502 292 b (bit-and rgb 0xFF)]
rlm@502 293 [r g b]))
rlm@502 294
rlm@502 295 (def reverse-gb-color-map
rlm@502 296 (zipmap (vals gb-color-map)
rlm@502 297 (keys gb-color-map)))
rlm@502 298
rlm@502 299 (defn vga-rgb->gb-rgb [[r g b]]
rlm@502 300 (reverse-gb-color-map [r g b]))
rlm@502 301
rlm@502 302 (defn gb-tiles [^BufferedImage image]
rlm@502 303 (for [tile (range 360)]
rlm@502 304 (for [x (range 8) y (range 8)]
rlm@502 305 (vga-rgb->gb-rgb
rlm@502 306 (rgb->triplet
rlm@503 307 (.getRGB image (+ x (* 8 (rem tile 20)))
rlm@503 308 (+ y (* 8 (int (/ tile 20))))))))))
rlm@503 309
rlm@503 310 (defn tile->palette [tile]
rlm@506 311 (vec (sort (set tile))))
rlm@503 312
rlm@503 313 (require 'clojure.set)
rlm@503 314
rlm@503 315 (defn absorb-contract [objs]
rlm@503 316 (reduce
rlm@503 317 (fn [accepted new-element]
rlm@503 318 (if (some
rlm@503 319 (fn [obj]
rlm@503 320 (clojure.set/subset? (set new-element) (set obj)))
rlm@503 321 accepted)
rlm@503 322 accepted
rlm@503 323 (conj accepted new-element)))
rlm@503 324 []
rlm@503 325 (sort-by (comp - count) objs)))
rlm@503 326
rlm@503 327 (defn absorb-combine-4 [objs]
rlm@504 328
rlm@503 329 )
rlm@503 330
rlm@503 331 (defn palettes [^BufferedImage image]
rlm@503 332 (let [palettes (map tile->palette (gb-tiles image))
rlm@503 333 unique-palettes (absorb-contract (set palettes))]
rlm@503 334 unique-palettes))
rlm@505 335
rlm@506 336 (defn tile-pallete
rlm@506 337 "find the first appropirate palette for the tile in the
rlm@506 338 provided list of palettes."
rlm@506 339 [tile palettes]
rlm@506 340 (let [tile-colors (set tile)]
rlm@506 341 (swank.util/find-first
rlm@506 342 #(clojure.set/subset? tile-colors (set %))
rlm@506 343 palettes)))
rlm@506 344
rlm@506 345
rlm@506 346 (defn image->gb-image
rlm@506 347 "Returns the image in a format amenable to the gameboy's
rlm@506 348 internal representation. The format is:
rlm@506 349 {:width -- width of the image
rlm@506 350 :height -- height of the image
rlm@506 351 :palettes -- vector of all the palettes the image
rlm@506 352 needs, in proper order
rlm@506 353 :tiles -- vector of all the tiles the image needs,
rlm@506 354 in proper order. A tile is 64 palette
rlm@506 355 indices.
rlm@506 356 :data -- vector of pairs of the format:
rlm@506 357 [tile-index, palette-index]
rlm@506 358 in row-oriented order}"
rlm@506 359 [^BufferedImage image]
rlm@506 360 (let [image-palettes (palettes image)
rlm@506 361 palette-index (zipmap
rlm@506 362 image-palettes
rlm@506 363 (range (count image-palettes)))
rlm@506 364 tiles (gb-tiles image)
rlm@506 365 unique-tiles (vec (distinct tiles))
rlm@506 366 tile-index (zipmap unique-tiles
rlm@506 367 (range (count unique-tiles)))]
rlm@506 368 {:width (.getWidth image)
rlm@506 369 :height (.getHeight image)
rlm@506 370 :palettes image-palettes
rlm@506 371 :tiles
rlm@506 372 (vec
rlm@506 373 (for [tile unique-tiles]
rlm@506 374 (let [colors
rlm@506 375 (vec (tile-pallete tile image-palettes))
rlm@506 376 color-index
rlm@506 377 (zipmap colors (range (count colors)))]
rlm@506 378 (mapv color-index tile))))
rlm@506 379 :data
rlm@506 380 (vec
rlm@506 381 (for [tile tiles]
rlm@506 382 (let [tile-colors (set (tile->palette tile))]
rlm@506 383 [(tile-index tile)
rlm@506 384 (palette-index
rlm@506 385 (tile-pallete tile image-palettes))])))}))
rlm@506 386
rlm@506 387
rlm@506 388
rlm@506 389
rlm@506 390
rlm@506 391
rlm@506 392
rlm@506 393
rlm@506 394
rlm@506 395
rlm@506 396 )
rlm@506 397
rlm@505 398 (defn wait-until-v-blank
rlm@505 399 "Modified version of frame-metronome. waits untill LY == 144,
rlm@505 400 indicating start of v-blank period."
rlm@505 401 []
rlm@505 402 (let [timing-loop
rlm@505 403 [0x01 ; \
rlm@505 404 0x44 ; | load 0xFF44 into BC
rlm@505 405 0xFF ; /
rlm@505 406 0x0A] ;; (BC) -> A, now A = LY (vertical line coord)
rlm@505 407 continue-if-144
rlm@505 408 [0xFE
rlm@505 409 144 ;; compare LY (in A) with 144
rlm@505 410 0x20 ;; jump back to beginning if LY != 144 (not-v-blank)
rlm@505 411 (->signed-8-bit
rlm@505 412 (+ -4 (- (count timing-loop))))]]
rlm@505 413 (concat timing-loop continue-if-144)))
rlm@503 414
rlm@503 415
rlm@502 416 (defn display-image-kernel [^BufferedImage image]
rlm@505 417 ;; assume image tile data is stored at 0xA000
rlm@505 418 ;; " " palette date is at 0xB000
rlm@505 419
rlm@502 420
rlm@502 421
rlm@505 422 )
rlm@505 423
rlm@505 424
rlm@505 425