(ns com.aurellem.run.image

   (:use (com.aurellem.gb saves gb-driver util constants

                          items vbm characters money

                          rlm-assembly))

   (:use (com.aurellem.run util music title save-corruption

                           bootstrap-0 bootstrap-1))

   (:require clojure.string)

   (:import [com.aurellem.gb.gb_driver SaveState])

   (:import java.awt.image.BufferedImage)

   (:import java.io.File))

 

 ;; want to display an image onto the screen.

 ;; probably will be the six ponies, possibly with scrolling. 

 

 ;; probably don't need hi-color mode since the images shuld be

 ;; simple. 

 

 ;; use background tiles?  they provide greater color depth than

 ;; sprites, and can still be scrolled, so why not? 

 

 ;; could also use sprites to get 3 more colors per tile for a total of

 ;; 7 colors per tile, although not for all tiles...

 

 

 

 ;; want a function to

 

 ;; 1. read an image

 ;; 2. split into a grid of 8x8 pixels

 ;; 3. convert all RGB colors to gb-RGB colors

 ;; 4. determine efficient color palletes for the image

 ;; 5. output efficient assembly code to draw the image to the gb

 ;; screen.

 

 

 (def image-program-target 0xB000)

 

 (def display-width 160)

 (def display-height 144)

 

 

 

 ;{:r :g :b }

 

 (def character-data     0x8000)

 (def character-data-end 0x97FF)

 

 

 

 

 (def BG-data-1 0x9800)

 

 (def BG-data-2 0x9C00)

 

 (def OAM 0xFE00)

 

 

 

 (def video-bank-select-register 0xFF4F)

 

 (defn gb-rgb->bits [[r g b]]

   (assert (<= 0 r 31))

   (assert (<= 0 g 31))

   (assert (<= 0 b 31))

   [(bit-and

     0xFF

     (+

      r

      (bit-shift-left g 5)))

    (+

     (bit-shift-right g 3)

     (bit-shift-left  b 2))])

 

 

 (def bg-palette-select 0xFF68)

 (def bg-palette-data   0xFF69)

 

 (def obj-palette-select 0xFF6A)

 (def obj-palette-data   0xFF6B)

 

 (def max-palettes 8)

 

 (defn write-byte [target data]

     (flatten

      [0x3E ;; load literal to A

       data

       0xEA ;; load A into target

       (reverse (disect-bytes-2 target))]))

 

 (defn begin-sequential-palette-write

   [palette-num palette-select-address]

   (assert (<= 0 palette-num max-palettes))

   (assert

    (or (= palette-select-address bg-palette-select)

        (= palette-select-address obj-palette-select)))

   (let [palette-write-data

         (Integer/parseInt

          (str "1" ;; auto increment

               "0" ;; not used

               (format

                "%03d"

                (Integer/parseInt

                 (Integer/toBinaryString palette-num) 10))

               "00" ;; color num

               "0"  ;; H/L

               ) 2)]

     (write-byte palette-select-address palette-write-data)))

         

 (defn set-palettes [palette-select palette-data palettes]

   (assert (<= (count palettes)) max-palettes)

   (flatten 

    [(begin-sequential-palette-write 0 palette-select)

 

     0x21 ;; target address to HL

     (reverse (disect-bytes-2 palette-data))

     

     

     (for [palette palettes]

       (map (fn [byte]

              [0x3E ;; literal to A

               byte

               0x77]) ;; A -> (HL)

            

            (flatten

             (map #(gb-rgb->bits (get palette % [0 0 0]))

                  (range 4)))))]))

       

 

 (defn display-one-color

   "Displayes a single color onto the gameboy screen. Input rgb in

    gameboy rgb."

   ([state [r g b]]

      ;; construct a kernel that displays a single color

      (let

          [palettes (repeat 8 [[r g b] [r g b] [r g b] [r g b]])

           kernel-address 0xC000

           kernel

           [0xF3 ;; disable interrupts

            (clear-music-registers)

            (frame-metronome)

            ;;(set-palettes

            ;; obj-palette-select obj-palette-data palettes)

            (set-palettes

             bg-palette-select bg-palette-data palettes)

            (infinite-loop)]]

        (-> (set-memory-range state

                              kernel-address (flatten kernel))

            (PC! kernel-address))))

   ([[r g b]]

      (display-one-color @current-state [r g b])))

 

 ;;(require 'cortex.sense)

 

 

 ;; (defn show-screenshot []

 ;;   (let [im (BufferedImage. 160 144 BufferedImage/TYPE_INT_RGB)

 ;;         pix (vec (pixels))

 ;;         view (cortex.sense/view-image)]

 ;;     (dorun (for [x (range 160) y (range 144)]

 ;;              (.setRGB im x y (pix (+ x (* 160 y))))))

 ;;     (view im)))

 

 (defn gb-rgb->vga-rgb [[r g b]]

   (let [vga-rgb  

         (first (pixels

                 (run-moves

                  (display-one-color

                   (tick @current-state)

                   [r g b])

                  [[][]])))]

     [(bit-shift-right (bit-and vga-rgb 0xFF0000) 16)

      (bit-shift-right (bit-and vga-rgb 0xFF00) 8)

      (bit-and vga-rgb 0xFF)]))

 

 (defn generate-gb-color-map []

   (set-state! (mid-game))

   (let [gb-colors

         (for [r (range 32)

               g (range 32)

               b (range 32)]

           [r g b])]

     (zipmap gb-colors

             (map gb-rgb->vga-rgb

                  gb-colors))))

 

 (import java.io.FileWriter)

 

 (def gb-color-map-file

   (File. user-home "proj/vba-clojure/gb-color-map"))

 

 (defn write-gb-color-map! []

   (binding [*out*(FileWriter. gb-color-map-file)]

     (let [out-str

           (.replace

            (str 

             (into (sorted-map) (generate-gb-color-map)))

            "," ",\n")]

       (println out-str))))

 

 (def gb-color-map 

   (read-string (slurp gb-color-map-file)))

 

 (import javax.imageio.stream.FileImageOutputStream)

 (import '(javax.imageio ImageWriteParam IIOImage ImageIO))

 

 

 (defn write-image! [^BufferedImage image ^File target]

   (doto

       (.next (ImageIO/getImageWritersByFormatName "png"))

     (.setOutput (FileImageOutputStream. target))

     (.write (IIOImage. image nil nil))

     (.dispose))

   image)

 

 

 (defn gen-gb-color-image! []

   (let [im (BufferedImage. 68 69 BufferedImage/TYPE_INT_RGB)

         pix (vec

 

              (reduce

               concat

               (map (partial

                     sort-by

                     (fn [[r g b]]

                       (let [s (max r g b)

                             det

                             (cond

                              (= s r)

                              (+ -1000 (- g) b)

                              (= s b)

                              (+ (- r) g)

                              (= s g)

                              (+ 1000 (- b) r))]

                         det)))

                    (partition

                     68 68 []

                     (sort-by

                      (fn euclidean-distance [[r g b]]

                        (Math/sqrt (+ (* r r) (* g g) (* b b))))

                      (filter

                       (fn [[r g b]]

                         (= (max r g b) b ))

                      

                       (seq (set (vals gb-color-map)))))))))

         ;;view (cortex.sense/view-image)

         target

         (File. user-home "proj/vba-clojure/gb-color-map-unique.png")]

     (dorun (for [x (range 68) y (range 69)]

              (let [[r g b] (get pix (+ x (* 68 y)) [0 0 0])

                    rgb (+ (bit-shift-left r 16)

                           (bit-shift-left g 8)

                           b)]

                (.setRGB im x y rgb))))

     ;;(view im)

     (write-image! im target)))

 

 

 (defn gen-gb-color-image*! []

   (let [im (BufferedImage. 213 213 BufferedImage/TYPE_INT_RGB)

         squares

         (vec

          (for [r (range 32)]

            (vec

             (for [b (range 32) g (range 32)]

               (gb-color-map [r g b])))))

         ;;view (cortex.sense/view-image)

         target (File. user-home "proj/vba-clojure/gb-color-map.png")]

 

     (dorun

      (for [s-index (range 32)]

        (dorun

         (for [x (range 32) y (range 32)]

           

           (let [[r g b] ((squares s-index) (+ x (* 32 y))) 

                 rgb (+ (bit-shift-left r 16)

                        (bit-shift-left g 8)

                        b)]

             (.setRGB im

                      (+ 3 (* 35 (rem s-index 6)) x)

                      (+ 3 (* 35 (int (/ s-index 6))) y)

                      rgb))))))

     ;;(view im)

     (write-image! im target)))

 

 (defn gen-gimp-palette! []

   (let [target

         (File. user-home "proj/vba-clojure/Gameboy-Color.gpl")]

     (spit

      target 

      (apply

       str

       (concat

        ["GIMP Palette\n"

         "Name: GameBoy\n"

         "#\n"]

        (map (fn [[r g b]]

               (format "%3d %3d %3d\n" r g b))

             (sort (set (vals gb-color-map)))))))))

      

 (def test-image

   (ImageIO/read

    (File. user-home "/proj/vba-clojure/images/test-gb-image.png")))

 

 (def test-image-2

   (ImageIO/read

    (File. user-home "/proj/vba-clojure/images/test-gb-image-2.png")))

 

 (def test-image-color

   (ImageIO/read

    (File. user-home "/proj/vba-clojure/images/colors-test.png")))

 

 (def pinkie-pie-mark

   (ImageIO/read

    (File. user-home "/proj/vba-clojure/images/pinkie-pie-cutie-mark.png")))

 

 

 (defn rgb->triplet [rgb]

   (let [r (bit-shift-right (bit-and rgb 0xFF0000) 16)

         g (bit-shift-right (bit-and rgb 0xFF00)    8)

         b                  (bit-and rgb 0xFF)]

     [r g b]))

 

 (def reverse-gb-color-map

   (zipmap (vals gb-color-map)

           (keys gb-color-map)))

 

 (defn vga-rgb->gb-rgb [[r g b]]

   (reverse-gb-color-map [r g b]))

 

 (defn gb-tiles [^BufferedImage image]

   (for [tile (range 360)]

     (for [y (range 8) x (range 8)]

       (vga-rgb->gb-rgb

        (rgb->triplet

         (.getRGB image (+ x (* 8 (rem tile 20)))

                  (+ y (* 8 (int (/ tile 20))))))))))

 

 (defn tile->palette [tile]

   (vec (sort (set tile))))

 

 (require 'clojure.set)

 

 (defn absorb-contract [objs]

   (reduce

    (fn [accepted new-element]

      (if (some

           (fn [obj]

             (clojure.set/subset? (set new-element) (set obj)))

           accepted)

        accepted

        (conj accepted new-element)))

    []

    (sort-by (comp - count) objs)))

 

 (defn palettes [^BufferedImage image]

   (let [palettes (map tile->palette (gb-tiles image))

         unique-palettes (absorb-contract (set palettes))]

     unique-palettes))

 

 (defn tile-pallete

   "find the first appropirate palette for the tile in the

    provided list of palettes."

   [tile palettes]

   (let [tile-colors (set tile)]

     (swank.util/find-first

      #(clojure.set/subset? tile-colors (set %))

      palettes)))

 

 

 (defn image->gb-image

     "Returns the image in a format amenable to the gameboy's

      internal representation.  The format is:

      {:width    --  width of the image

       :height   --  height of the image

       :palettes --  vector of all the palettes the image

                     needs, in proper order

       :tiles    --  vector of all the tiles the image needs,

                     in proper order. A tile is 64 palette

                     indices.

       :data     --  vector of pairs of the format:

                     [tile-index, palette-index]

                     in row-oriented order}"

   [^BufferedImage image]

   (let [image-palettes (palettes image)

         palette-index (zipmap

                        image-palettes

                        (range (count image-palettes)))

         tiles (gb-tiles image)

         unique-tiles (vec (distinct tiles))

         tile-index (zipmap unique-tiles

                            (range (count unique-tiles)))]

     {:width (.getWidth image)

      :height (.getHeight image)

      :palettes image-palettes

      :tiles

      (vec

       (for [tile unique-tiles]

         (let [colors

               (vec (tile-pallete tile image-palettes))

               color-index

               (zipmap colors (range (count colors)))]

           (mapv color-index tile))))

      :data

      (vec 

       (for [tile tiles]

         (let [tile-colors (set (tile->palette tile))]

           [(tile-index tile)

            (palette-index

             (tile-pallete tile image-palettes))])))}))

 

 (defn wait-until-v-blank

   "Modified version of frame-metronome. waits untill LY == 144,

    indicating start of v-blank period."

   []

   (let [timing-loop

         [0x01 ; \

          0x44 ;  | load 0xFF44 into BC

          0xFF ; /  

          0x0A] ;; (BC) -> A, now A = LY (vertical line coord)

         continue-if-144

         [0xFE

          144  ;; compare LY (in A) with 144

          0x20 ;; jump back to beginning if LY != 144 (not-v-blank)

          (->signed-8-bit

           (+ -4 (- (count timing-loop))))]]

     (concat timing-loop continue-if-144)))

 

 (def bg-character-data 0x9000)

 

 (defn gb-tile->bytes

   "Tile is a vector of 64 numbers between 0 and 3 that

    represent a single 8x8 color tile in the GB screen.

    It gets bit-packed into to 16 8-bit numbers in the following

    form:

 

    0-low  1-low  ... 7-low

    0-high 1-high ... 7-high

    .

    .

    .

    55-low  ........ 63-low

    55-high ........ 63-high"

   [tile]

   (let [row->bits

         (fn [row]

           (mapv

            (fn [row*]

              (Integer/parseInt (apply str row*) 2))

            [(map #(bit-and 0x01 %) row)

             (map #(bit-shift-right (bit-and 0x02 %) 1)

                  row)]))]

     (vec

      (flatten

       (map row->bits

            (partition 8 tile))))))

 

 (defn write-data

   "Efficient assembly to write a sequence of values to

    memory, starting at a target address."

   [base-address target-address data]

   (let [len (count data)

         program-length 21] ;; change this if program length

         ;; below changes!

     (flatten

        [0x21 ;; load data address start into HL

         (reverse (disect-bytes-2 (+ base-address program-length)))

 

         0x01 ;; load target address into BC

         (reverse (disect-bytes-2 target-address))

         

         0x11 ;; load len into DE

         (reverse (disect-bytes-2 len))

 

         

         ;; data x-fer loop start

         0x2A ;; (HL) -> A; HL++;

         0x02 ;; A -> (BC);

         0x03 ;; INC BC;

         0x1B ;; DEC DE

 

         0xAF

         0xB2 ;; (OR D E) -> A

         0xB3

 

         

         0x20 ;; if DE is not now 0,

         (->signed-8-bit -9) ;; GOTO start

         

         0xC3

         (reverse

          (disect-bytes-2

           (+ len base-address program-length)))

         data])))

 

 (defn write-image

   "Assume the image data is specified as 360 blocks."

   [base-address target-address image-data]

   

   (let [len (count image-data)

         gen-program

         (fn [program-length]

           (flatten 

            [0x01 ;; load data address start into BC

             (reverse

              (disect-bytes-2 (+ base-address program-length)))

 

             0x21 ;; load target address into HL

             (reverse (disect-bytes-2 target-address))

 

             0x1E ;; total-rows (18) -> E

             18

 

             0x16 ;; total columns (20) -> D

             20

             

             ;; data x-fer loop start

             0x0A ;; (BC) -> A;

             0x03 ;; INC BC;

             0x22 ;; A -> (HL); HL++;

 

 

 

             0x15 ;; dec D 

             0x20

             (->signed-8-bit -6) ;; continue writing row

 

             ;; row is complete, advance to next row

             ;; HL += 12

 

             0xC5 ;; push BC

 

             0x06 ;; 0 -> B

             0

 

             0x0E

             12  ;; 12 -> C

 

             0x09 ;; HL + BC -> HL 

 

             0xC1 ;; pop BC

             

             0x1D ;; dec E

             0x20

             (->signed-8-bit -18) ;; contunue writing image

 

             0xC3

             (reverse

              (disect-bytes-2

               (+ len base-address program-length)))]))]

     (flatten (concat

               (gen-program (count (gen-program 0)))

               image-data))))

 

 (defn test-write-data []

   (let [test-data (concat (range 256)

                           (reverse (range 256)))

         base-address 0xC000

         target-address 0xD000

 

         test-kernel

         (flatten

          [0xF3 ;; disable interrupts

           (write-data (+ 1 base-address)

                       target-address test-data)

           (infinite-loop)])]

     (assert

      (= test-data

         (-> (mid-game)

             tick tick tick

             (set-memory-range base-address test-kernel)

             (PC! base-address)

             (run-moves (repeat 100 []))

             (memory)

             vec

             (subvec target-address

                     (+ target-address

                        (count test-data))))))))

 

 (def LCD-bank-select-address 0xFF4F)

 

 (def BG-1-address 0x9800)

 (def BG-2-address 0x9C00)

 (def character-data-address 0x8000)

 

 (def LCD-control-register 0xFF40)

 (def STAT-register        0xFF41)

 

 (def SCX-register 0xFF42)

 (def SCY-register 0xFF43)

 

 (defn select-LCD-bank [n]

   (assert (or (= n 0) (= n 1)))

   (write-byte LCD-bank-select-address n))

 

 (defn write-image* [_ _ _] [])

 

 (defn display-image-kernel [base-address ^BufferedImage image]

   (let [gb-image (image->gb-image image)

         

         A [(clear-music-registers)

 

            ;; [X] disable LCD protection circuit.

            (write-byte LCD-control-register 0x00)

            ;; now we can write to all video RAM anytime with

            ;; impunity.

            

            ;; [ ] We're only using background palettes; just set the

            ;; minimum required bg palettes for this image, starting

            ;; with palette #0.

 

            (set-palettes bg-palette-select bg-palette-data

                          (:palettes gb-image))

 

            ;; [X] switch to bank 0 to set BG character data.

            (select-LCD-bank 0)

            ;; [X] set SCX and SCY to 0

            (write-byte SCX-register 0)

            (write-byte SCY-register 0)

            ]

         A (flatten A)

 

         B [;; [X] write minimum amount of tiles to BG character

            ;; section

            (write-data

             (+ base-address (count A))

             character-data-address

             (flatten

              (map gb-tile->bytes (:tiles gb-image))))

            (select-LCD-bank 0)]

         B (flatten B)

 

         

         C [;; [X] write image to the screen in terms of tiles

            (write-image

             (+ base-address (+ (count A) (count B)))

             BG-1-address

             (map first (:data gb-image)))

            (select-LCD-bank 1)]

 

         C (flatten C)

 

         D [;; [X] specifiy pallets for each character

            (write-image

             (+ base-address (+ (count A) (count B) (count C)))

             BG-1-address

             (map second (:data gb-image)))

            

 

            ;; [X] reactivate the LCD display

            ;; we're using only BG images, located at

            ;; BG-1 (0x9800), with background character data

            ;; stored starting at 0x8000

 

            (write-byte

             LCD-control-register

             (Integer/parseInt

              (str

               "1"  ;; LCDC on/off

               "0"  ;; Window code area

               "0"  ;; Windowing on?

               "1"  ;; BG tile base (1 = 0x8000)

               "0"  ;; BG-1 or BG-2 ?

               "0"  ;; OBJ-block composition

               "0"  ;; OBJ-on flag 

               "1") ;; no-effect 

              2))

            ]

 

         D (flatten D)]

 

     (concat A B C D)))

 

 (defn display-image [#^BufferedImage image]

   (let [kernel-address 0xB500]

     (-> (tick (tick (tick (mid-game))))

         (set-memory-range

          kernel-address

          (concat (display-image-kernel kernel-address image)

                  (infinite-loop)))

         (PC! kernel-address))))