1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/clojure/com/aurellem/gb/mem_util.clj	Sat Mar 31 04:25:49 2012 -0500
     1.3 @@ -0,0 +1,192 @@
     1.4 +(ns com.aurellem.gb.mem-util
     1.5 +  (:use (com.aurellem.gb assembly characters gb-driver))
     1.6 +  (:import [com.aurellem.gb.gb_driver SaveState]))
     1.7 +
     1.8 +
     1.9 +
    1.10 +
    1.11 +  
    1.12 +(def hex-pc (comp hex PC))
    1.13 +
    1.14 +(defn nstep [state n]
    1.15 +  (if (zero? n) state
    1.16 +      (recur (step state) (dec n))))
    1.17 +
    1.18 +
    1.19 +(defn view-memory*
    1.20 +  "View a region of indexable memory in the given state."
    1.21 +  [state start length]
    1.22 +  ((comp vec map)
    1.23 +   #((comp  aget) (memory state) %)
    1.24 +   (range start (+ start length))))
    1.25 +
    1.26 +
    1.27 +(defn pc-trail
    1.28 +  "Track the PC for a number of ticks."
    1.29 +  [state ticks]
    1.30 +  (tick state)
    1.31 +  (set-state! state)
    1.32 +  (loop [pcs [(PC)] ]
    1.33 +    (if (> (count pcs) ticks) pcs
    1.34 +        (do
    1.35 +          (com.aurellem.gb.Gb/tick)
    1.36 +          (recur (conj pcs (PC)))))))
    1.37 +
    1.38 +
    1.39 +(defn get-memory [state n]
    1.40 +  (aget (memory state) n))
    1.41 +
    1.42 +(defn first-change
    1.43 +  "Watch the current memory location as it ticks,
    1.44 +return the first state that differs at location mem." 
    1.45 +  [state n]
    1.46 +  (tick state)
    1.47 +  (set-state! state)
    1.48 +  (let [init (aget (memory state) n)]
    1.49 +    (loop []
    1.50 +      (if (= (aget (memory) n) init)
    1.51 +        (do
    1.52 +          (com.aurellem.gb.Gb/tick)
    1.53 +          (recur))))
    1.54 +    (update-state)))
    1.55 +
    1.56 +
    1.57 +
    1.58 +
    1.59 +
    1.60 +
    1.61 +
    1.62 +(defn differences 
    1.63 +  "Return the differences between the two lists as triples [index
    1.64 +(list-1 index) (list-2 index)]."
    1.65 +[list-1 list-2]
    1.66 +  (remove
    1.67 +   (fn [[a b c]] (= b c))
    1.68 +   (map vector
    1.69 +        (range)
    1.70 +        list-1
    1.71 +        list-2)))
    1.72 +
    1.73 +(defn pc-diff
    1.74 +  "Return the differences between the program counter evolution
    1.75 +between the two states (measured for 10000 ticks)."
    1.76 +  [state-1 state-2]
    1.77 +  (differences (map hex (pc-trail state-1 10000))
    1.78 +               (map hex (pc-trail state-2 10000))))
    1.79 +
    1.80 +
    1.81 +(defn memory-diff [state-1 state-2]
    1.82 +  (remove
    1.83 +  (fn[[a b c]] (= b c))
    1.84 +  (map (comp vec (partial map hex) list)
    1.85 +       (range)
    1.86 +       (vec (memory state-1))
    1.87 +       (vec (memory state-2)))
    1.88 +  ))
    1.89 +
    1.90 +
    1.91 +(defn spell-array
    1.92 +  "Interpret the array as a string of printable Pokemon-text characters."
    1.93 +  [array start n]
    1.94 +  (character-codes->str
    1.95 +          (take n (drop start
    1.96 +                        (vec array)))))
    1.97 +
    1.98 +(defn spell-memory
    1.99 +  "Interpret the indexable memory of the state as a string of printable
   1.100 +Pokemon-text characters. If no state is given, uses current-state."
   1.101 +  ([state mem n]
   1.102 +     (spell-array (memory state) mem n))
   1.103 +  ([mem n] (spell-array @current-state mem n)))
   1.104 +
   1.105 +
   1.106 +(defn sublist
   1.107 +  "Unshifts the list until the sublist is at the start."
   1.108 +  [list sub]
   1.109 +  (cond
   1.110 +    (empty? sub) list
   1.111 +    (empty? list) nil
   1.112 +    (= (take (count sub) list) sub) list
   1.113 +    :else (recur (rest list) sub)))
   1.114 +
   1.115 +(defn find-sublist
   1.116 +  "Returns the position of the first occurence of sublist."
   1.117 +  [list sub]
   1.118 +  (loop [n 0 a list]
   1.119 +    (cond
   1.120 +      (empty? a) nil
   1.121 +      (= (take (count sub) a) sub) n
   1.122 +      :else (recur (inc n) (rest a)))))
   1.123 +
   1.124 +(defn find-sublists
   1.125 +  "Returns a vector of the occurences of sublists."
   1.126 +  [list sub]
   1.127 +  (let [m (find-sublist list sub)]
   1.128 +    (if (nil? m) '()
   1.129 +        (cons m
   1.130 +              (map (partial + (inc m))
   1.131 +                   (find-sublists
   1.132 +                    (drop (inc m) list)
   1.133 +                    sub))))))
   1.134 +
   1.135 +
   1.136 +
   1.137 +(defn search-memory
   1.138 +  "Search for the given codes in memory, returning short snippets of
   1.139 +text around the results."
   1.140 +  ([codes k]
   1.141 +     (search-memory com.aurellem.gb.gb-driver/original-rom codes k))
   1.142 +  ([array codes k]
   1.143 +     (map
   1.144 +      (fn [n]
   1.145 +        [(hex n)
   1.146 +         (take k (drop n rom))])
   1.147 +      
   1.148 +      (find-sublists
   1.149 +       rom
   1.150 +       codes))))
   1.151 +
   1.152 +(defn spelling-bee
   1.153 +  "Search for the given string in ROM, returning short snippets of
   1.154 +  text around the results."
   1.155 +  ([str k]
   1.156 +     (spelling-bee com.aurellem.gb.gb-driver/original-rom str k))
   1.157 +  ([rom str k]
   1.158 +     (map
   1.159 +      (fn [[address snip]]
   1.160 +        [address (character-codes->str snip)])
   1.161 +        (search-memory rom (str->character-codes str) k))))
   1.162 +     
   1.163 +
   1.164 +
   1.165 +
   1.166 +
   1.167 +
   1.168 +(defn rewrite-memory
   1.169 +  "Alter the vector of memory. Treats strings as lists of character
   1.170 +ops."
   1.171 +  ([mem start strs-or-ops]
   1.172 +     (let [x (first strs-or-ops)]
   1.173 +       (cond (empty? strs-or-ops) mem
   1.174 +             (string? x)
   1.175 +             
   1.176 +             (recur mem start
   1.177 +                    (concat
   1.178 +                     (str->character-codes x)
   1.179 +                     (rest strs-or-ops)))
   1.180 +        :else
   1.181 +        (recur
   1.182 +         (assoc mem start x)
   1.183 +         (inc start)
   1.184 +         (rest strs-or-ops))))))
   1.185 +
   1.186 +
   1.187 +(defn rewrite-rom
   1.188 +  "Alter the rom at the given location. Takes a list of
   1.189 +various strings/bytes as data."
   1.190 +  [start strs-or-bytes]
   1.191 +  ((partial rewrite-memory (vec (rom(root))))
   1.192 +   start strs-or-bytes))
   1.193 +
   1.194 +(defn restore-rom! [] (write-rom! original-rom))
   1.195 +