rlm@488: (ns com.aurellem.run.image
rlm@486:   (:use (com.aurellem.gb saves gb-driver util constants
rlm@486:                          items vbm characters money
rlm@486:                          rlm-assembly))
rlm@492:   (:use (com.aurellem.run util music title save-corruption
rlm@486:                           bootstrap-0 bootstrap-1))
rlm@486:   (:require clojure.string)
rlm@486:   (:import [com.aurellem.gb.gb_driver SaveState])
rlm@522:   (:import java.awt.image.BufferedImage)
rlm@486:   (:import java.io.File))
rlm@486: 
rlm@486: ;; want to display an image onto the screen.
rlm@486: ;; probably will be the six ponies, possibly with scrolling. 
rlm@486: 
rlm@486: ;; probably don't need hi-color mode since the images shuld be
rlm@486: ;; simple. 
rlm@486: 
rlm@486: ;; use background tiles?  they provide greater color depth than
rlm@486: ;; sprites, and can still be scrolled, so why not? 
rlm@486: 
rlm@490: ;; could also use sprites to get 3 more colors per tile for a total of
rlm@490: ;; 7 colors per tile, although not for all tiles...
rlm@486: 
rlm@486: 
rlm@486: 
rlm@490: ;; want a function to
rlm@486: 
rlm@490: ;; 1. read an image
rlm@490: ;; 2. split into a grid of 8x8 pixels
rlm@490: ;; 3. convert all RGB colors to gb-RGB colors
rlm@490: ;; 4. determine efficient color palletes for the image
rlm@490: ;; 5. output efficient assembly code to draw the image to the gb
rlm@490: ;; screen.
rlm@486: 
rlm@488: 
rlm@491: (def image-program-target 0xB000)
rlm@486: 
rlm@491: (def display-width 160)
rlm@491: (def display-height 144)
rlm@491: 
rlm@491: 
rlm@491: 
rlm@491: ;{:r :g :b }
rlm@491: 
rlm@491: (def character-data     0x8000)
rlm@491: (def character-data-end 0x97FF)
rlm@491: 
rlm@491: 
rlm@491: 
rlm@491: 
rlm@491: (def BG-data-1 0x9800)
rlm@491: 
rlm@491: (def BG-data-2 0x9C00)
rlm@491: 
rlm@491: (def OAM 0xFE00)
rlm@491: 
rlm@491: 
rlm@491: 
rlm@491: (def video-bank-select-register 0xFF4F)
rlm@491: 
rlm@492: (defn gb-rgb->bits [[r g b]]
rlm@492:   (assert (<= 0 r 31))
rlm@492:   (assert (<= 0 g 31))
rlm@492:   (assert (<= 0 b 31))
rlm@491:   [(bit-and
rlm@491:     0xFF
rlm@491:     (+
rlm@491:      r
rlm@491:      (bit-shift-left g 5)))
rlm@491:    (+
rlm@491:     (bit-shift-right g 3)
rlm@491:     (bit-shift-left  b 2))])
rlm@491: 
rlm@492: 
rlm@492: (def bg-palette-select 0xFF68)
rlm@492: (def bg-palette-data   0xFF69)
rlm@492: 
rlm@492: (def obj-palette-select 0xFF6A)
rlm@492: (def obj-palette-data   0xFF6B)
rlm@492: 
rlm@492: (def max-palettes 8)
rlm@492: 
rlm@511: (defn write-byte [target data]
rlm@492:     (flatten
rlm@492:      [0x3E ;; load literal to A
rlm@492:       data
rlm@492:       0xEA ;; load A into target
rlm@493:       (reverse (disect-bytes-2 target))]))
rlm@492: 
rlm@492: (defn begin-sequential-palette-write
rlm@492:   [palette-num palette-select-address]
rlm@492:   (assert (<= 0 palette-num max-palettes))
rlm@492:   (assert
rlm@492:    (or (= palette-select-address bg-palette-select)
rlm@492:        (= palette-select-address obj-palette-select)))
rlm@492:   (let [palette-write-data
rlm@492:         (Integer/parseInt
rlm@492:          (str "1" ;; auto increment
rlm@492:               "0" ;; not used
rlm@492:               (format
rlm@492:                "%03d"
rlm@492:                (Integer/parseInt
rlm@492:                 (Integer/toBinaryString palette-num) 10))
rlm@492:               "00" ;; color num
rlm@492:               "0"  ;; H/L
rlm@492:               ) 2)]
rlm@511:     (write-byte palette-select-address palette-write-data)))
rlm@492:         
rlm@492: (defn set-palettes [palette-select palette-data palettes]
rlm@492:   (assert (<= (count palettes)) max-palettes)
rlm@492:   (flatten 
rlm@492:    [(begin-sequential-palette-write 0 palette-select)
rlm@511: 
rlm@511:     0x21 ;; target address to HL
rlm@511:     (reverse (disect-bytes-2 palette-data))
rlm@511:     
rlm@511:     
rlm@511:     (for [palette palettes]
rlm@511:       (map (fn [byte]
rlm@511:              [0x3E ;; literal to A
rlm@511:               byte
rlm@511:               0x77]) ;; A -> (HL)
rlm@511:            
rlm@511:            (flatten
rlm@511:             (map #(gb-rgb->bits (get palette % [0 0 0]))
rlm@511:                  (range 4)))))]))
rlm@511:       
rlm@492: 
rlm@491: (defn display-one-color
rlm@507:   "Displayes a single color onto the gameboy screen. Input rgb in
rlm@491:    gameboy rgb."
rlm@498:   ([state [r g b]]
rlm@498:      ;; construct a kernel that displays a single color
rlm@498:      (let
rlm@511:          [palettes (repeat 8 [[r g b] [r g b] [r g b] [r g b]])
rlm@498:           kernel-address 0xC000
rlm@498:           kernel
rlm@498:           [0xF3 ;; disable interrupts
rlm@498:            (clear-music-registers)
rlm@498:            (frame-metronome)
rlm@511:            ;;(set-palettes
rlm@511:            ;; obj-palette-select obj-palette-data palettes)
rlm@511:            (set-palettes
rlm@511:             bg-palette-select bg-palette-data palettes)
rlm@498:            (infinite-loop)]]
rlm@498:        (-> (set-memory-range state
rlm@498:                              kernel-address (flatten kernel))
rlm@498:            (PC! kernel-address))))
rlm@498:   ([[r g b]]
rlm@498:      (display-one-color @current-state [r g b])))
rlm@492: 
rlm@505: ;;(require 'cortex.sense)
rlm@522: 
rlm@492: 
rlm@505: ;; (defn show-screenshot []
rlm@505: ;;   (let [im (BufferedImage. 160 144 BufferedImage/TYPE_INT_RGB)
rlm@505: ;;         pix (vec (pixels))
rlm@505: ;;         view (cortex.sense/view-image)]
rlm@505: ;;     (dorun (for [x (range 160) y (range 144)]
rlm@505: ;;              (.setRGB im x y (pix (+ x (* 160 y))))))
rlm@505: ;;     (view im)))
rlm@496: 
rlm@500: (defn gb-rgb->vga-rgb [[r g b]]
rlm@498:   (let [vga-rgb  
rlm@498:         (first (pixels
rlm@498:                 (run-moves
rlm@498:                  (display-one-color
rlm@498:                   (tick @current-state)
rlm@498:                   [r g b])
rlm@498:                  [[][]])))]
rlm@498:     [(bit-shift-right (bit-and vga-rgb 0xFF0000) 16)
rlm@498:      (bit-shift-right (bit-and vga-rgb 0xFF00) 8)
rlm@498:      (bit-and vga-rgb 0xFF)]))
rlm@491: 
rlm@498: (defn generate-gb-color-map []
rlm@498:   (set-state! (mid-game))
rlm@498:   (let [gb-colors
rlm@498:         (for [r (range 32)
rlm@498:               g (range 32)
rlm@498:               b (range 32)]
rlm@498:           [r g b])]
rlm@498:     (zipmap gb-colors
rlm@498:             (map gb-rgb->vga-rgb
rlm@498:                  gb-colors))))
rlm@491: 
rlm@498: (import java.io.FileWriter)
rlm@491: 
rlm@498: (def gb-color-map-file
rlm@498:   (File. user-home "proj/vba-clojure/gb-color-map"))
rlm@495: 
rlm@498: (defn write-gb-color-map! []
rlm@498:   (binding [*out*(FileWriter. gb-color-map-file)]
rlm@498:     (let [out-str
rlm@498:           (.replace
rlm@498:            (str 
rlm@498:             (into (sorted-map) (generate-gb-color-map)))
rlm@498:            "," ",\n")]
rlm@498:       (println out-str))))
rlm@498: 
rlm@499: (def gb-color-map 
rlm@499:   (read-string (slurp gb-color-map-file)))
rlm@499: 
rlm@499: (import javax.imageio.stream.FileImageOutputStream)
rlm@499: (import '(javax.imageio ImageWriteParam IIOImage ImageIO))
rlm@499: 
rlm@499: 
rlm@522: (defn write-image! [^BufferedImage image ^File target]
rlm@522:   (doto
rlm@522:       (.next (ImageIO/getImageWritersByFormatName "png"))
rlm@522:     (.setOutput (FileImageOutputStream. target))
rlm@522:     (.write (IIOImage. image nil nil))
rlm@522:     (.dispose))
rlm@522:   image)
rlm@522: 
rlm@522: 
rlm@499: (defn gen-gb-color-image! []
rlm@500:   (let [im (BufferedImage. 68 69 BufferedImage/TYPE_INT_RGB)
rlm@499:         pix (vec
rlm@499: 
rlm@499:              (reduce
rlm@499:               concat
rlm@499:               (map (partial
rlm@499:                     sort-by
rlm@499:                     (fn [[r g b]]
rlm@499:                       (let [s (max r g b)
rlm@499:                             det
rlm@499:                             (cond
rlm@499:                              (= s r)
rlm@499:                              (+ -1000 (- g) b)
rlm@499:                              (= s b)
rlm@499:                              (+ (- r) g)
rlm@499:                              (= s g)
rlm@499:                              (+ 1000 (- b) r))]
rlm@499:                         det)))
rlm@499:                    (partition
rlm@500:                     68 68 []
rlm@499:                     (sort-by
rlm@499:                      (fn euclidean-distance [[r g b]]
rlm@499:                        (Math/sqrt (+ (* r r) (* g g) (* b b))))
rlm@501:                      (filter
rlm@501:                       (fn [[r g b]]
rlm@501:                         (= (max r g b) b ))
rlm@501:                      
rlm@501:                       (seq (set (vals gb-color-map)))))))))
rlm@505:         ;;view (cortex.sense/view-image)
rlm@515:         target
rlm@515:         (File. user-home "proj/vba-clojure/gb-color-map-unique.png")]
rlm@500:     (dorun (for [x (range 68) y (range 69)]
rlm@500:              (let [[r g b] (get pix (+ x (* 68 y)) [0 0 0])
rlm@499:                    rgb (+ (bit-shift-left r 16)
rlm@499:                           (bit-shift-left g 8)
rlm@499:                           b)]
rlm@505:                (.setRGB im x y rgb))))
rlm@505:     ;;(view im)
rlm@522:     (write-image! im target)))
rlm@522: 
rlm@522: 
rlm@499: (defn gen-gb-color-image*! []
rlm@499:   (let [im (BufferedImage. 213 213 BufferedImage/TYPE_INT_RGB)
rlm@499:         squares
rlm@499:         (vec
rlm@499:          (for [r (range 32)]
rlm@499:            (vec
rlm@499:             (for [b (range 32) g (range 32)]
rlm@499:               (gb-color-map [r g b])))))
rlm@505:         ;;view (cortex.sense/view-image)
rlm@499:         target (File. user-home "proj/vba-clojure/gb-color-map.png")]
rlm@499: 
rlm@499:     (dorun
rlm@499:      (for [s-index (range 32)]
rlm@499:        (dorun
rlm@499:         (for [x (range 32) y (range 32)]
rlm@499:           
rlm@499:           (let [[r g b] ((squares s-index) (+ x (* 32 y))) 
rlm@499:                 rgb (+ (bit-shift-left r 16)
rlm@499:                        (bit-shift-left g 8)
rlm@499:                        b)]
rlm@499:             (.setRGB im
rlm@499:                      (+ 3 (* 35 (rem s-index 6)) x)
rlm@499:                      (+ 3 (* 35 (int (/ s-index 6))) y)
rlm@499:                      rgb))))))
rlm@505:     ;;(view im)
rlm@522:     (write-image! im target)))
rlm@501: 
rlm@518: (defn gen-gimp-palette! []
rlm@518:   (let [target
rlm@518:         (File. user-home "proj/vba-clojure/Gameboy-Color.gpl")]
rlm@518:     (spit
rlm@518:      target 
rlm@518:      (apply
rlm@518:       str
rlm@518:       (concat
rlm@518:        ["GIMP Palette\n"
rlm@518:         "Name: GameBoy\n"
rlm@518:         "#\n"]
rlm@518:        (map (fn [[r g b]]
rlm@518:               (format "%3d %3d %3d\n" r g b))
rlm@518:             (sort (set (vals gb-color-map)))))))))
rlm@518:      
rlm@502: (def test-image
rlm@502:   (ImageIO/read
rlm@502:    (File. user-home "/proj/vba-clojure/images/test-gb-image.png")))
rlm@502: 
rlm@514: (def test-image-2
rlm@514:   (ImageIO/read
rlm@514:    (File. user-home "/proj/vba-clojure/images/test-gb-image-2.png")))
rlm@514: 
rlm@515: (def test-image-color
rlm@515:   (ImageIO/read
rlm@515:    (File. user-home "/proj/vba-clojure/images/colors-test.png")))
rlm@515: 
rlm@519: (def pinkie-pie-mark
rlm@519:   (ImageIO/read
rlm@519:    (File. user-home "/proj/vba-clojure/images/pinkie-pie-cutie-mark.png")))
rlm@519: 
rlm@519: 
rlm@502: (defn rgb->triplet [rgb]
rlm@502:   (let [r (bit-shift-right (bit-and rgb 0xFF0000) 16)
rlm@502:         g (bit-shift-right (bit-and rgb 0xFF00)    8)
rlm@502:         b                  (bit-and rgb 0xFF)]
rlm@502:     [r g b]))
rlm@502: 
rlm@502: (def reverse-gb-color-map
rlm@502:   (zipmap (vals gb-color-map)
rlm@502:           (keys gb-color-map)))
rlm@502: 
rlm@502: (defn vga-rgb->gb-rgb [[r g b]]
rlm@502:   (reverse-gb-color-map [r g b]))
rlm@502: 
rlm@502: (defn gb-tiles [^BufferedImage image]
rlm@502:   (for [tile (range 360)]
rlm@514:     (for [y (range 8) x (range 8)]
rlm@502:       (vga-rgb->gb-rgb
rlm@502:        (rgb->triplet
rlm@503:         (.getRGB image (+ x (* 8 (rem tile 20)))
rlm@503:                  (+ y (* 8 (int (/ tile 20))))))))))
rlm@503: 
rlm@503: (defn tile->palette [tile]
rlm@506:   (vec (sort (set tile))))
rlm@503: 
rlm@503: (require 'clojure.set)
rlm@503: 
rlm@503: (defn absorb-contract [objs]
rlm@503:   (reduce
rlm@503:    (fn [accepted new-element]
rlm@503:      (if (some
rlm@503:           (fn [obj]
rlm@503:             (clojure.set/subset? (set new-element) (set obj)))
rlm@503:           accepted)
rlm@503:        accepted
rlm@503:        (conj accepted new-element)))
rlm@503:    []
rlm@503:    (sort-by (comp - count) objs)))
rlm@503: 
rlm@503: (defn palettes [^BufferedImage image]
rlm@503:   (let [palettes (map tile->palette (gb-tiles image))
rlm@503:         unique-palettes (absorb-contract (set palettes))]
rlm@503:     unique-palettes))
rlm@505: 
rlm@506: (defn tile-pallete
rlm@506:   "find the first appropirate palette for the tile in the
rlm@506:    provided list of palettes."
rlm@506:   [tile palettes]
rlm@506:   (let [tile-colors (set tile)]
rlm@506:     (swank.util/find-first
rlm@506:      #(clojure.set/subset? tile-colors (set %))
rlm@506:      palettes)))
rlm@506: 
rlm@506: 
rlm@506: (defn image->gb-image
rlm@506:     "Returns the image in a format amenable to the gameboy's
rlm@506:      internal representation.  The format is:
rlm@506:      {:width    --  width of the image
rlm@506:       :height   --  height of the image
rlm@506:       :palettes --  vector of all the palettes the image
rlm@506:                     needs, in proper order
rlm@506:       :tiles    --  vector of all the tiles the image needs,
rlm@506:                     in proper order. A tile is 64 palette
rlm@506:                     indices.
rlm@506:       :data     --  vector of pairs of the format:
rlm@506:                     [tile-index, palette-index]
rlm@506:                     in row-oriented order}"
rlm@506:   [^BufferedImage image]
rlm@506:   (let [image-palettes (palettes image)
rlm@506:         palette-index (zipmap
rlm@506:                        image-palettes
rlm@506:                        (range (count image-palettes)))
rlm@506:         tiles (gb-tiles image)
rlm@506:         unique-tiles (vec (distinct tiles))
rlm@506:         tile-index (zipmap unique-tiles
rlm@506:                            (range (count unique-tiles)))]
rlm@506:     {:width (.getWidth image)
rlm@506:      :height (.getHeight image)
rlm@506:      :palettes image-palettes
rlm@506:      :tiles
rlm@506:      (vec
rlm@506:       (for [tile unique-tiles]
rlm@506:         (let [colors
rlm@506:               (vec (tile-pallete tile image-palettes))
rlm@506:               color-index
rlm@506:               (zipmap colors (range (count colors)))]
rlm@506:           (mapv color-index tile))))
rlm@506:      :data
rlm@506:      (vec 
rlm@506:       (for [tile tiles]
rlm@506:         (let [tile-colors (set (tile->palette tile))]
rlm@506:           [(tile-index tile)
rlm@506:            (palette-index
rlm@506:             (tile-pallete tile image-palettes))])))}))
rlm@506: 
rlm@505: (defn wait-until-v-blank
rlm@505:   "Modified version of frame-metronome. waits untill LY == 144,
rlm@505:    indicating start of v-blank period."
rlm@505:   []
rlm@505:   (let [timing-loop
rlm@505:         [0x01 ; \
rlm@505:          0x44 ;  | load 0xFF44 into BC
rlm@505:          0xFF ; /  
rlm@505:          0x0A] ;; (BC) -> A, now A = LY (vertical line coord)
rlm@505:         continue-if-144
rlm@505:         [0xFE
rlm@505:          144  ;; compare LY (in A) with 144
rlm@505:          0x20 ;; jump back to beginning if LY != 144 (not-v-blank)
rlm@505:          (->signed-8-bit
rlm@505:           (+ -4 (- (count timing-loop))))]]
rlm@505:     (concat timing-loop continue-if-144)))
rlm@503: 
rlm@507: (def bg-character-data 0x9000)
rlm@507: 
rlm@507: (defn gb-tile->bytes
rlm@507:   "Tile is a vector of 64 numbers between 0 and 3 that
rlm@507:    represent a single 8x8 color tile in the GB screen.
rlm@507:    It gets bit-packed into to 16 8-bit numbers in the following
rlm@507:    form:
rlm@507: 
rlm@507:    0-low  1-low  ... 7-low
rlm@507:    0-high 1-high ... 7-high
rlm@507:    .
rlm@507:    .
rlm@507:    .
rlm@507:    55-low  ........ 63-low
rlm@507:    55-high ........ 63-high"
rlm@507:   [tile]
rlm@507:   (let [row->bits
rlm@507:         (fn [row]
rlm@507:           (mapv
rlm@507:            (fn [row*]
rlm@507:              (Integer/parseInt (apply str row*) 2))
rlm@507:            [(map #(bit-and 0x01 %) row)
rlm@507:             (map #(bit-shift-right (bit-and 0x02 %) 1)
rlm@507:                  row)]))]
rlm@507:     (vec
rlm@507:      (flatten
rlm@507:       (map row->bits
rlm@507:            (partition 8 tile))))))
rlm@507: 
rlm@508: (defn write-data
rlm@508:   "Efficient assembly to write a sequence of values to
rlm@508:    memory, starting at a target address."
rlm@508:   [base-address target-address data]
rlm@510:   (let [len (count data)
rlm@510:         program-length 21] ;; change this if program length
rlm@510:         ;; below changes!
rlm@508:     (flatten
rlm@508:        [0x21 ;; load data address start into HL
rlm@510:         (reverse (disect-bytes-2 (+ base-address program-length)))
rlm@508: 
rlm@508:         0x01 ;; load target address into BC
rlm@508:         (reverse (disect-bytes-2 target-address))
rlm@508:         
rlm@510:         0x11 ;; load len into DE
rlm@510:         (reverse (disect-bytes-2 len))
rlm@508: 
rlm@508:         
rlm@508:         ;; data x-fer loop start
rlm@508:         0x2A ;; (HL) -> A; HL++;
rlm@508:         0x02 ;; A -> (BC);
rlm@508:         0x03 ;; INC BC;
rlm@510:         0x1B ;; DEC DE
rlm@508: 
rlm@510:         0xAF
rlm@510:         0xB2 ;; (OR D E) -> A
rlm@510:         0xB3
rlm@510: 
rlm@508:         
rlm@510:         0x20 ;; if DE is not now 0,
rlm@510:         (->signed-8-bit -9) ;; GOTO start
rlm@508:         
rlm@510:         0xC3
rlm@510:         (reverse
rlm@510:          (disect-bytes-2
rlm@510:           (+ len base-address program-length)))
rlm@510:         data])))
rlm@510: 
rlm@512: (defn write-image
rlm@514:   "Assume the image data is specified as 360 blocks."
rlm@512:   [base-address target-address image-data]
rlm@512:   
rlm@512:   (let [len (count image-data)
rlm@512:         gen-program
rlm@512:         (fn [program-length]
rlm@512:           (flatten 
rlm@513:            [0x01 ;; load data address start into BC
rlm@512:             (reverse
rlm@512:              (disect-bytes-2 (+ base-address program-length)))
rlm@512: 
rlm@513:             0x21 ;; load target address into HL
rlm@512:             (reverse (disect-bytes-2 target-address))
rlm@512: 
rlm@512:             0x1E ;; total-rows (18) -> E
rlm@513:             18
rlm@512: 
rlm@512:             0x16 ;; total columns (20) -> D
rlm@512:             20
rlm@512:             
rlm@513:             ;; data x-fer loop start
rlm@513:             0x0A ;; (BC) -> A;
rlm@513:             0x03 ;; INC BC;
rlm@513:             0x22 ;; A -> (HL); HL++;
rlm@512: 
rlm@512: 
rlm@512: 
rlm@512:             0x15 ;; dec D 
rlm@512:             0x20
rlm@513:             (->signed-8-bit -6) ;; continue writing row
rlm@512: 
rlm@512:             ;; row is complete, advance to next row
rlm@513:             ;; HL += 12
rlm@512: 
rlm@512:             0xC5 ;; push BC
rlm@512: 
rlm@512:             0x06 ;; 0 -> B
rlm@512:             0
rlm@512: 
rlm@512:             0x0E
rlm@513:             12  ;; 12 -> C
rlm@512: 
rlm@512:             0x09 ;; HL + BC -> HL 
rlm@512: 
rlm@512:             0xC1 ;; pop BC
rlm@512:             
rlm@512:             0x1D ;; dec E
rlm@512:             0x20
rlm@514:             (->signed-8-bit -18) ;; contunue writing image
rlm@512: 
rlm@512:             0xC3
rlm@512:             (reverse
rlm@512:              (disect-bytes-2
rlm@512:               (+ len base-address program-length)))]))]
rlm@512:     (flatten (concat
rlm@512:               (gen-program (count (gen-program 0)))
rlm@512:               image-data))))
rlm@508: 
rlm@508: (defn test-write-data []
rlm@510:   (let [test-data (concat (range 256)
rlm@510:                           (reverse (range 256)))
rlm@510:         base-address 0xC000
rlm@510:         target-address 0xD000
rlm@508: 
rlm@508:         test-kernel
rlm@508:         (flatten
rlm@508:          [0xF3 ;; disable interrupts
rlm@508:           (write-data (+ 1 base-address)
rlm@508:                       target-address test-data)
rlm@508:           (infinite-loop)])]
rlm@509:     (assert
rlm@509:      (= test-data
rlm@509:         (-> (mid-game)
rlm@509:             tick tick tick
rlm@509:             (set-memory-range base-address test-kernel)
rlm@509:             (PC! base-address)
rlm@509:             (run-moves (repeat 100 []))
rlm@509:             (memory)
rlm@509:             vec
rlm@509:             (subvec target-address
rlm@509:                     (+ target-address
rlm@509:                        (count test-data))))))))
rlm@508: 
rlm@511: (def LCD-bank-select-address 0xFF4F)
rlm@511: 
rlm@511: (def BG-1-address 0x9800)
rlm@511: (def BG-2-address 0x9C00)
rlm@511: (def character-data-address 0x8000)
rlm@511: 
rlm@511: (def LCD-control-register 0xFF40)
rlm@511: (def STAT-register        0xFF41)
rlm@511: 
rlm@511: (def SCX-register 0xFF42)
rlm@511: (def SCY-register 0xFF43)
rlm@511: 
rlm@511: (defn select-LCD-bank [n]
rlm@511:   (assert (or (= n 0) (= n 1)))
rlm@511:   (write-byte LCD-bank-select-address n))
rlm@511: 
rlm@512: (defn write-image* [_ _ _] [])
rlm@512: 
rlm@508: (defn display-image-kernel [base-address ^BufferedImage image]
rlm@511:   (let [gb-image (image->gb-image image)
rlm@511:         
rlm@511:         A [(clear-music-registers)
rlm@512: 
rlm@511:            ;; [X] disable LCD protection circuit.
rlm@511:            (write-byte LCD-control-register 0x00)
rlm@511:            ;; now we can write to all video RAM anytime with
rlm@511:            ;; impunity.
rlm@511:            
rlm@512:            ;; [ ] We're only using background palettes; just set the
rlm@512:            ;; minimum required bg palettes for this image, starting
rlm@512:            ;; with palette #0.
rlm@502: 
rlm@511:            (set-palettes bg-palette-select bg-palette-data
rlm@511:                          (:palettes gb-image))
rlm@507: 
rlm@511:            ;; [X] switch to bank 0 to set BG character data.
rlm@511:            (select-LCD-bank 0)
rlm@511:            ;; [X] set SCX and SCY to 0
rlm@511:            (write-byte SCX-register 0)
rlm@511:            (write-byte SCY-register 0)
rlm@511:            ]
rlm@511:         A (flatten A)
rlm@507: 
rlm@511:         B [;; [X] write minimum amount of tiles to BG character
rlm@511:            ;; section
rlm@511:            (write-data
rlm@511:             (+ base-address (count A))
rlm@511:             character-data-address
rlm@511:             (flatten
rlm@515:              (map gb-tile->bytes (:tiles gb-image))))
rlm@517:            (select-LCD-bank 0)]
rlm@511:         B (flatten B)
rlm@507: 
rlm@511:         
rlm@517:         C [;; [X] write image to the screen in terms of tiles
rlm@512:            (write-image
rlm@511:             (+ base-address (+ (count A) (count B)))
rlm@511:             BG-1-address
rlm@517:             (map first (:data gb-image)))
rlm@517:            (select-LCD-bank 1)]
rlm@507: 
rlm@511:         C (flatten C)
rlm@507: 
rlm@517:         D [;; [X] specifiy pallets for each character
rlm@515:            (write-image
rlm@515:             (+ base-address (+ (count A) (count B) (count C)))
rlm@515:             BG-1-address
rlm@517:             (map second (:data gb-image)))
rlm@515:            
rlm@505: 
rlm@511:            ;; [X] reactivate the LCD display
rlm@511:            ;; we're using only BG images, located at
rlm@511:            ;; BG-1 (0x9800), with background character data
rlm@511:            ;; stored starting at 0x8000
rlm@505: 
rlm@511:            (write-byte
rlm@511:             LCD-control-register
rlm@511:             (Integer/parseInt
rlm@511:              (str
rlm@511:               "1"  ;; LCDC on/off
rlm@511:               "0"  ;; Window code area
rlm@511:               "0"  ;; Windowing on?
rlm@511:               "1"  ;; BG tile base (1 = 0x8000)
rlm@511:               "0"  ;; BG-1 or BG-2 ?
rlm@511:               "0"  ;; OBJ-block composition
rlm@511:               "0"  ;; OBJ-on flag 
rlm@511:               "1") ;; no-effect 
rlm@511:              2))
rlm@540:            ]
rlm@505: 
rlm@511:         D (flatten D)]
rlm@511: 
rlm@511:     (concat A B C D)))
rlm@511: 
rlm@511: (defn display-image [#^BufferedImage image]
rlm@522:   (let [kernel-address 0xB500]
rlm@511:     (-> (tick (tick (tick (mid-game))))
rlm@511:         (set-memory-range
rlm@511:          kernel-address
rlm@540:          (concat (display-image-kernel kernel-address image)
rlm@540:                  (infinite-loop)))
rlm@511:         (PC! kernel-address))))
rlm@522: