Mercurial > vba-clojure

annotate clojure/com/aurellem/gb/vbm.clj @ 560:3194a4f438ca

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
restored previous functionality of glyph-display program.
author Robert McIntyre <rlm@mit.edu>
date Fri, 31 Aug 2012 05:00:33 -0500
parents 25b7bb7da3b1
children c8cda378e1a0
rev   line source
rlm@145 1 (ns com.aurellem.gb.vbm
rlm@145 2 (:import java.io.File)
rlm@145 3 (:import org.apache.commons.io.FileUtils)
rlm@145 4 (:use com.aurellem.gb.gb-driver))
rlm@145 5
rlm@145 6 ;;;;;;;;;;;;; read vbm file
rlm@145 7
rlm@145 8 (def ^:dynamic *moves-cache*
rlm@250 9 (File. user-home "proj/vba-clojure/moves/"))
rlm@145 10
rlm@145 11 (defn buttons [mask]
rlm@145 12 (loop [buttons []
rlm@145 13 masks (seq (dissoc button-code :listen))]
rlm@145 14 (if (empty? masks) buttons
rlm@145 15 (let [[button value] (first masks)]
rlm@145 16 (if (not= 0x0000 (bit-and value mask))
rlm@145 17 (recur (conj buttons button) (rest masks))
rlm@145 18 (recur buttons (rest masks)))))))
rlm@145 19
rlm@145 20 (defn vbm-bytes [#^File vbm]
rlm@145 21 (let [bytes (FileUtils/readFileToByteArray vbm)
rlm@145 22 ints (int-array (count bytes))]
rlm@145 23 (areduce bytes idx _ nil
rlm@145 24 (aset ints idx
rlm@145 25 (bit-and 0xFF (aget bytes idx))))
rlm@145 26 ints))
rlm@145 27
rlm@145 28 (def vbm-header-length 255)
rlm@145 29
rlm@145 30 (defn repair-vbm
rlm@145 31 "Two 0's must be inserted after every reset."
rlm@145 32 [vbm-masks]
rlm@145 33 (loop [fixed []
rlm@145 34 pending vbm-masks]
rlm@145 35 (if (empty? pending) fixed
rlm@145 36 (let [mask (first pending)]
rlm@145 37 (if (not= 0x0000 (bit-and mask (button-code :restart)))
rlm@145 38 (recur (conj fixed mask 0x0000 0x0000) (next pending))
rlm@145 39 (recur (conj fixed mask) (next pending)))))))
rlm@145 40
rlm@145 41 (defn vbm-masks [#^File vbm]
rlm@145 42 (repair-vbm
rlm@145 43 (map (fn [[a b]]
rlm@145 44 (+ (bit-shift-left a 8) b))
rlm@145 45 (partition
rlm@145 46 2 (drop vbm-header-length (vbm-bytes vbm))))))
rlm@145 47
rlm@145 48 (defn vbm-buttons [#^File vbm]
rlm@145 49 (map buttons (vbm-masks vbm)))
rlm@145 50
rlm@145 51 (defn convert-buttons
rlm@145 52 "To write a vbm file, we must remove the last two buttons after any
rlm@145 53 reset event."
rlm@145 54 [buttons]
rlm@145 55 (loop [fixed []
rlm@145 56 pending buttons]
rlm@145 57 (if (empty? pending) fixed
rlm@145 58 (let [mask (first pending)]
rlm@336 59 (if (contains? (set (first pending)) :restart)
rlm@145 60 (recur (conj fixed mask) (drop 3 pending))
rlm@145 61 (recur (conj fixed mask) (next pending)))))))
rlm@145 62
rlm@250 63 (defn moves-filename [name]
rlm@250 64 (File. *moves-cache* (format "%s.vbm" name)))
rlm@145 65
rlm@250 66 (defn read-moves [name]
rlm@250 67 (let [target (moves-filename name)]
rlm@145 68 (if (.exists target)
rlm@145 69 (vbm-buttons target))))
rlm@145 70 ;;;;;;;;;;;;;; write moves to vbm file
rlm@145 71
rlm@145 72
rlm@145 73 (def vbm-header
rlm@145 74 (byte-array
rlm@145 75 (map
rlm@145 76 byte
rlm@145 77 [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 78 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 79 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 80 95 95 82 111 98 101 114 116 32 32 77 99 73 110 116 121 114 101 95
rlm@145 81 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95
rlm@145 82 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95
rlm@145 83 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95
rlm@145 84 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95
rlm@145 85 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95
rlm@145 86 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95
rlm@145 87 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95 95
rlm@145 88 95 95 95 95])))
rlm@145 89
rlm@145 90 (def vbm-trailer
rlm@145 91 (byte-array
rlm@145 92 (map byte [0])))
rlm@145 93
rlm@145 94 (defn buttons->vbm-bytes [buttons]
rlm@145 95 (let [bytes-in-ints
rlm@145 96 (map button-mask (convert-buttons buttons))
rlm@145 97 high-bits (map #(bit-shift-right (bit-and 0xFF00 %) 8)
rlm@145 98 bytes-in-ints)
rlm@145 99 low-bits (map #(bit-and 0xFF %) bytes-in-ints)
rlm@145 100 convert-byte (fn [i] (byte (if (>= i 128) (- i 256) i)))
rlm@145 101 contents
rlm@145 102 (byte-array
rlm@145 103 (concat
rlm@145 104 vbm-header
rlm@145 105 (map convert-byte (interleave high-bits low-bits))
rlm@145 106 vbm-trailer))]
rlm@145 107 contents))
rlm@145 108
rlm@250 109 (defn write-moves! [moves name]
rlm@250 110 (let [target (moves-filename name)]
rlm@145 111 (clojure.java.io/copy (buttons->vbm-bytes moves) target)
rlm@145 112 target))
rlm@145 113
rlm@145 114 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@145 115
rlm@145 116 (use 'clojure.java.shell)
rlm@145 117
rlm@145 118 (def vba-linux (File. user-home "bin/vba-linux"))
rlm@145 119
rlm@145 120 (defn play-vbm [#^File vbm]
rlm@145 121 (.delete yellow-save-file)
rlm@145 122 (if (.exists vbm)
rlm@145 123 (sh (.getCanonicalPath vba-linux)
rlm@145 124 (str "--playmovie=" (.getCanonicalPath vbm))
rlm@145 125 (.getCanonicalPath yellow-rom-image)))
rlm@145 126 nil)
rlm@145 127
rlm@335 128 (defn test-moves [moves]
rlm@335 129 (write-moves! moves "temp")
rlm@335 130 (play-vbm (moves-filename "temp")))
rlm@335 131