Mercurial > cortex

annotate org/worm_learn.clj @ 419:dd40244255d4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
implemented phi-space threading... almost done!
author Robert McIntyre <rlm@mit.edu>
date Thu, 20 Mar 2014 20:54:37 -0400
parents 027707c75f39
children 7f3581dc58ff
rev   line source
rlm@394 1 (ns org.aurellem.worm-learn
rlm@394 2 "General worm creation framework."
rlm@394 3 {:author "Robert McIntyre"}
rlm@394 4 (:use (cortex world util import body sense
rlm@408 5 hearing touch vision proprioception movement
rlm@408 6 test))
rlm@394 7 (:import (com.jme3.math ColorRGBA Vector3f))
rlm@394 8 (:import java.io.File)
rlm@394 9 (:import com.jme3.audio.AudioNode)
rlm@397 10 (:import com.aurellem.capture.RatchetTimer)
rlm@397 11 (:import (com.aurellem.capture Capture IsoTimer))
rlm@397 12 (:import (com.jme3.math Vector3f ColorRGBA)))
rlm@406 13
rlm@413 14 (import org.apache.commons.math3.transform.TransformType)
rlm@413 15 (import org.apache.commons.math3.transform.FastFourierTransformer)
rlm@413 16 (import org.apache.commons.math3.transform.DftNormalization)
rlm@413 17
rlm@406 18 (use 'clojure.pprint)
rlm@408 19 (use 'clojure.set)
rlm@394 20 (dorun (cortex.import/mega-import-jme3))
rlm@394 21 (rlm.rlm-commands/help)
rlm@394 22
rlm@400 23 (load-bullet)
rlm@394 24
rlm@399 25 (def hand "Models/test-creature/hand.blend")
rlm@394 26
rlm@399 27 (defn worm-model []
rlm@399 28 (load-blender-model "Models/worm/worm.blend"))
rlm@394 29
rlm@400 30 (def output-base (File. "/home/r/proj/cortex/render/worm-learn/curl"))
rlm@394 31
rlm@397 32
rlm@399 33 (defn motor-control-program
rlm@399 34 "Create a function which will execute the motor script"
rlm@406 35 [muscle-labels
rlm@399 36 script]
rlm@399 37 (let [current-frame (atom -1)
rlm@399 38 keyed-script (group-by first script)
rlm@399 39 current-forces (atom {}) ]
rlm@399 40 (fn [effectors]
rlm@399 41 (let [indexed-effectors (vec effectors)]
rlm@399 42 (dorun
rlm@399 43 (for [[_ part force] (keyed-script (swap! current-frame inc))]
rlm@399 44 (swap! current-forces (fn [m] (assoc m part force)))))
rlm@399 45 (doall (map (fn [effector power]
rlm@399 46 (effector (int power)))
rlm@399 47 effectors
rlm@406 48 (map #(@current-forces % 0) muscle-labels)))))))
rlm@397 49
rlm@404 50 (defn worm-direct-control
rlm@404 51 "Create keybindings and a muscle control program that will enable
rlm@404 52 the user to control the worm via the keyboard."
rlm@404 53 [muscle-labels activation-strength]
rlm@404 54 (let [strengths (mapv (fn [_] (atom 0)) muscle-labels)
rlm@404 55 activator
rlm@404 56 (fn [n]
rlm@404 57 (fn [world pressed?]
rlm@404 58 (let [strength (if pressed? activation-strength 0)]
rlm@404 59 (swap! (nth strengths n) (constantly strength)))))
rlm@404 60 activators
rlm@404 61 (map activator (range (count muscle-labels)))
rlm@404 62 worm-keys
rlm@404 63 ["key-f" "key-r"
rlm@404 64 "key-g" "key-t"
rlm@413 65 "key-h" "key-y"
rlm@404 66 "key-j" "key-u"
rlm@413 67 "key-k" "key-i"
rlm@413 68 "key-l" "key-o"]]
rlm@404 69 {:motor-control
rlm@404 70 (fn [effectors]
rlm@404 71 (doall
rlm@404 72 (map (fn [strength effector]
rlm@404 73 (effector (deref strength)))
rlm@404 74 strengths effectors)))
rlm@404 75 :keybindings
rlm@404 76 ;; assume muscles are listed in pairs and map them to keys.
rlm@404 77 (zipmap worm-keys activators)}))
rlm@400 78
rlm@400 79 ;; These are scripts that direct the worm to move in two radically
rlm@400 80 ;; different patterns -- a sinusoidal wiggling motion, and a curling
rlm@400 81 ;; motions that causes the worm to form a circle.
rlm@400 82
rlm@400 83 (def curl-script
rlm@415 84 [[150 :d-flex 40]
rlm@415 85 [250 :d-flex 0]])
rlm@400 86
rlm@400 87 (def period 18)
rlm@400 88
rlm@404 89 (def worm-muscle-labels
rlm@414 90 [:base-ex :base-flex
rlm@414 91 :a-ex :a-flex
rlm@414 92 :b-ex :b-flex
rlm@414 93 :c-ex :c-flex
rlm@414 94 :d-ex :d-flex])
rlm@399 95
rlm@399 96 (defn gen-wiggle [[flexor extensor :as muscle-pair] time-base]
rlm@399 97 (let [period period
rlm@399 98 power 45]
rlm@399 99 [[time-base flexor power]
rlm@399 100 [(+ time-base period) flexor 0]
rlm@399 101 [(+ time-base period 1) extensor power]
rlm@399 102 [(+ time-base (+ (* 2 period) 2)) extensor 0]]))
rlm@399 103
rlm@399 104 (def wiggle-script
rlm@414 105 (mapcat gen-wiggle (repeat 4000 [:a-ex :a-flex])
rlm@406 106 (range 100 1000000 (+ 3 (* period 2)))))
rlm@399 107
rlm@399 108
rlm@415 109 (defn shift-script [shift script]
rlm@415 110 (map (fn [[time label power]] [(+ time shift) label power])
rlm@415 111 script))
rlm@415 112
rlm@415 113 (def do-all-the-things
rlm@415 114 (concat
rlm@415 115 curl-script
rlm@415 116 [[300 :d-ex 40]
rlm@415 117 [320 :d-ex 0]]
rlm@415 118 (shift-script 280 (take 16 wiggle-script))))
rlm@415 119
rlm@400 120 ;; Normally, we'd use unsupervised/supervised machine learning to pick
rlm@400 121 ;; out the defining features of the different actions available to the
rlm@400 122 ;; worm. For this project, I am going to explicitely define functions
rlm@400 123 ;; that recognize curling and wiggling respectively. These functions
rlm@400 124 ;; are defined using all the information available from an embodied
rlm@400 125 ;; simulation of the action. Note how much easier they are to define
rlm@400 126 ;; than if I only had vision to work with. Things like scale/position
rlm@400 127 ;; invariance are complete non-issues here. This is the advantage of
rlm@400 128 ;; body-centered action recognition and what I hope to show with this
rlm@400 129 ;; thesis.
rlm@400 130
rlm@405 131
rlm@415 132 ;; curled? relies on proprioception, resting? relies on touch,
rlm@415 133 ;; wiggling? relies on a fourier analysis of muscle contraction, and
rlm@415 134 ;; grand-circle? relies on touch and reuses curled? as a gaurd.
rlm@405 135
rlm@405 136 (defn curled?
rlm@405 137 "Is the worm curled up?"
rlm@405 138 [experiences]
rlm@405 139 (every?
rlm@405 140 (fn [[_ _ bend]]
rlm@405 141 (> (Math/sin bend) 0.64))
rlm@405 142 (:proprioception (peek experiences))))
rlm@405 143
rlm@406 144 (defn touch-average [[coords touch]]
rlm@406 145 (/ (average (map first touch)) (average (map second touch))))
rlm@406 146
rlm@411 147 (defn rect-region [[x0 y0] [x1 y1]]
rlm@411 148 (vec
rlm@411 149 (for [x (range x0 (inc x1))
rlm@411 150 y (range y0 (inc y1))]
rlm@411 151 [x y])))
rlm@407 152
rlm@415 153 (def worm-segment-bottom (rect-region [8 15] [14 22]))
rlm@407 154
rlm@411 155 (defn contact
rlm@411 156 "Determine how much contact a particular worm segment has with
rlm@411 157 other objects. Returns a value between 0 and 1, where 1 is full
rlm@411 158 contact and 0 is no contact."
rlm@415 159 [touch-region [coords contact :as touch]]
rlm@411 160 (-> (zipmap coords contact)
rlm@415 161 (select-keys touch-region)
rlm@411 162 (vals)
rlm@411 163 (#(map first %))
rlm@411 164 (average)
rlm@411 165 (* 10)
rlm@411 166 (- 1)
rlm@411 167 (Math/abs)))
rlm@406 168
rlm@415 169 (defn resting?
rlm@415 170 "Is the worm straight?"
rlm@415 171 [experiences]
rlm@415 172 (every?
rlm@415 173 (fn [touch-data]
rlm@415 174 (< 0.9 (contact worm-segment-bottom touch-data)))
rlm@415 175 (:touch (peek experiences))))
rlm@415 176
rlm@415 177 (defn vector:last-n [v n]
rlm@415 178 (let [c (count v)]
rlm@415 179 (if (< c n) v
rlm@415 180 (subvec v (- c n) c))))
rlm@415 181
rlm@413 182 (defn fft [nums]
rlm@414 183 (map
rlm@414 184 #(.getReal %)
rlm@414 185 (.transform
rlm@414 186 (FastFourierTransformer. DftNormalization/STANDARD)
rlm@414 187 (double-array nums) TransformType/FORWARD)))
rlm@413 188
rlm@413 189 (def indexed (partial map-indexed vector))
rlm@413 190
rlm@414 191 (defn max-indexed [s]
rlm@414 192 (first (sort-by (comp - second) (indexed s))))
rlm@414 193
rlm@400 194 (defn wiggling?
rlm@405 195 "Is the worm wiggling?"
rlm@405 196 [experiences]
rlm@414 197 (let [analysis-interval 0x40]
rlm@414 198 (when (> (count experiences) analysis-interval)
rlm@414 199 (let [a-flex 3
rlm@414 200 a-ex 2
rlm@414 201 muscle-activity
rlm@414 202 (map :muscle (vector:last-n experiences analysis-interval))
rlm@414 203 base-activity
rlm@414 204 (map #(- (% a-flex) (% a-ex)) muscle-activity)]
rlm@414 205 (= 2
rlm@414 206 (first
rlm@415 207 (max-indexed
rlm@415 208 (map #(Math/abs %)
rlm@415 209 (take 20 (fft base-activity))))))))))
rlm@414 210
rlm@415 211 (def worm-segment-bottom-tip (rect-region [15 15] [22 22]))
rlm@414 212
rlm@415 213 (def worm-segment-top-tip (rect-region [0 15] [7 22]))
rlm@414 214
rlm@415 215 (defn grand-circle?
rlm@415 216 "Does the worm form a majestic circle (one end touching the other)?"
rlm@415 217 [experiences]
rlm@415 218 (and true;; (curled? experiences)
rlm@415 219 (let [worm-touch (:touch (peek experiences))
rlm@415 220 tail-touch (worm-touch 0)
rlm@415 221 head-touch (worm-touch 4)]
rlm@415 222 (and (< 0.55 (contact worm-segment-bottom-tip tail-touch))
rlm@415 223 (< 0.55 (contact worm-segment-top-tip head-touch))))))
rlm@400 224
rlm@418 225
rlm@418 226 (declare phi-space phi-scan)
rlm@418 227
rlm@418 228 (defn next-phi-states
rlm@418 229 "Given proprioception data, determine the most likely next sensory
rlm@418 230 pattern from previous experience."
rlm@418 231 [proprio phi-space phi-scan]
rlm@418 232 (if-let [results (phi-scan proprio)]
rlm@418 233 (mapv phi-space
rlm@418 234 (filter (partial > (count phi-space))
rlm@418 235 (map inc results)))))
rlm@418 236
rlm@418 237 (defn debug-experience
rlm@418 238 [experiences]
rlm@418 239 (cond
rlm@418 240 (grand-circle? experiences) (println "Grand Circle")
rlm@418 241 (curled? experiences) (println "Curled")
rlm@418 242 (wiggling? experiences) (println "Wiggling")
rlm@418 243 (resting? experiences) (println "Resting")))
rlm@418 244
rlm@418 245
rlm@400 246 (def standard-world-view
rlm@400 247 [(Vector3f. 4.207176, -3.7366982, 3.0816958)
rlm@400 248 (Quaternion. 0.11118768, 0.87678415, 0.24434438, -0.3989771)])
rlm@400 249
rlm@400 250 (def worm-side-view
rlm@400 251 [(Vector3f. 4.207176, -3.7366982, 3.0816958)
rlm@400 252 (Quaternion. -0.11555642, 0.88188726, -0.2854942, -0.3569518)])
rlm@400 253
rlm@400 254 (def degenerate-worm-view
rlm@400 255 [(Vector3f. -0.0708936, -8.570261, 2.6487997)
rlm@400 256 (Quaternion. -2.318909E-4, 0.9985348, 0.053941682, 0.004291452)])
rlm@399 257
rlm@404 258 (defn worm-world-defaults []
rlm@404 259 (let [direct-control (worm-direct-control worm-muscle-labels 40)]
rlm@404 260 {:view worm-side-view
rlm@404 261 :motor-control (:motor-control direct-control)
rlm@404 262 :keybindings (:keybindings direct-control)
rlm@405 263 :record nil
rlm@418 264 :experiences (atom [])
rlm@418 265 :experience-watch debug-experience
rlm@407 266 :worm-model worm-model
rlm@407 267 :end-frame nil}))
rlm@407 268
rlm@404 269 (defn dir! [file]
rlm@410 270 (if-not (.exists file)
rlm@404 271 (.mkdir file))
rlm@404 272 file)
rlm@405 273
rlm@405 274 (defn record-experience! [experiences data]
rlm@405 275 (swap! experiences #(conj % data)))
rlm@405 276
rlm@399 277 (defn worm-world
rlm@407 278 [& {:keys [record motor-control keybindings view experiences
rlm@418 279 worm-model end-frame experience-watch] :as settings}]
rlm@407 280 (let [{:keys [record motor-control keybindings view experiences
rlm@418 281 worm-model end-frame experience-watch]}
rlm@404 282 (merge (worm-world-defaults) settings)
rlm@404 283 worm (doto (worm-model) (body!))
rlm@404 284 touch (touch! worm)
rlm@404 285 prop (proprioception! worm)
rlm@404 286 muscles (movement! worm)
rlm@404 287
rlm@404 288 touch-display (view-touch)
rlm@404 289 prop-display (view-proprioception)
rlm@404 290 muscle-display (view-movement)
rlm@404 291
rlm@404 292 floor (box 10 1 10 :position (Vector3f. 0 -10 0)
rlm@407 293 :color ColorRGBA/Gray :mass 0)
rlm@407 294 timer (IsoTimer. 60)]
rlm@399 295
rlm@404 296 (world
rlm@404 297 (nodify [worm floor])
rlm@404 298 (merge standard-debug-controls keybindings)
rlm@404 299 (fn [world]
rlm@404 300 (position-camera world view)
rlm@407 301 (.setTimer world timer)
rlm@407 302 (display-dilated-time world timer)
rlm@404 303 (if record
rlm@404 304 (Capture/captureVideo
rlm@404 305 world
rlm@404 306 (dir! (File. record "main-view"))))
rlm@404 307 (speed-up world)
rlm@404 308 (light-up-everything world))
rlm@404 309 (fn [world tpf]
rlm@410 310 (if (and end-frame (> (.getTime timer) end-frame))
rlm@407 311 (.stop world))
rlm@414 312 (let [muscle-data (vec (motor-control muscles))
rlm@405 313 proprioception-data (prop)
rlm@415 314 touch-data (mapv #(% (.getRootNode world)) touch)]
rlm@405 315 (when experiences
rlm@405 316 (record-experience!
rlm@405 317 experiences {:touch touch-data
rlm@405 318 :proprioception proprioception-data
rlm@418 319 :muscle muscle-data}))
rlm@418 320 (when experience-watch
rlm@418 321 (experience-watch @experiences))
rlm@404 322 (muscle-display
rlm@405 323 muscle-data
rlm@405 324 (if record (dir! (File. record "muscle"))))
rlm@405 325 (prop-display
rlm@405 326 proprioception-data
rlm@405 327 (if record (dir! (File. record "proprio"))))
rlm@405 328 (touch-display
rlm@405 329 touch-data
rlm@405 330 (if record (dir! (File. record "touch")))))))))
rlm@407 331
rlm@407 332
rlm@407 333
rlm@416 334 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@416 335 ;;;;;;;; Phi-Space ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@416 336 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@416 337
rlm@416 338 (defn generate-phi-space []
rlm@416 339 (let [experiences (atom [])]
rlm@416 340 (run-world
rlm@416 341 (apply-map
rlm@416 342 worm-world
rlm@416 343 (merge
rlm@416 344 (worm-world-defaults)
rlm@416 345 {:end-frame 700
rlm@416 346 :motor-control
rlm@416 347 (motor-control-program worm-muscle-labels do-all-the-things)
rlm@416 348 :experiences experiences})))
rlm@416 349 @experiences))
rlm@416 350
rlm@416 351 (defn bin [digits]
rlm@416 352 (fn [angles]
rlm@416 353 (->> angles
rlm@416 354 (flatten)
rlm@416 355 (map (juxt #(Math/sin %) #(Math/cos %)))
rlm@416 356 (flatten)
rlm@416 357 (mapv #(Math/round (* % (Math/pow 10 (dec digits))))))))
rlm@416 358
rlm@418 359 ;; k-nearest neighbors with spatial binning. Only returns a result if
rlm@418 360 ;; the propriceptive data is within 10% of a previously recorded
rlm@418 361 ;; result in all dimensions.
rlm@416 362 (defn gen-phi-scan [phi-space]
rlm@416 363 (let [bin-keys (map bin [3 2 1])
rlm@416 364 bin-maps
rlm@417 365 (map (fn [bin-key]
rlm@417 366 (group-by
rlm@417 367 (comp bin-key :proprioception phi-space)
rlm@417 368 (range (count phi-space)))) bin-keys)
rlm@416 369 lookups (map (fn [bin-key bin-map]
rlm@416 370 (fn [proprio] (bin-map (bin-key proprio))))
rlm@416 371 bin-keys bin-maps)]
rlm@416 372 (fn lookup [proprio-data]
rlm@419 373 (set (some #(% proprio-data) lookups)))))
rlm@419 374
rlm@419 375
rlm@419 376 (defn longest-thread
rlm@419 377 "Find the longest thread from phi-index-sets. The index sets should
rlm@419 378 be ordered from most recent to least recent."
rlm@419 379 [phi-index-sets]
rlm@419 380 (loop [result '()
rlm@419 381 [thread-bases & remaining :as phi-index-sets] phi-index-sets]
rlm@419 382 (if (empty? phi-index-sets)
rlm@419 383 result
rlm@419 384 (let [threads
rlm@419 385 (for [thread-base thread-bases]
rlm@419 386 (loop [thread (list thread-base)
rlm@419 387 remaining remaining]
rlm@419 388 (let [next-index (dec (first thread))]
rlm@419 389 (cond (empty? remaining) thread
rlm@419 390 (contains? (first remaining) next-index)
rlm@419 391 (recur
rlm@419 392 (cons next-index thread) (rest remaining))
rlm@419 393 :else thread))))
rlm@419 394 longest-thread
rlm@419 395 (reduce (fn [thread-a thread-b]
rlm@419 396 (if (> (count thread-a) (count thread-b))
rlm@419 397 thread-a thread-b))
rlm@419 398 '(nil)
rlm@419 399 threads)]
rlm@419 400 (recur (concat longest-thread result)
rlm@419 401 (drop (count longest-thread) phi-index-sets))))))
rlm@419 402
rlm@416 403
rlm@416 404 (defn init []
rlm@416 405 (def phi-space (generate-phi-space))
rlm@416 406 (def phi-scan (gen-phi-scan phi-space))
rlm@416 407 )
rlm@418 408
rlm@419 409
rlm@419 410 (def ppp (atom ()))
rlm@419 411
rlm@419 412 (defn debug-experience-phi [experiences]
rlm@419 413 (let [phi-indices (phi-scan (:proprioception (peek experiences)))]
rlm@419 414 (swap! ppp (partial cons phi-indices))
rlm@419 415 (println-repl phi-indices))
rlm@419 416 (cond
rlm@419 417 (grand-circle? experiences) (println "Grand Circle")
rlm@419 418 (curled? experiences) (println "Curled")
rlm@419 419 (wiggling? experiences) (println "Wiggling")
rlm@419 420 (resting? experiences) (println "Resting"))
rlm@419 421 )