Mercurial > vba-clojure

annotate clojure/com/aurellem/run/image.clj @ 504:81e43f0350db

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
resolved conflict.
author Robert McIntyre <rlm@mit.edu>
date Mon, 18 Jun 2012 18:56:49 -0500
parents 4703b74f1fb1
children f992a0a0480d
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@504 129 <<<<<<< local
rlm@504 130 [[r g b]]
rlm@504 131 ;; construct a kernel that displays a single color
rlm@504 132 (let
rlm@504 133 [palettes (repeat 8 [r g b])
rlm@504 134 kernel-address 0xC000
rlm@504 135 kernel
rlm@504 136 [0xF3 ;; disable interrupts
rlm@504 137 (clear-music-registers)
rlm@504 138 (frame-metronome)
rlm@504 139 (set-palettes obj-palette-select obj-palette-data palettes)
rlm@504 140 (set-palettes bg-palette-select bg-palette-data palettes)
rlm@504 141 (infinite-loop)]]
rlm@504 142 (-> (set-memory-range (second (music-base))
rlm@504 143 kernel-address (flatten kernel))
rlm@504 144 (PC! kernel-address))))
rlm@504 145 =======
rlm@498 146 ([state [r g b]]
rlm@498 147 ;; construct a kernel that displays a single color
rlm@498 148 (let
rlm@498 149 [palettes (repeat 8 [r g b])
rlm@498 150 kernel-address 0xC000
rlm@498 151 kernel
rlm@498 152 [0xF3 ;; disable interrupts
rlm@498 153 (clear-music-registers)
rlm@498 154 (frame-metronome)
rlm@498 155 (set-palettes obj-palette-select obj-palette-data palettes)
rlm@498 156 (set-palettes bg-palette-select bg-palette-data palettes)
rlm@498 157 (infinite-loop)]]
rlm@498 158 (-> (set-memory-range state
rlm@498 159 kernel-address (flatten kernel))
rlm@498 160 (PC! kernel-address))))
rlm@498 161 ([[r g b]]
rlm@498 162 (display-one-color @current-state [r g b])))
rlm@492 163
rlm@496 164 (require 'cortex.sense)
rlm@496 165 (import java.awt.image.BufferedImage)
rlm@492 166
rlm@496 167 (defn show-screenshot []
rlm@496 168 (let [im (BufferedImage. 160 144 BufferedImage/TYPE_INT_RGB)
rlm@496 169 pix (vec (pixels))
rlm@496 170 view (cortex.sense/view-image)]
rlm@496 171 (dorun (for [x (range 160) y (range 144)]
rlm@498 172 (.setRGB im x y (pix (+ x (* 160 y))))))
rlm@496 173 (view im)))
rlm@496 174
rlm@500 175 (defn gb-rgb->vga-rgb [[r g b]]
rlm@498 176 (let [vga-rgb
rlm@498 177 (first (pixels
rlm@498 178 (run-moves
rlm@498 179 (display-one-color
rlm@498 180 (tick @current-state)
rlm@498 181 [r g b])
rlm@498 182 [[][]])))]
rlm@498 183 [(bit-shift-right (bit-and vga-rgb 0xFF0000) 16)
rlm@498 184 (bit-shift-right (bit-and vga-rgb 0xFF00) 8)
rlm@498 185 (bit-and vga-rgb 0xFF)]))
rlm@491 186
rlm@498 187 (defn generate-gb-color-map []
rlm@498 188 (set-state! (mid-game))
rlm@498 189 (let [gb-colors
rlm@498 190 (for [r (range 32)
rlm@498 191 g (range 32)
rlm@498 192 b (range 32)]
rlm@498 193 [r g b])]
rlm@498 194 (zipmap gb-colors
rlm@498 195 (map gb-rgb->vga-rgb
rlm@498 196 gb-colors))))
rlm@491 197
rlm@498 198 (import java.io.FileWriter)
rlm@491 199
rlm@498 200 (def gb-color-map-file
rlm@498 201 (File. user-home "proj/vba-clojure/gb-color-map"))
rlm@495 202
rlm@498 203 (defn write-gb-color-map! []
rlm@498 204 (binding [*out*(FileWriter. gb-color-map-file)]
rlm@498 205 (let [out-str
rlm@498 206 (.replace
rlm@498 207 (str
rlm@498 208 (into (sorted-map) (generate-gb-color-map)))
rlm@498 209 "," ",\n")]
rlm@498 210 (println out-str))))
rlm@498 211
rlm@499 212 (def gb-color-map
rlm@499 213 (read-string (slurp gb-color-map-file)))
rlm@499 214
rlm@499 215 (import javax.imageio.stream.FileImageOutputStream)
rlm@499 216 (import '(javax.imageio ImageWriteParam IIOImage ImageIO))
rlm@499 217
rlm@499 218
rlm@499 219 (defn gen-gb-color-image! []
rlm@500 220 (let [im (BufferedImage. 68 69 BufferedImage/TYPE_INT_RGB)
rlm@499 221 pix (vec
rlm@499 222
rlm@499 223 (reduce
rlm@499 224 concat
rlm@499 225 (map (partial
rlm@499 226 sort-by
rlm@499 227 (fn [[r g b]]
rlm@499 228 (let [s (max r g b)
rlm@499 229 det
rlm@499 230 (cond
rlm@499 231 (= s r)
rlm@499 232 (+ -1000 (- g) b)
rlm@499 233 (= s b)
rlm@499 234 (+ (- r) g)
rlm@499 235 (= s g)
rlm@499 236 (+ 1000 (- b) r))]
rlm@499 237 det)))
rlm@499 238 (partition
rlm@500 239 68 68 []
rlm@499 240 (sort-by
rlm@499 241 (fn euclidean-distance [[r g b]]
rlm@499 242 (Math/sqrt (+ (* r r) (* g g) (* b b))))
rlm@501 243 (filter
rlm@501 244 (fn [[r g b]]
rlm@501 245 (= (max r g b) b ))
rlm@501 246
rlm@501 247 (seq (set (vals gb-color-map)))))))))
rlm@499 248 view (cortex.sense/view-image)
rlm@500 249 target (File. user-home "proj/vba-clojure/gb-color-map-unique.png")]
rlm@500 250 (dorun (for [x (range 68) y (range 69)]
rlm@500 251 (let [[r g b] (get pix (+ x (* 68 y)) [0 0 0])
rlm@499 252 rgb (+ (bit-shift-left r 16)
rlm@499 253 (bit-shift-left g 8)
rlm@499 254 b)]
rlm@499 255 (.setRGB im x y rgb))))
rlm@499 256 (view im)
rlm@499 257 (doto
rlm@499 258 (.next (ImageIO/getImageWritersByFormatName "png"))
rlm@499 259 (.setOutput (FileImageOutputStream. target))
rlm@499 260 (.write (IIOImage. im nil nil))
rlm@499 261 (.dispose))
rlm@499 262 im))
rlm@499 263
rlm@499 264 (defn gen-gb-color-image*! []
rlm@499 265 (let [im (BufferedImage. 213 213 BufferedImage/TYPE_INT_RGB)
rlm@499 266 squares
rlm@499 267 (vec
rlm@499 268 (for [r (range 32)]
rlm@499 269 (vec
rlm@499 270 (for [b (range 32) g (range 32)]
rlm@499 271 (gb-color-map [r g b])))))
rlm@499 272 view (cortex.sense/view-image)
rlm@499 273 target (File. user-home "proj/vba-clojure/gb-color-map.png")]
rlm@499 274
rlm@499 275 (dorun
rlm@499 276 (for [s-index (range 32)]
rlm@499 277 (dorun
rlm@499 278 (for [x (range 32) y (range 32)]
rlm@499 279
rlm@499 280 (let [[r g b] ((squares s-index) (+ x (* 32 y)))
rlm@499 281 rgb (+ (bit-shift-left r 16)
rlm@499 282 (bit-shift-left g 8)
rlm@499 283 b)]
rlm@499 284 (.setRGB im
rlm@499 285 (+ 3 (* 35 (rem s-index 6)) x)
rlm@499 286 (+ 3 (* 35 (int (/ s-index 6))) y)
rlm@499 287 rgb))))))
rlm@499 288 (view im)
rlm@499 289 (doto
rlm@499 290 (.next (ImageIO/getImageWritersByFormatName "png"))
rlm@499 291 (.setOutput (FileImageOutputStream. target))
rlm@499 292 (.write (IIOImage. im nil nil))
rlm@499 293 (.dispose))
rlm@499 294 im))
rlm@501 295
rlm@501 296
rlm@501 297 (count
rlm@501 298 (filter
rlm@501 299 (fn [[r g b]]
rlm@501 300 (= (max r g b) r ))(set (vals gb-color-map))))
rlm@502 301
rlm@502 302 (def test-image
rlm@502 303 (ImageIO/read
rlm@502 304 (File. user-home "/proj/vba-clojure/images/test-gb-image.png")))
rlm@502 305
rlm@502 306 (defn rgb->triplet [rgb]
rlm@502 307 (let [r (bit-shift-right (bit-and rgb 0xFF0000) 16)
rlm@502 308 g (bit-shift-right (bit-and rgb 0xFF00) 8)
rlm@502 309 b (bit-and rgb 0xFF)]
rlm@502 310 [r g b]))
rlm@502 311
rlm@502 312 (def reverse-gb-color-map
rlm@502 313 (zipmap (vals gb-color-map)
rlm@502 314 (keys gb-color-map)))
rlm@502 315
rlm@502 316 (defn vga-rgb->gb-rgb [[r g b]]
rlm@502 317 (reverse-gb-color-map [r g b]))
rlm@502 318
rlm@502 319 (defn gb-tiles [^BufferedImage image]
rlm@502 320 (for [tile (range 360)]
rlm@502 321 (for [x (range 8) y (range 8)]
rlm@502 322 (vga-rgb->gb-rgb
rlm@502 323 (rgb->triplet
rlm@503 324 (.getRGB image (+ x (* 8 (rem tile 20)))
rlm@503 325 (+ y (* 8 (int (/ tile 20))))))))))
rlm@503 326
rlm@503 327 (defn tile->palette [tile]
rlm@503 328 (sort (set tile)))
rlm@503 329
rlm@503 330 (require 'clojure.set)
rlm@503 331
rlm@503 332 (defn absorb-contract [objs]
rlm@503 333 (reduce
rlm@503 334 (fn [accepted new-element]
rlm@503 335 (if (some
rlm@503 336 (fn [obj]
rlm@503 337 (clojure.set/subset? (set new-element) (set obj)))
rlm@503 338 accepted)
rlm@503 339 accepted
rlm@503 340 (conj accepted new-element)))
rlm@503 341 []
rlm@503 342 (sort-by (comp - count) objs)))
rlm@503 343
rlm@503 344 (defn absorb-combine-4 [objs]
rlm@504 345
rlm@502 346
rlm@502 347
rlm@503 348 )
rlm@503 349
rlm@503 350 (defn palettes [^BufferedImage image]
rlm@503 351 (let [palettes (map tile->palette (gb-tiles image))
rlm@503 352 unique-palettes (absorb-contract (set palettes))]
rlm@503 353 unique-palettes))
rlm@503 354
rlm@503 355
rlm@503 356
rlm@503 357
rlm@503 358
rlm@503 359
rlm@503 360
rlm@503 361
rlm@502 362 (defn display-image-kernel [^BufferedImage image]
rlm@502 363
rlm@502 364
rlm@502 365
rlm@502 366 )