rlm@145: (ns com.aurellem.gb.vbm
rlm@145:   (:import java.io.File)
rlm@145:   (:import org.apache.commons.io.FileUtils)
rlm@145:   (:use com.aurellem.gb.gb-driver))
rlm@145: 
rlm@145: ;;;;;;;;;;;;; read vbm file 
rlm@145: 
rlm@145: (def ^:dynamic *moves-cache*
rlm@250:      (File. user-home "proj/vba-clojure/moves/"))
rlm@145: 
rlm@145: (defn buttons [mask]
rlm@145:   (loop [buttons []
rlm@145:          masks (seq (dissoc button-code :listen))]
rlm@145:     (if (empty? masks) buttons
rlm@145:         (let [[button value] (first masks)]
rlm@145:           (if (not= 0x0000 (bit-and value mask))
rlm@145:             (recur (conj buttons button) (rest masks))
rlm@145:             (recur buttons (rest masks)))))))
rlm@145: 
rlm@145: (defn vbm-bytes [#^File vbm]
rlm@145:   (let [bytes (FileUtils/readFileToByteArray vbm)
rlm@145:         ints (int-array (count bytes))]
rlm@145:     (areduce bytes idx _ nil
rlm@145:              (aset ints idx
rlm@145:                    (bit-and 0xFF (aget bytes idx))))
rlm@145:     ints))
rlm@145: 
rlm@145: (def vbm-header-length 255)
rlm@145: 
rlm@145: (defn repair-vbm
rlm@145:   "Two 0's must be inserted after every reset."
rlm@145:   [vbm-masks]
rlm@145:   (loop [fixed []
rlm@145:          pending vbm-masks]
rlm@145:     (if (empty? pending) fixed
rlm@145:         (let [mask (first pending)]
rlm@145:           (if (not= 0x0000 (bit-and mask (button-code :restart)))
rlm@145:             (recur (conj fixed mask 0x0000 0x0000) (next pending))
rlm@145:             (recur (conj fixed mask) (next pending)))))))
rlm@145: 
rlm@145: (defn vbm-masks [#^File vbm]
rlm@145:   (repair-vbm
rlm@145:    (map (fn [[a b]]
rlm@145:           (+ (bit-shift-left a 8) b))
rlm@145:         (partition
rlm@145:          2 (drop vbm-header-length (vbm-bytes vbm))))))
rlm@145: 
rlm@145: (defn vbm-buttons [#^File vbm]
rlm@145:   (map buttons (vbm-masks vbm)))
rlm@145: 
rlm@145: (defn convert-buttons
rlm@145:   "To write a vbm file, we must remove the last two buttons after any
rlm@145:    reset event."
rlm@145:   [buttons]
rlm@145:   (loop [fixed []
rlm@145:          pending buttons]
rlm@145:     (if (empty? pending) fixed
rlm@145:         (let [mask (first pending)]
rlm@336:           (if (contains? (set (first pending)) :restart)
rlm@145:             (recur (conj fixed mask) (drop 3 pending))
rlm@145:             (recur (conj fixed mask) (next pending)))))))
rlm@145: 
rlm@250: (defn moves-filename [name]
rlm@250:   (File. *moves-cache* (format "%s.vbm" name)))
rlm@145: 
rlm@250: (defn read-moves [name]
rlm@250:   (let [target (moves-filename name)]
rlm@145:     (if (.exists target)
rlm@145:       (vbm-buttons target))))
rlm@145: ;;;;;;;;;;;;;; write moves to vbm file
rlm@145: 
rlm@145: 
rlm@145: (def vbm-header
rlm@145:   (byte-array
rlm@145:    (map
rlm@145:     byte
rlm@145:     [86 66 77 26 1 0 0 0 105 74 88 79 89 1 0 0 0 0 0 0 0 1 2 112 0 0 0
rlm@145:      0 0 0 0 0 1 0 0 0 80 79 75 69 77 79 78 32 89 69 76 76 1 -105 124 4
rlm@145:      3 0 0 0 0 0 0 0 0 1 0 0 95 95 95 95 95 95 95 95 95 95 95 95 95 95
rlm@145:      95 95 82 111 98 101 114 116 32 32 77 99 73 110 116 121 114 101 95
rlm@145:      95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95
rlm@145:      95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95
rlm@145:      95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95
rlm@145:      95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95
rlm@145:      95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95
rlm@145:      95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95
rlm@145:      95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95
rlm@145:      95 95 95 95])))
rlm@145: 
rlm@145: (def vbm-trailer
rlm@145:   (byte-array
rlm@145:    (map byte [0])))
rlm@145: 
rlm@145: (defn buttons->vbm-bytes [buttons]
rlm@145:   (let [bytes-in-ints
rlm@145:         (map button-mask (convert-buttons buttons))
rlm@145:         high-bits (map #(bit-shift-right (bit-and 0xFF00 %) 8)
rlm@145:                        bytes-in-ints)
rlm@145:         low-bits (map #(bit-and 0xFF %) bytes-in-ints)
rlm@145:         convert-byte (fn [i] (byte (if (>= i 128) (- i 256) i)))
rlm@145:         contents
rlm@145:         (byte-array
rlm@145:          (concat
rlm@145:           vbm-header
rlm@145:           (map convert-byte (interleave high-bits low-bits))
rlm@145:           vbm-trailer))]
rlm@145:     contents))
rlm@145:         
rlm@250: (defn write-moves! [moves name]
rlm@250:   (let [target (moves-filename name)]
rlm@145:     (clojure.java.io/copy (buttons->vbm-bytes moves) target)
rlm@145:     target))
rlm@145: 
rlm@604: (defn write-moves-to-file! [moves file]
rlm@604:   (clojure.java.io/copy (buttons->vbm-bytes moves) file))
rlm@604: 
rlm@145: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@145: 
rlm@145: (use 'clojure.java.shell)
rlm@145: 
rlm@145: (def vba-linux (File. user-home "bin/vba-linux"))
rlm@145: 
rlm@145: (defn play-vbm [#^File vbm]
rlm@145:   (.delete yellow-save-file)
rlm@145:   (if (.exists vbm)
rlm@145:     (sh (.getCanonicalPath vba-linux)
rlm@145:         (str "--playmovie=" (.getCanonicalPath vbm))
rlm@145:         (.getCanonicalPath yellow-rom-image)))
rlm@145:   nil)
rlm@145: 
rlm@335: (defn test-moves [moves]
rlm@335:   (write-moves! moves "temp")
rlm@335:   (play-vbm (moves-filename "temp")))
rlm@335: