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