Mercurial > cortex
view org/worm_learn.clj @ 485:ac953b562eab
completed first draft.
author | Robert McIntyre <rlm@mit.edu> |
---|---|
date | Sat, 29 Mar 2014 16:22:49 -0400 |
parents | 0a4362d1f138 |
children | ced955c3c84f |
line wrap: on
line source
1 (ns org.aurellem.worm-learn2 "General worm creation framework."3 {:author "Robert McIntyre"}4 (:use (cortex world util import body sense5 hearing touch vision proprioception movement6 test))7 (:import (com.jme3.math ColorRGBA Vector3f))8 (:import java.io.File)9 (:import com.jme3.audio.AudioNode)10 (:import com.aurellem.capture.RatchetTimer)11 (:import (com.aurellem.capture Capture IsoTimer))12 (:import (com.jme3.math Vector3f ColorRGBA)))14 (import org.apache.commons.math3.transform.TransformType)15 (import org.apache.commons.math3.transform.FastFourierTransformer)16 (import org.apache.commons.math3.transform.DftNormalization)18 (use 'clojure.pprint)19 (use 'clojure.set)20 (dorun (cortex.import/mega-import-jme3))21 (rlm.rlm-commands/help)23 (load-bullet)25 (def hand "Models/test-creature/hand.blend")27 (defn worm-model []28 (load-blender-model "Models/worm/worm.blend"))30 (defn worm []31 (let [model (load-blender-model "Models/worm/worm.blend")]32 {:body (doto model (body!))33 :touch (touch! model)34 :proprioception (proprioception! model)35 :muscles (movement! model)}))37 (defn worm* []38 (let [model (load-blender-model "Models/worm/worm-of-the-imagination.blend")]39 {:body (doto model (body!))40 :touch (touch! model)41 :proprioception (proprioception! model)42 :muscles (movement! model)}))45 (def output-base (File. "/home/r/proj/cortex/render/worm-learn/curl"))48 (defn motor-control-program49 "Create a function which will execute the motor script"50 [muscle-labels51 script]52 (let [current-frame (atom -1)53 keyed-script (group-by first script)54 current-forces (atom {}) ]55 (fn [effectors]56 (let [indexed-effectors (vec effectors)]57 (dorun58 (for [[_ part force] (keyed-script (swap! current-frame inc))]59 (swap! current-forces (fn [m] (assoc m part force)))))60 (doall (map (fn [effector power]61 (effector (int power)))62 effectors63 (map #(@current-forces % 0) muscle-labels)))))))65 (defn worm-direct-control66 "Create keybindings and a muscle control program that will enable67 the user to control the worm via the keyboard."68 [muscle-labels activation-strength]69 (let [strengths (mapv (fn [_] (atom 0)) muscle-labels)70 activator71 (fn [n]72 (fn [world pressed?]73 (let [strength (if pressed? activation-strength 0)]74 (swap! (nth strengths n) (constantly strength)))))75 activators76 (map activator (range (count muscle-labels)))77 worm-keys78 ["key-f" "key-r"79 "key-g" "key-t"80 "key-h" "key-y"81 "key-j" "key-u"82 "key-k" "key-i"83 "key-l" "key-o"]]84 {:motor-control85 (fn [effectors]86 (doall87 (map (fn [strength effector]88 (effector (deref strength)))89 strengths effectors)))90 :keybindings91 ;; assume muscles are listed in pairs and map them to keys.92 (zipmap worm-keys activators)}))94 ;; These are scripts that direct the worm to move in two radically95 ;; different patterns -- a sinusoidal wiggling motion, and a curling96 ;; motions that causes the worm to form a circle.98 (def curl-script99 [[150 :d-flex 40]100 [250 :d-flex 0]])102 (def period 18)104 (def worm-muscle-labels105 [:base-ex :base-flex106 :a-ex :a-flex107 :b-ex :b-flex108 :c-ex :c-flex109 :d-ex :d-flex])111 (defn gen-wiggle [[flexor extensor :as muscle-pair] time-base]112 (let [period period113 power 45]114 [[time-base flexor power]115 [(+ time-base period) flexor 0]116 [(+ time-base period 1) extensor power]117 [(+ time-base (+ (* 2 period) 2)) extensor 0]]))119 (def wiggle-script120 (mapcat gen-wiggle (repeat 4000 [:a-ex :a-flex])121 (range 100 1000000 (+ 3 (* period 2)))))124 (defn shift-script [shift script]125 (map (fn [[time label power]] [(+ time shift) label power])126 script))128 (def do-all-the-things129 (concat130 curl-script131 [[300 :d-ex 40]132 [320 :d-ex 0]]133 (shift-script 280 (take 16 wiggle-script))))135 ;; Normally, we'd use unsupervised/supervised machine learning to pick136 ;; out the defining features of the different actions available to the137 ;; worm. For this project, I am going to explicitely define functions138 ;; that recognize curling and wiggling respectively. These functions139 ;; are defined using all the information available from an embodied140 ;; simulation of the action. Note how much easier they are to define141 ;; than if I only had vision to work with. Things like scale/position142 ;; invariance are complete non-issues here. This is the advantage of143 ;; body-centered action recognition and what I hope to show with this144 ;; thesis.147 ;; curled? relies on proprioception, resting? relies on touch,148 ;; wiggling? relies on a fourier analysis of muscle contraction, and149 ;; grand-circle? relies on touch and reuses curled? as a gaurd.151 (defn curled?152 "Is the worm curled up?"153 [experiences]154 (every?155 (fn [[_ _ bend]]156 (> (Math/sin bend) 0.64))157 (:proprioception (peek experiences))))159 (defn rect-region [[x0 y0] [x1 y1]]160 (vec161 (for [x (range x0 (inc x1))162 y (range y0 (inc y1))]163 [x y])))165 (def worm-segment-bottom (rect-region [8 15] [14 22]))167 (defn contact168 "Determine how much contact a particular worm segment has with169 other objects. Returns a value between 0 and 1, where 1 is full170 contact and 0 is no contact."171 [touch-region [coords contact :as touch]]172 (-> (zipmap coords contact)173 (select-keys touch-region)174 (vals)175 (#(map first %))176 (average)177 (* 10)178 (- 1)179 (Math/abs)))181 (defn resting?182 "Is the worm resting on the ground?"183 [experiences]184 (every?185 (fn [touch-data]186 (< 0.9 (contact worm-segment-bottom touch-data)))187 (:touch (peek experiences))))189 (defn vector:last-n [v n]190 (let [c (count v)]191 (if (< c n) v192 (subvec v (- c n) c))))194 (defn fft [nums]195 (map196 #(.getReal %)197 (.transform198 (FastFourierTransformer. DftNormalization/STANDARD)199 (double-array nums) TransformType/FORWARD)))201 (def indexed (partial map-indexed vector))203 (defn max-indexed [s]204 (first (sort-by (comp - second) (indexed s))))206 (defn wiggling?207 "Is the worm wiggling?"208 [experiences]209 (let [analysis-interval 96]210 (when (> (count experiences) analysis-interval)211 (let [a-flex 3212 a-ex 2213 muscle-activity214 (map :muscle (vector:last-n experiences analysis-interval))215 base-activity216 (map #(- (% a-flex) (% a-ex)) muscle-activity)217 accept?218 (fn [activity]219 (->> activity (fft) (take 20) (map #(Math/abs %))220 (max-indexed) (first) (<= 2)))]221 (or (accept? (take 64 base-activity))222 (accept? (take 64 (drop 20 base-activity))))))))226 (def worm-segment-bottom-tip (rect-region [15 15] [22 22]))228 (def worm-segment-top-tip (rect-region [0 15] [7 22]))230 (defn grand-circle?231 "Does the worm form a majestic circle (one end touching the other)?"232 [experiences]233 (and (curled? experiences)234 (let [worm-touch (:touch (peek experiences))235 tail-touch (worm-touch 0)236 head-touch (worm-touch 4)]237 (and (< 0.1 (contact worm-segment-bottom-tip tail-touch))238 (< 0.1 (contact worm-segment-top-tip head-touch))))))241 (declare phi-space phi-scan debug-experience)245 (def standard-world-view246 [(Vector3f. 4.207176, -3.7366982, 3.0816958)247 (Quaternion. 0.11118768, 0.87678415, 0.24434438, -0.3989771)])249 (def worm-side-view250 [(Vector3f. 4.207176, -3.7366982, 3.0816958)251 (Quaternion. -0.11555642, 0.88188726, -0.2854942, -0.3569518)])253 (def degenerate-worm-view254 [(Vector3f. -0.0708936, -8.570261, 2.6487997)255 (Quaternion. -2.318909E-4, 0.9985348, 0.053941682, 0.004291452)])257 (defn worm-world-defaults []258 (let [direct-control (worm-direct-control worm-muscle-labels 40)]259 (merge direct-control260 {:view worm-side-view261 :record nil262 :experiences (atom [])263 :experience-watch debug-experience264 :worm worm265 :end-frame nil})))267 (defn dir! [file]268 (if-not (.exists file)269 (.mkdir file))270 file)272 (defn record-experience! [experiences data]273 (swap! experiences #(conj % data)))275 (defn enable-shadows [world]276 (let [bsr (doto277 (BasicShadowRenderer. (asset-manager) 512)278 (.setDirection (.normalizeLocal (Vector3f. 1 -1 -1))))]279 (.addProcessor (.getViewPort world) bsr)))281 (defn enable-good-shadows [world]282 (let [pssm283 (doto (PssmShadowRenderer. (asset-manager) 1024 3)284 (.setDirection (.normalizeLocal (Vector3f. -1 -3 -1)))285 (.setLambda (float 0.55))286 (.setShadowIntensity (float 0.6))287 (.setCompareMode PssmShadowRenderer$CompareMode/Software)288 (.setFilterMode PssmShadowRenderer$FilterMode/Bilinear))]289 (.addProcessor (.getViewPort world) pssm)))291 (defn debug-experience292 [experiences text]293 (cond294 (grand-circle? experiences) (.setText text "Grand Circle")295 (curled? experiences) (.setText text "Curled")296 (wiggling? experiences) (.setText text "Wiggling")297 (resting? experiences) (.setText text "Resting")298 :else (.setText text "Unknown")))301 (defn worm-world302 [& {:keys [record motor-control keybindings view experiences303 worm end-frame experience-watch] :as settings}]304 (let [{:keys [record motor-control keybindings view experiences305 worm end-frame experience-watch]}306 (merge (worm-world-defaults) settings)308 touch-display (view-touch)309 prop-display (view-proprioception)310 muscle-display (view-movement)311 {:keys [proprioception touch muscles body]} (worm)313 floor314 (box 5 1 5 :position (Vector3f. 0 -10 0)315 :mass 0316 :texture "Textures/aurellem.png"317 :material "Common/MatDefs/Misc/Unshaded.j3md")318 timer (IsoTimer. 60)320 font (.loadFont (asset-manager) "Interface/Fonts/Console.fnt")321 worm-action (doto (BitmapText. font false)322 (.setSize 35)323 (.setColor (ColorRGBA/Black)))]325 (world326 (nodify [body floor])327 (merge standard-debug-controls keybindings)328 (fn [world]329 (.setLocalTranslation330 worm-action 20 470 0)331 (.attachChild (.getGuiNode world) worm-action)333 (enable-good-shadows world)334 (.setShadowMode body RenderQueue$ShadowMode/CastAndReceive)335 (.setShadowMode floor RenderQueue$ShadowMode/Receive)337 (.setBackgroundColor (.getViewPort world) (ColorRGBA/White))338 (.setDisplayStatView world false)339 (.setDisplayFps world false)340 (position-camera world view)341 (.setTimer world timer)342 ;;(display-dilated-time world timer)343 (when record344 (dir! record)345 (Capture/captureVideo346 world347 (dir! (File. record "main-view"))))348 (speed-up world 0.5)349 ;;(light-up-everything world)350 )351 (fn [world tpf]352 (if (and end-frame (> (.getTime timer) end-frame))353 (.stop world))354 (let [muscle-data (vec (motor-control muscles))355 proprioception-data (proprioception)356 touch-data (mapv #(% (.getRootNode world)) touch)]357 (when experiences358 (record-experience!359 experiences {:touch touch-data360 :proprioception proprioception-data361 :muscle muscle-data}))362 (when experience-watch363 (experience-watch @experiences worm-action))364 (muscle-display365 muscle-data366 (when record (dir! (File. record "muscle"))))367 (prop-display368 proprioception-data369 (when record (dir! (File. record "proprio"))))370 (touch-display371 touch-data372 (when record (dir! (File. record "touch")))))))))376 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;377 ;;;;;;;; Phi-Space ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;378 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;380 (defn generate-phi-space []381 (let [experiences (atom [])]382 (run-world383 (apply-map384 worm-world385 (merge386 (worm-world-defaults)387 {:end-frame 700388 :motor-control389 (motor-control-program worm-muscle-labels do-all-the-things)390 :experiences experiences})))391 @experiences))393 (defn bin [digits]394 (fn [angles]395 (->> angles396 (flatten)397 (map (juxt #(Math/sin %) #(Math/cos %)))398 (flatten)399 (mapv #(Math/round (* % (Math/pow 10 (dec digits))))))))401 ;; k-nearest neighbors with spatial binning. Only returns a result if402 ;; the propriceptive data is within 10% of a previously recorded403 ;; result in all dimensions.404 (defn gen-phi-scan [phi-space]405 (let [bin-keys (map bin [3 2 1])406 bin-maps407 (map (fn [bin-key]408 (group-by409 (comp bin-key :proprioception phi-space)410 (range (count phi-space)))) bin-keys)411 lookups (map (fn [bin-key bin-map]412 (fn [proprio] (bin-map (bin-key proprio))))413 bin-keys bin-maps)]414 (fn lookup [proprio-data]415 (set (some #(% proprio-data) lookups)))))418 (defn longest-thread419 "Find the longest thread from phi-index-sets. The index sets should420 be ordered from most recent to least recent."421 [phi-index-sets]422 (loop [result '()423 [thread-bases & remaining :as phi-index-sets] phi-index-sets]424 (if (empty? phi-index-sets)425 (vec result)426 (let [threads427 (for [thread-base thread-bases]428 (loop [thread (list thread-base)429 remaining remaining]430 (let [next-index (dec (first thread))]431 (cond (empty? remaining) thread432 (contains? (first remaining) next-index)433 (recur434 (cons next-index thread) (rest remaining))435 :else thread))))436 longest-thread437 (reduce (fn [thread-a thread-b]438 (if (> (count thread-a) (count thread-b))439 thread-a thread-b))440 '(nil)441 threads)]442 (recur (concat longest-thread result)443 (drop (count longest-thread) phi-index-sets))))))446 (defn init []447 (def phi-space (generate-phi-space))448 (def phi-scan (gen-phi-scan phi-space))449 )451 ;; (defn infer-nils-dyl [s]452 ;; (loop [closed ()453 ;; open s454 ;; anchor 0]455 ;; (if-not (empty? open)456 ;; (recur (conj closed457 ;; (or (peek open)458 ;; anchor))459 ;; (pop open)460 ;; (or (peek open) anchor))461 ;; closed)))463 ;; (defn infer-nils [s]464 ;; (for [i (range (count s))]465 ;; (or (get s i)466 ;; (some (comp not nil?) (vector:last-n (- (count s) i)))467 ;; 0)))470 (defn infer-nils471 "Replace nils with the next available non-nil element in the472 sequence, or barring that, 0."473 [s]474 (loop [i (dec (count s))475 v (transient s)]476 (if (zero? i) (persistent! v)477 (if-let [cur (v i)]478 (if (get v (dec i) 0)479 (recur (dec i) v)480 (recur (dec i) (assoc! v (dec i) cur)))481 (recur i (assoc! v i 0))))))483 ;; tests485 ;;(infer-nils [1 nil 1 1]) [1 1 1 1]486 ;;(infer-nils [1 1 1 nil]) [1 1 1 0]487 ;;(infer-nils [nil 2 1 1]) [2 2 1 1]490 (defn empathy-demonstration []491 (let [proprio (atom ())]492 (fn493 [experiences text]494 (let [phi-indices (phi-scan (:proprioception (peek experiences)))]495 (swap! proprio (partial cons phi-indices))496 (let [exp-thread (longest-thread (take 300 @proprio))497 empathy (mapv phi-space (infer-nils exp-thread))]498 (println-repl (vector:last-n exp-thread 22))499 (cond500 (grand-circle? empathy) (.setText text "Grand Circle")501 (curled? empathy) (.setText text "Curled")502 (wiggling? empathy) (.setText text "Wiggling")503 (resting? empathy) (.setText text "Resting")504 :else (.setText text "Unknown")))))))506 (defn init-interactive []507 (def phi-space508 (let [experiences (atom [])]509 (run-world510 (apply-map511 worm-world512 (merge513 (worm-world-defaults)514 {:experiences experiences})))515 @experiences))516 (def phi-scan (gen-phi-scan phi-space)))518 (defn empathy-experiment-1 [record]519 (.start (worm-world :experience-watch (empathy-demonstration)520 :record record :worm worm*)))523 (def worm-action-label524 (juxt grand-circle? curled? wiggling?))526 (defn compare-empathy-with-baseline [accuracy]527 (let [proprio (atom ())]528 (fn529 [experiences text]530 (let [phi-indices (phi-scan (:proprioception (peek experiences)))]531 (swap! proprio (partial cons phi-indices))532 (let [exp-thread (longest-thread (take 300 @proprio))533 empathy (mapv phi-space (infer-nils exp-thread))534 experience-matches-empathy535 (= (worm-action-label experiences)536 (worm-action-label empathy))]537 (cond538 (grand-circle? empathy) (.setText text "Grand Circle")539 (curled? empathy) (.setText text "Curled")540 (wiggling? empathy) (.setText text "Wiggling")541 (resting? empathy) (.setText text "Resting")542 :else (.setText text "Unknown"))544 (println-repl experience-matches-empathy)545 (swap! accuracy #(conj % experience-matches-empathy)))))))547 (defn accuracy [v]548 (float (/ (count (filter true? v)) (count v))))550 (defn test-empathy-accuracy []551 (let [res (atom [])]552 (run-world553 (worm-world :experience-watch554 (compare-empathy-with-baseline res)555 :worm worm*))556 (accuracy @res)))