1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/clojure/com/aurellem/gb/vbm.clj	Mon Mar 19 21:23:46 2012 -0500
     1.3 @@ -0,0 +1,127 @@
     1.4 +(ns com.aurellem.gb.vbm
     1.5 +  (:import java.io.File)
     1.6 +  (:import org.apache.commons.io.FileUtils)
     1.7 +  (:use com.aurellem.gb.gb-driver))
     1.8 +
     1.9 +;;;;;;;;;;;;; read vbm file 
    1.10 +
    1.11 +(def ^:dynamic *moves-cache*
    1.12 +     (File. user-home "proj/pokemon-escape/moves/"))
    1.13 +
    1.14 +(defn buttons [mask]
    1.15 +  (loop [buttons []
    1.16 +         masks (seq (dissoc button-code :listen))]
    1.17 +    (if (empty? masks) buttons
    1.18 +        (let [[button value] (first masks)]
    1.19 +          (if (not= 0x0000 (bit-and value mask))
    1.20 +            (recur (conj buttons button) (rest masks))
    1.21 +            (recur buttons (rest masks)))))))
    1.22 +
    1.23 +(defn vbm-bytes [#^File vbm]
    1.24 +  (let [bytes (FileUtils/readFileToByteArray vbm)
    1.25 +        ints (int-array (count bytes))]
    1.26 +    (areduce bytes idx _ nil
    1.27 +             (aset ints idx
    1.28 +                   (bit-and 0xFF (aget bytes idx))))
    1.29 +    ints))
    1.30 +
    1.31 +(def vbm-header-length 255)
    1.32 +
    1.33 +(defn repair-vbm
    1.34 +  "Two 0's must be inserted after every reset."
    1.35 +  [vbm-masks]
    1.36 +  (loop [fixed []
    1.37 +         pending vbm-masks]
    1.38 +    (if (empty? pending) fixed
    1.39 +        (let [mask (first pending)]
    1.40 +          (if (not= 0x0000 (bit-and mask (button-code :restart)))
    1.41 +            (recur (conj fixed mask 0x0000 0x0000) (next pending))
    1.42 +            (recur (conj fixed mask) (next pending)))))))
    1.43 +
    1.44 +(defn vbm-masks [#^File vbm]
    1.45 +  (repair-vbm
    1.46 +   (map (fn [[a b]]
    1.47 +          (+ (bit-shift-left a 8) b))
    1.48 +        (partition
    1.49 +         2 (drop vbm-header-length (vbm-bytes vbm))))))
    1.50 +
    1.51 +(defn vbm-buttons [#^File vbm]
    1.52 +  (map buttons (vbm-masks vbm)))
    1.53 +
    1.54 +(defn convert-buttons
    1.55 +  "To write a vbm file, we must remove the last two buttons after any
    1.56 +   reset event."
    1.57 +  [buttons]
    1.58 +  (loop [fixed []
    1.59 +         pending buttons]
    1.60 +    (if (empty? pending) fixed
    1.61 +        (let [mask (first pending)]
    1.62 +          (if (contains? (set (first pending)) :reset)
    1.63 +            (recur (conj fixed mask) (drop 3 pending))
    1.64 +            (recur (conj fixed mask) (next pending)))))))
    1.65 +
    1.66 +(defn moves->filename [frame]
    1.67 +  (File. *moves-cache* (format "%07d.vbm" frame)))
    1.68 +
    1.69 +(defn read-moves [frame]
    1.70 +  (let [target (moves->filename frame)]
    1.71 +    (if (.exists target)
    1.72 +      (vbm-buttons target))))
    1.73 +;;;;;;;;;;;;;; write moves to vbm file
    1.74 +
    1.75 +
    1.76 +(def vbm-header
    1.77 +  (byte-array
    1.78 +   (map
    1.79 +    byte
    1.80 +    [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
    1.81 +     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
    1.82 +     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
    1.83 +     95 95 82 111 98 101 114 116 32 32 77 99 73 110 116 121 114 101 95
    1.84 +     95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95
    1.85 +     95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95
    1.86 +     95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95
    1.87 +     95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95
    1.88 +     95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95
    1.89 +     95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95
    1.90 +     95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95
    1.91 +     95 95 95 95])))
    1.92 +
    1.93 +(def vbm-trailer
    1.94 +  (byte-array
    1.95 +   (map byte [0])))
    1.96 +
    1.97 +(defn buttons->vbm-bytes [buttons]
    1.98 +  (let [bytes-in-ints
    1.99 +        (map button-mask (convert-buttons buttons))
   1.100 +        high-bits (map #(bit-shift-right (bit-and 0xFF00 %) 8)
   1.101 +                       bytes-in-ints)
   1.102 +        low-bits (map #(bit-and 0xFF %) bytes-in-ints)
   1.103 +        convert-byte (fn [i] (byte (if (>= i 128) (- i 256) i)))
   1.104 +        contents
   1.105 +        (byte-array
   1.106 +         (concat
   1.107 +          vbm-header
   1.108 +          (map convert-byte (interleave high-bits low-bits))
   1.109 +          vbm-trailer))]
   1.110 +    contents))
   1.111 +        
   1.112 +(defn write-moves! [moves]
   1.113 +  (let [target (moves->filename (count moves))]
   1.114 +    (clojure.java.io/copy (buttons->vbm-bytes moves) target)
   1.115 +    target))
   1.116 +
   1.117 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.118 +
   1.119 +(use 'clojure.java.shell)
   1.120 +
   1.121 +(def vba-linux (File. user-home "bin/vba-linux"))
   1.122 +
   1.123 +(defn play-vbm [#^File vbm]
   1.124 +  (.delete yellow-save-file)
   1.125 +  (if (.exists vbm)
   1.126 +    (sh (.getCanonicalPath vba-linux)
   1.127 +        (str "--playmovie=" (.getCanonicalPath vbm))
   1.128 +        (.getCanonicalPath yellow-rom-image)))
   1.129 +  nil)
   1.130 +