Mercurial > cortex
diff org/worm_learn.clj @ 460:763d13f77e03
merge in laptop changes.
author | Robert McIntyre <rlm@mit.edu> |
---|---|
date | Thu, 27 Mar 2014 17:57:01 -0400 |
parents | 0a4362d1f138 |
children | ced955c3c84f |
line wrap: on
line diff
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000 1.2 +++ b/org/worm_learn.clj Thu Mar 27 17:57:01 2014 -0400 1.3 @@ -0,0 +1,562 @@ 1.4 +(ns org.aurellem.worm-learn 1.5 + "General worm creation framework." 1.6 + {:author "Robert McIntyre"} 1.7 + (:use (cortex world util import body sense 1.8 + hearing touch vision proprioception movement 1.9 + test)) 1.10 + (:import (com.jme3.math ColorRGBA Vector3f)) 1.11 + (:import java.io.File) 1.12 + (:import com.jme3.audio.AudioNode) 1.13 + (:import com.aurellem.capture.RatchetTimer) 1.14 + (:import (com.aurellem.capture Capture IsoTimer)) 1.15 + (:import (com.jme3.math Vector3f ColorRGBA))) 1.16 + 1.17 +(import org.apache.commons.math3.transform.TransformType) 1.18 +(import org.apache.commons.math3.transform.FastFourierTransformer) 1.19 +(import org.apache.commons.math3.transform.DftNormalization) 1.20 + 1.21 +(use 'clojure.pprint) 1.22 +(use 'clojure.set) 1.23 +(dorun (cortex.import/mega-import-jme3)) 1.24 +(rlm.rlm-commands/help) 1.25 + 1.26 +(load-bullet) 1.27 + 1.28 +(def hand "Models/test-creature/hand.blend") 1.29 + 1.30 +(defn worm-model [] 1.31 + (load-blender-model "Models/worm/worm.blend")) 1.32 + 1.33 +(defn worm [] 1.34 + (let [model (load-blender-model "Models/worm/worm.blend")] 1.35 + {:body (doto model (body!)) 1.36 + :touch (touch! model) 1.37 + :proprioception (proprioception! model) 1.38 + :muscles (movement! model)})) 1.39 + 1.40 +(defn worm* [] 1.41 + (let [model (load-blender-model "Models/worm/worm-of-the-imagination.blend")] 1.42 + {:body (doto model (body!)) 1.43 + :touch (touch! model) 1.44 + :proprioception (proprioception! model) 1.45 + :muscles (movement! model)})) 1.46 + 1.47 + 1.48 +(def output-base (File. "/home/r/proj/cortex/render/worm-learn/curl")) 1.49 + 1.50 + 1.51 +(defn motor-control-program 1.52 + "Create a function which will execute the motor script" 1.53 + [muscle-labels 1.54 + script] 1.55 + (let [current-frame (atom -1) 1.56 + keyed-script (group-by first script) 1.57 + current-forces (atom {}) ] 1.58 + (fn [effectors] 1.59 + (let [indexed-effectors (vec effectors)] 1.60 + (dorun 1.61 + (for [[_ part force] (keyed-script (swap! current-frame inc))] 1.62 + (swap! current-forces (fn [m] (assoc m part force))))) 1.63 + (doall (map (fn [effector power] 1.64 + (effector (int power))) 1.65 + effectors 1.66 + (map #(@current-forces % 0) muscle-labels))))))) 1.67 + 1.68 +(defn worm-direct-control 1.69 + "Create keybindings and a muscle control program that will enable 1.70 + the user to control the worm via the keyboard." 1.71 + [muscle-labels activation-strength] 1.72 + (let [strengths (mapv (fn [_] (atom 0)) muscle-labels) 1.73 + activator 1.74 + (fn [n] 1.75 + (fn [world pressed?] 1.76 + (let [strength (if pressed? activation-strength 0)] 1.77 + (swap! (nth strengths n) (constantly strength))))) 1.78 + activators 1.79 + (map activator (range (count muscle-labels))) 1.80 + worm-keys 1.81 + ["key-f" "key-r" 1.82 + "key-g" "key-t" 1.83 + "key-h" "key-y" 1.84 + "key-j" "key-u" 1.85 + "key-k" "key-i" 1.86 + "key-l" "key-o"]] 1.87 + {:motor-control 1.88 + (fn [effectors] 1.89 + (doall 1.90 + (map (fn [strength effector] 1.91 + (effector (deref strength))) 1.92 + strengths effectors))) 1.93 + :keybindings 1.94 + ;; assume muscles are listed in pairs and map them to keys. 1.95 + (zipmap worm-keys activators)})) 1.96 + 1.97 +;; These are scripts that direct the worm to move in two radically 1.98 +;; different patterns -- a sinusoidal wiggling motion, and a curling 1.99 +;; motions that causes the worm to form a circle. 1.100 + 1.101 +(def curl-script 1.102 + [[150 :d-flex 40] 1.103 + [250 :d-flex 0]]) 1.104 + 1.105 +(def period 18) 1.106 + 1.107 +(def worm-muscle-labels 1.108 + [:base-ex :base-flex 1.109 + :a-ex :a-flex 1.110 + :b-ex :b-flex 1.111 + :c-ex :c-flex 1.112 + :d-ex :d-flex]) 1.113 + 1.114 +(defn gen-wiggle [[flexor extensor :as muscle-pair] time-base] 1.115 + (let [period period 1.116 + power 45] 1.117 + [[time-base flexor power] 1.118 + [(+ time-base period) flexor 0] 1.119 + [(+ time-base period 1) extensor power] 1.120 + [(+ time-base (+ (* 2 period) 2)) extensor 0]])) 1.121 + 1.122 +(def wiggle-script 1.123 + (mapcat gen-wiggle (repeat 4000 [:a-ex :a-flex]) 1.124 + (range 100 1000000 (+ 3 (* period 2))))) 1.125 + 1.126 + 1.127 +(defn shift-script [shift script] 1.128 + (map (fn [[time label power]] [(+ time shift) label power]) 1.129 + script)) 1.130 + 1.131 +(def do-all-the-things 1.132 + (concat 1.133 + curl-script 1.134 + [[300 :d-ex 40] 1.135 + [320 :d-ex 0]] 1.136 + (shift-script 280 (take 16 wiggle-script)))) 1.137 + 1.138 +;; Normally, we'd use unsupervised/supervised machine learning to pick 1.139 +;; out the defining features of the different actions available to the 1.140 +;; worm. For this project, I am going to explicitely define functions 1.141 +;; that recognize curling and wiggling respectively. These functions 1.142 +;; are defined using all the information available from an embodied 1.143 +;; simulation of the action. Note how much easier they are to define 1.144 +;; than if I only had vision to work with. Things like scale/position 1.145 +;; invariance are complete non-issues here. This is the advantage of 1.146 +;; body-centered action recognition and what I hope to show with this 1.147 +;; thesis. 1.148 + 1.149 + 1.150 +;; curled? relies on proprioception, resting? relies on touch, 1.151 +;; wiggling? relies on a fourier analysis of muscle contraction, and 1.152 +;; grand-circle? relies on touch and reuses curled? as a gaurd. 1.153 + 1.154 +(defn curled? 1.155 + "Is the worm curled up?" 1.156 + [experiences] 1.157 + (every? 1.158 + (fn [[_ _ bend]] 1.159 + (> (Math/sin bend) 0.64)) 1.160 + (:proprioception (peek experiences)))) 1.161 + 1.162 +(defn rect-region [[x0 y0] [x1 y1]] 1.163 + (vec 1.164 + (for [x (range x0 (inc x1)) 1.165 + y (range y0 (inc y1))] 1.166 + [x y]))) 1.167 + 1.168 +(def worm-segment-bottom (rect-region [8 15] [14 22])) 1.169 + 1.170 +(defn contact 1.171 + "Determine how much contact a particular worm segment has with 1.172 + other objects. Returns a value between 0 and 1, where 1 is full 1.173 + contact and 0 is no contact." 1.174 + [touch-region [coords contact :as touch]] 1.175 + (-> (zipmap coords contact) 1.176 + (select-keys touch-region) 1.177 + (vals) 1.178 + (#(map first %)) 1.179 + (average) 1.180 + (* 10) 1.181 + (- 1) 1.182 + (Math/abs))) 1.183 + 1.184 +(defn resting? 1.185 + "Is the worm resting on the ground?" 1.186 + [experiences] 1.187 + (every? 1.188 + (fn [touch-data] 1.189 + (< 0.9 (contact worm-segment-bottom touch-data))) 1.190 + (:touch (peek experiences)))) 1.191 + 1.192 +(defn vector:last-n [v n] 1.193 + (let [c (count v)] 1.194 + (if (< c n) v 1.195 + (subvec v (- c n) c)))) 1.196 + 1.197 +(defn fft [nums] 1.198 + (map 1.199 + #(.getReal %) 1.200 + (.transform 1.201 + (FastFourierTransformer. DftNormalization/STANDARD) 1.202 + (double-array nums) TransformType/FORWARD))) 1.203 + 1.204 +(def indexed (partial map-indexed vector)) 1.205 + 1.206 +(defn max-indexed [s] 1.207 + (first (sort-by (comp - second) (indexed s)))) 1.208 + 1.209 +(defn wiggling? 1.210 + "Is the worm wiggling?" 1.211 + [experiences] 1.212 + (let [analysis-interval 96] 1.213 + (when (> (count experiences) analysis-interval) 1.214 + (let [a-flex 3 1.215 + a-ex 2 1.216 + muscle-activity 1.217 + (map :muscle (vector:last-n experiences analysis-interval)) 1.218 + base-activity 1.219 + (map #(- (% a-flex) (% a-ex)) muscle-activity) 1.220 + accept? 1.221 + (fn [activity] 1.222 + (->> activity (fft) (take 20) (map #(Math/abs %)) 1.223 + (max-indexed) (first) (<= 2)))] 1.224 + (or (accept? (take 64 base-activity)) 1.225 + (accept? (take 64 (drop 20 base-activity)))))))) 1.226 + 1.227 + 1.228 + 1.229 +(def worm-segment-bottom-tip (rect-region [15 15] [22 22])) 1.230 + 1.231 +(def worm-segment-top-tip (rect-region [0 15] [7 22])) 1.232 + 1.233 +(defn grand-circle? 1.234 + "Does the worm form a majestic circle (one end touching the other)?" 1.235 + [experiences] 1.236 + (and (curled? experiences) 1.237 + (let [worm-touch (:touch (peek experiences)) 1.238 + tail-touch (worm-touch 0) 1.239 + head-touch (worm-touch 4)] 1.240 + (and (< 0.1 (contact worm-segment-bottom-tip tail-touch)) 1.241 + (< 0.1 (contact worm-segment-top-tip head-touch)))))) 1.242 + 1.243 + 1.244 +(declare phi-space phi-scan debug-experience) 1.245 + 1.246 + 1.247 + 1.248 +(def standard-world-view 1.249 + [(Vector3f. 4.207176, -3.7366982, 3.0816958) 1.250 + (Quaternion. 0.11118768, 0.87678415, 0.24434438, -0.3989771)]) 1.251 + 1.252 +(def worm-side-view 1.253 + [(Vector3f. 4.207176, -3.7366982, 3.0816958) 1.254 + (Quaternion. -0.11555642, 0.88188726, -0.2854942, -0.3569518)]) 1.255 + 1.256 +(def degenerate-worm-view 1.257 + [(Vector3f. -0.0708936, -8.570261, 2.6487997) 1.258 + (Quaternion. -2.318909E-4, 0.9985348, 0.053941682, 0.004291452)]) 1.259 + 1.260 +(defn worm-world-defaults [] 1.261 + (let [direct-control (worm-direct-control worm-muscle-labels 40)] 1.262 + (merge direct-control 1.263 + {:view worm-side-view 1.264 + :record nil 1.265 + :experiences (atom []) 1.266 + :experience-watch debug-experience 1.267 + :worm worm 1.268 + :end-frame nil}))) 1.269 + 1.270 +(defn dir! [file] 1.271 + (if-not (.exists file) 1.272 + (.mkdir file)) 1.273 + file) 1.274 + 1.275 +(defn record-experience! [experiences data] 1.276 + (swap! experiences #(conj % data))) 1.277 + 1.278 +(defn enable-shadows [world] 1.279 + (let [bsr (doto 1.280 + (BasicShadowRenderer. (asset-manager) 512) 1.281 + (.setDirection (.normalizeLocal (Vector3f. 1 -1 -1))))] 1.282 + (.addProcessor (.getViewPort world) bsr))) 1.283 + 1.284 +(defn enable-good-shadows [world] 1.285 + (let [pssm 1.286 + (doto (PssmShadowRenderer. (asset-manager) 1024 3) 1.287 + (.setDirection (.normalizeLocal (Vector3f. -1 -3 -1))) 1.288 + (.setLambda (float 0.55)) 1.289 + (.setShadowIntensity (float 0.6)) 1.290 + (.setCompareMode PssmShadowRenderer$CompareMode/Software) 1.291 + (.setFilterMode PssmShadowRenderer$FilterMode/Bilinear))] 1.292 + (.addProcessor (.getViewPort world) pssm))) 1.293 + 1.294 +(defn debug-experience 1.295 + [experiences text] 1.296 + (cond 1.297 + (grand-circle? experiences) (.setText text "Grand Circle") 1.298 + (curled? experiences) (.setText text "Curled") 1.299 + (wiggling? experiences) (.setText text "Wiggling") 1.300 + (resting? experiences) (.setText text "Resting") 1.301 + :else (.setText text "Unknown"))) 1.302 + 1.303 + 1.304 +(defn worm-world 1.305 + [& {:keys [record motor-control keybindings view experiences 1.306 + worm end-frame experience-watch] :as settings}] 1.307 + (let [{:keys [record motor-control keybindings view experiences 1.308 + worm end-frame experience-watch]} 1.309 + (merge (worm-world-defaults) settings) 1.310 + 1.311 + touch-display (view-touch) 1.312 + prop-display (view-proprioception) 1.313 + muscle-display (view-movement) 1.314 + {:keys [proprioception touch muscles body]} (worm) 1.315 + 1.316 + floor 1.317 + (box 5 1 5 :position (Vector3f. 0 -10 0) 1.318 + :mass 0 1.319 + :texture "Textures/aurellem.png" 1.320 + :material "Common/MatDefs/Misc/Unshaded.j3md") 1.321 + timer (IsoTimer. 60) 1.322 + 1.323 + font (.loadFont (asset-manager) "Interface/Fonts/Console.fnt") 1.324 + worm-action (doto (BitmapText. font false) 1.325 + (.setSize 35) 1.326 + (.setColor (ColorRGBA/Black)))] 1.327 + 1.328 + (world 1.329 + (nodify [body floor]) 1.330 + (merge standard-debug-controls keybindings) 1.331 + (fn [world] 1.332 + (.setLocalTranslation 1.333 + worm-action 20 470 0) 1.334 + (.attachChild (.getGuiNode world) worm-action) 1.335 + 1.336 + (enable-good-shadows world) 1.337 + (.setShadowMode body RenderQueue$ShadowMode/CastAndReceive) 1.338 + (.setShadowMode floor RenderQueue$ShadowMode/Receive) 1.339 + 1.340 + (.setBackgroundColor (.getViewPort world) (ColorRGBA/White)) 1.341 + (.setDisplayStatView world false) 1.342 + (.setDisplayFps world false) 1.343 + (position-camera world view) 1.344 + (.setTimer world timer) 1.345 + ;;(display-dilated-time world timer) 1.346 + (when record 1.347 + (dir! record) 1.348 + (Capture/captureVideo 1.349 + world 1.350 + (dir! (File. record "main-view")))) 1.351 + (speed-up world 0.5) 1.352 + ;;(light-up-everything world) 1.353 + ) 1.354 + (fn [world tpf] 1.355 + (if (and end-frame (> (.getTime timer) end-frame)) 1.356 + (.stop world)) 1.357 + (let [muscle-data (vec (motor-control muscles)) 1.358 + proprioception-data (proprioception) 1.359 + touch-data (mapv #(% (.getRootNode world)) touch)] 1.360 + (when experiences 1.361 + (record-experience! 1.362 + experiences {:touch touch-data 1.363 + :proprioception proprioception-data 1.364 + :muscle muscle-data})) 1.365 + (when experience-watch 1.366 + (experience-watch @experiences worm-action)) 1.367 + (muscle-display 1.368 + muscle-data 1.369 + (when record (dir! (File. record "muscle")))) 1.370 + (prop-display 1.371 + proprioception-data 1.372 + (when record (dir! (File. record "proprio")))) 1.373 + (touch-display 1.374 + touch-data 1.375 + (when record (dir! (File. record "touch"))))))))) 1.376 + 1.377 + 1.378 + 1.379 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.380 +;;;;;;;; Phi-Space ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.381 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.382 + 1.383 +(defn generate-phi-space [] 1.384 + (let [experiences (atom [])] 1.385 + (run-world 1.386 + (apply-map 1.387 + worm-world 1.388 + (merge 1.389 + (worm-world-defaults) 1.390 + {:end-frame 700 1.391 + :motor-control 1.392 + (motor-control-program worm-muscle-labels do-all-the-things) 1.393 + :experiences experiences}))) 1.394 + @experiences)) 1.395 + 1.396 +(defn bin [digits] 1.397 + (fn [angles] 1.398 + (->> angles 1.399 + (flatten) 1.400 + (map (juxt #(Math/sin %) #(Math/cos %))) 1.401 + (flatten) 1.402 + (mapv #(Math/round (* % (Math/pow 10 (dec digits)))))))) 1.403 + 1.404 +;; k-nearest neighbors with spatial binning. Only returns a result if 1.405 +;; the propriceptive data is within 10% of a previously recorded 1.406 +;; result in all dimensions. 1.407 +(defn gen-phi-scan [phi-space] 1.408 + (let [bin-keys (map bin [3 2 1]) 1.409 + bin-maps 1.410 + (map (fn [bin-key] 1.411 + (group-by 1.412 + (comp bin-key :proprioception phi-space) 1.413 + (range (count phi-space)))) bin-keys) 1.414 + lookups (map (fn [bin-key bin-map] 1.415 + (fn [proprio] (bin-map (bin-key proprio)))) 1.416 + bin-keys bin-maps)] 1.417 + (fn lookup [proprio-data] 1.418 + (set (some #(% proprio-data) lookups))))) 1.419 + 1.420 + 1.421 +(defn longest-thread 1.422 + "Find the longest thread from phi-index-sets. The index sets should 1.423 + be ordered from most recent to least recent." 1.424 + [phi-index-sets] 1.425 + (loop [result '() 1.426 + [thread-bases & remaining :as phi-index-sets] phi-index-sets] 1.427 + (if (empty? phi-index-sets) 1.428 + (vec result) 1.429 + (let [threads 1.430 + (for [thread-base thread-bases] 1.431 + (loop [thread (list thread-base) 1.432 + remaining remaining] 1.433 + (let [next-index (dec (first thread))] 1.434 + (cond (empty? remaining) thread 1.435 + (contains? (first remaining) next-index) 1.436 + (recur 1.437 + (cons next-index thread) (rest remaining)) 1.438 + :else thread)))) 1.439 + longest-thread 1.440 + (reduce (fn [thread-a thread-b] 1.441 + (if (> (count thread-a) (count thread-b)) 1.442 + thread-a thread-b)) 1.443 + '(nil) 1.444 + threads)] 1.445 + (recur (concat longest-thread result) 1.446 + (drop (count longest-thread) phi-index-sets)))))) 1.447 + 1.448 + 1.449 +(defn init [] 1.450 + (def phi-space (generate-phi-space)) 1.451 + (def phi-scan (gen-phi-scan phi-space)) 1.452 + ) 1.453 + 1.454 +;; (defn infer-nils-dyl [s] 1.455 +;; (loop [closed () 1.456 +;; open s 1.457 +;; anchor 0] 1.458 +;; (if-not (empty? open) 1.459 +;; (recur (conj closed 1.460 +;; (or (peek open) 1.461 +;; anchor)) 1.462 +;; (pop open) 1.463 +;; (or (peek open) anchor)) 1.464 +;; closed))) 1.465 + 1.466 +;; (defn infer-nils [s] 1.467 +;; (for [i (range (count s))] 1.468 +;; (or (get s i) 1.469 +;; (some (comp not nil?) (vector:last-n (- (count s) i))) 1.470 +;; 0))) 1.471 + 1.472 + 1.473 +(defn infer-nils 1.474 + "Replace nils with the next available non-nil element in the 1.475 + sequence, or barring that, 0." 1.476 + [s] 1.477 + (loop [i (dec (count s)) 1.478 + v (transient s)] 1.479 + (if (zero? i) (persistent! v) 1.480 + (if-let [cur (v i)] 1.481 + (if (get v (dec i) 0) 1.482 + (recur (dec i) v) 1.483 + (recur (dec i) (assoc! v (dec i) cur))) 1.484 + (recur i (assoc! v i 0)))))) 1.485 + 1.486 +;; tests 1.487 + 1.488 +;;(infer-nils [1 nil 1 1]) [1 1 1 1] 1.489 +;;(infer-nils [1 1 1 nil]) [1 1 1 0] 1.490 +;;(infer-nils [nil 2 1 1]) [2 2 1 1] 1.491 + 1.492 + 1.493 +(defn empathy-demonstration [] 1.494 + (let [proprio (atom ())] 1.495 + (fn 1.496 + [experiences text] 1.497 + (let [phi-indices (phi-scan (:proprioception (peek experiences)))] 1.498 + (swap! proprio (partial cons phi-indices)) 1.499 + (let [exp-thread (longest-thread (take 300 @proprio)) 1.500 + empathy (mapv phi-space (infer-nils exp-thread))] 1.501 + (println-repl (vector:last-n exp-thread 22)) 1.502 + (cond 1.503 + (grand-circle? empathy) (.setText text "Grand Circle") 1.504 + (curled? empathy) (.setText text "Curled") 1.505 + (wiggling? empathy) (.setText text "Wiggling") 1.506 + (resting? empathy) (.setText text "Resting") 1.507 + :else (.setText text "Unknown"))))))) 1.508 + 1.509 +(defn init-interactive [] 1.510 + (def phi-space 1.511 + (let [experiences (atom [])] 1.512 + (run-world 1.513 + (apply-map 1.514 + worm-world 1.515 + (merge 1.516 + (worm-world-defaults) 1.517 + {:experiences experiences}))) 1.518 + @experiences)) 1.519 + (def phi-scan (gen-phi-scan phi-space))) 1.520 + 1.521 +(defn empathy-experiment-1 [record] 1.522 + (.start (worm-world :experience-watch (empathy-demonstration) 1.523 + :record record :worm worm*))) 1.524 + 1.525 + 1.526 +(def worm-action-label 1.527 + (juxt grand-circle? curled? wiggling?)) 1.528 + 1.529 +(defn compare-empathy-with-baseline [accuracy] 1.530 + (let [proprio (atom ())] 1.531 + (fn 1.532 + [experiences text] 1.533 + (let [phi-indices (phi-scan (:proprioception (peek experiences)))] 1.534 + (swap! proprio (partial cons phi-indices)) 1.535 + (let [exp-thread (longest-thread (take 300 @proprio)) 1.536 + empathy (mapv phi-space (infer-nils exp-thread)) 1.537 + experience-matches-empathy 1.538 + (= (worm-action-label experiences) 1.539 + (worm-action-label empathy))] 1.540 + (cond 1.541 + (grand-circle? empathy) (.setText text "Grand Circle") 1.542 + (curled? empathy) (.setText text "Curled") 1.543 + (wiggling? empathy) (.setText text "Wiggling") 1.544 + (resting? empathy) (.setText text "Resting") 1.545 + :else (.setText text "Unknown")) 1.546 + 1.547 + (println-repl experience-matches-empathy) 1.548 + (swap! accuracy #(conj % experience-matches-empathy))))))) 1.549 + 1.550 +(defn accuracy [v] 1.551 + (float (/ (count (filter true? v)) (count v)))) 1.552 + 1.553 +(defn test-empathy-accuracy [] 1.554 + (let [res (atom [])] 1.555 + (run-world 1.556 + (worm-world :experience-watch 1.557 + (compare-empathy-with-baseline res) 1.558 + :worm worm*)) 1.559 + (accuracy @res))) 1.560 + 1.561 + 1.562 + 1.563 + 1.564 + 1.565 +