view org/worm_learn.clj @ 451:0a4362d1f138

finishing up chapter 3.
author Robert McIntyre <rlm@mit.edu>
date Wed, 26 Mar 2014 20:38:17 -0400
parents 09b7c8dd4365
children ced955c3c84f
line wrap: on
line source
1 (ns org.aurellem.worm-learn
2 "General worm creation framework."
3 {:author "Robert McIntyre"}
4 (:use (cortex world util import body sense
5 hearing touch vision proprioception movement
6 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-program
49 "Create a function which will execute the motor script"
50 [muscle-labels
51 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 (dorun
58 (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 effectors
63 (map #(@current-forces % 0) muscle-labels)))))))
65 (defn worm-direct-control
66 "Create keybindings and a muscle control program that will enable
67 the user to control the worm via the keyboard."
68 [muscle-labels activation-strength]
69 (let [strengths (mapv (fn [_] (atom 0)) muscle-labels)
70 activator
71 (fn [n]
72 (fn [world pressed?]
73 (let [strength (if pressed? activation-strength 0)]
74 (swap! (nth strengths n) (constantly strength)))))
75 activators
76 (map activator (range (count muscle-labels)))
77 worm-keys
78 ["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-control
85 (fn [effectors]
86 (doall
87 (map (fn [strength effector]
88 (effector (deref strength)))
89 strengths effectors)))
90 :keybindings
91 ;; 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 radically
95 ;; different patterns -- a sinusoidal wiggling motion, and a curling
96 ;; motions that causes the worm to form a circle.
98 (def curl-script
99 [[150 :d-flex 40]
100 [250 :d-flex 0]])
102 (def period 18)
104 (def worm-muscle-labels
105 [:base-ex :base-flex
106 :a-ex :a-flex
107 :b-ex :b-flex
108 :c-ex :c-flex
109 :d-ex :d-flex])
111 (defn gen-wiggle [[flexor extensor :as muscle-pair] time-base]
112 (let [period period
113 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-script
120 (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-things
129 (concat
130 curl-script
131 [[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 pick
136 ;; out the defining features of the different actions available to the
137 ;; worm. For this project, I am going to explicitely define functions
138 ;; that recognize curling and wiggling respectively. These functions
139 ;; are defined using all the information available from an embodied
140 ;; simulation of the action. Note how much easier they are to define
141 ;; than if I only had vision to work with. Things like scale/position
142 ;; invariance are complete non-issues here. This is the advantage of
143 ;; body-centered action recognition and what I hope to show with this
144 ;; thesis.
147 ;; curled? relies on proprioception, resting? relies on touch,
148 ;; wiggling? relies on a fourier analysis of muscle contraction, and
149 ;; 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 (vec
161 (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 contact
168 "Determine how much contact a particular worm segment has with
169 other objects. Returns a value between 0 and 1, where 1 is full
170 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) v
192 (subvec v (- c n) c))))
194 (defn fft [nums]
195 (map
196 #(.getReal %)
197 (.transform
198 (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 3
212 a-ex 2
213 muscle-activity
214 (map :muscle (vector:last-n experiences analysis-interval))
215 base-activity
216 (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-view
246 [(Vector3f. 4.207176, -3.7366982, 3.0816958)
247 (Quaternion. 0.11118768, 0.87678415, 0.24434438, -0.3989771)])
249 (def worm-side-view
250 [(Vector3f. 4.207176, -3.7366982, 3.0816958)
251 (Quaternion. -0.11555642, 0.88188726, -0.2854942, -0.3569518)])
253 (def degenerate-worm-view
254 [(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-control
260 {:view worm-side-view
261 :record nil
262 :experiences (atom [])
263 :experience-watch debug-experience
264 :worm worm
265 :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 (doto
277 (BasicShadowRenderer. (asset-manager) 512)
278 (.setDirection (.normalizeLocal (Vector3f. 1 -1 -1))))]
279 (.addProcessor (.getViewPort world) bsr)))
281 (defn enable-good-shadows [world]
282 (let [pssm
283 (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-experience
292 [experiences text]
293 (cond
294 (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-world
302 [& {:keys [record motor-control keybindings view experiences
303 worm end-frame experience-watch] :as settings}]
304 (let [{:keys [record motor-control keybindings view experiences
305 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 floor
314 (box 5 1 5 :position (Vector3f. 0 -10 0)
315 :mass 0
316 :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 (world
326 (nodify [body floor])
327 (merge standard-debug-controls keybindings)
328 (fn [world]
329 (.setLocalTranslation
330 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 record
344 (dir! record)
345 (Capture/captureVideo
346 world
347 (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 experiences
358 (record-experience!
359 experiences {:touch touch-data
360 :proprioception proprioception-data
361 :muscle muscle-data}))
362 (when experience-watch
363 (experience-watch @experiences worm-action))
364 (muscle-display
365 muscle-data
366 (when record (dir! (File. record "muscle"))))
367 (prop-display
368 proprioception-data
369 (when record (dir! (File. record "proprio"))))
370 (touch-display
371 touch-data
372 (when record (dir! (File. record "touch")))))))))
376 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
377 ;;;;;;;; Phi-Space ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
378 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
380 (defn generate-phi-space []
381 (let [experiences (atom [])]
382 (run-world
383 (apply-map
384 worm-world
385 (merge
386 (worm-world-defaults)
387 {:end-frame 700
388 :motor-control
389 (motor-control-program worm-muscle-labels do-all-the-things)
390 :experiences experiences})))
391 @experiences))
393 (defn bin [digits]
394 (fn [angles]
395 (->> angles
396 (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 if
402 ;; the propriceptive data is within 10% of a previously recorded
403 ;; result in all dimensions.
404 (defn gen-phi-scan [phi-space]
405 (let [bin-keys (map bin [3 2 1])
406 bin-maps
407 (map (fn [bin-key]
408 (group-by
409 (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-thread
419 "Find the longest thread from phi-index-sets. The index sets should
420 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 [threads
427 (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) thread
432 (contains? (first remaining) next-index)
433 (recur
434 (cons next-index thread) (rest remaining))
435 :else thread))))
436 longest-thread
437 (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 s
454 ;; anchor 0]
455 ;; (if-not (empty? open)
456 ;; (recur (conj closed
457 ;; (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-nils
471 "Replace nils with the next available non-nil element in the
472 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 ;; tests
485 ;;(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 (fn
493 [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 (cond
500 (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-space
508 (let [experiences (atom [])]
509 (run-world
510 (apply-map
511 worm-world
512 (merge
513 (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-label
524 (juxt grand-circle? curled? wiggling?))
526 (defn compare-empathy-with-baseline [accuracy]
527 (let [proprio (atom ())]
528 (fn
529 [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-empathy
535 (= (worm-action-label experiences)
536 (worm-action-label empathy))]
537 (cond
538 (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-world
553 (worm-world :experience-watch
554 (compare-empathy-with-baseline res)
555 :worm worm*))
556 (accuracy @res)))