view org/worm_learn.clj @ 548:0b891e0dd809

version 0.2 of thesis complete.
author Robert McIntyre <rlm@mit.edu>
date Thu, 01 May 2014 23:41:41 -0400
parents 01934317b25b
children
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)
24 (load-bullet)
26 (defn bin [digits]
27 (fn [angles]
28 (->> angles
29 (flatten)
30 (map (juxt #(Math/sin %) #(Math/cos %)))
31 (flatten)
32 (mapv #(Math/round (* % (Math/pow 10 (dec digits))))))))
35 (def hand "Models/test-creature/hand.blend")
37 (defn worm-model []
38 (load-blender-model "Models/worm/worm.blend"))
40 (defn worm []
41 (let [model (load-blender-model "Models/worm/worm.blend")]
42 {:body (doto model (body!))
43 :touch (touch! model)
44 :proprioception (proprioception! model)
45 :muscles (movement! model)}))
47 (defn worm* []
48 (let [model (load-blender-model "Models/worm/worm-of-the-imagination.blend")]
49 {:body (doto model (body!))
50 :touch (touch! model)
51 :proprioception (proprioception! model)
52 :muscles (movement! model)}))
55 (def output-base (File. "/home/r/proj/cortex/render/worm-learn/curl"))
58 (defn motor-control-program
59 "Create a function which will execute the motor script"
60 [muscle-labels
61 script]
62 (let [current-frame (atom -1)
63 keyed-script (group-by first script)
64 current-forces (atom {}) ]
65 (fn [effectors]
66 (let [indexed-effectors (vec effectors)]
67 (dorun
68 (for [[_ part force] (keyed-script (swap! current-frame inc))]
69 (swap! current-forces (fn [m] (assoc m part force)))))
70 (doall (map (fn [effector power]
71 (effector (int power)))
72 effectors
73 (map #(@current-forces % 0) muscle-labels)))))))
75 (defn worm-direct-control
76 "Create keybindings and a muscle control program that will enable
77 the user to control the worm via the keyboard."
78 [muscle-labels activation-strength]
79 (let [strengths (mapv (fn [_] (atom 0)) muscle-labels)
80 activator
81 (fn [n]
82 (fn [world pressed?]
83 (let [strength (if pressed? activation-strength 0)]
84 (swap! (nth strengths n) (constantly strength)))))
85 activators
86 (map activator (range (count muscle-labels)))
87 worm-keys
88 ["key-f" "key-r"
89 "key-g" "key-t"
90 "key-h" "key-y"
91 "key-j" "key-u"
92 "key-k" "key-i"
93 "key-l" "key-o"]]
94 {:motor-control
95 (fn [effectors]
96 (doall
97 (map (fn [strength effector]
98 (effector (deref strength)))
99 strengths effectors)))
100 :keybindings
101 ;; assume muscles are listed in pairs and map them to keys.
102 (zipmap worm-keys activators)}))
104 ;; These are scripts that direct the worm to move in two radically
105 ;; different patterns -- a sinusoidal wiggling motion, and a curling
106 ;; motions that causes the worm to form a circle.
108 (def curl-script
109 [[150 :d-flex 40]
110 [250 :d-flex 0]])
112 (def period 18)
114 (def worm-muscle-labels
115 [:base-ex :base-flex
116 :a-ex :a-flex
117 :b-ex :b-flex
118 :c-ex :c-flex
119 :d-ex :d-flex])
121 (defn gen-wiggle [[flexor extensor :as muscle-pair] time-base]
122 (let [period period
123 power 45]
124 [[time-base flexor power]
125 [(+ time-base period) flexor 0]
126 [(+ time-base period 1) extensor power]
127 [(+ time-base (+ (* 2 period) 2)) extensor 0]]))
129 (def wiggle-script
130 (mapcat gen-wiggle (repeat 4000 [:a-ex :a-flex])
131 (range 100 1000000 (+ 3 (* period 2)))))
134 (defn shift-script [shift script]
135 (map (fn [[time label power]] [(+ time shift) label power])
136 script))
138 (def do-all-the-things
139 (concat
140 curl-script
141 [[300 :d-ex 40]
142 [320 :d-ex 0]]
143 (shift-script 280 (take 16 wiggle-script))))
145 ;; Normally, we'd use unsupervised/supervised machine learning to pick
146 ;; out the defining features of the different actions available to the
147 ;; worm. For this project, I am going to explicitely define functions
148 ;; that recognize curling and wiggling respectively. These functions
149 ;; are defined using all the information available from an embodied
150 ;; simulation of the action. Note how much easier they are to define
151 ;; than if I only had vision to work with. Things like scale/position
152 ;; invariance are complete non-issues here. This is the advantage of
153 ;; body-centered action recognition and what I hope to show with this
154 ;; thesis.
157 ;; curled? relies on proprioception, resting? relies on touch,
158 ;; wiggling? relies on a fourier analysis of muscle contraction, and
159 ;; grand-circle? relies on touch and reuses curled? as a gaurd.
161 (defn curled?
162 "Is the worm curled up?"
163 [experiences]
164 (every?
165 (fn [[_ _ bend]]
166 (> (Math/sin bend) 0.64))
167 (:proprioception (peek experiences))))
169 (defn rect-region [[x0 y0] [x1 y1]]
170 (vec
171 (for [x (range x0 (inc x1))
172 y (range y0 (inc y1))]
173 [x y])))
175 (def all-touch-coordinates
176 (concat
177 (rect-region [0 15] [7 22])
178 (rect-region [8 0] [14 29])
179 (rect-region [15 15] [22 22])))
181 (def worm-segment-bottom (rect-region [8 15] [14 22]))
183 (defn contact
184 "Determine how much contact a particular worm segment has with
185 other objects. Returns a value between 0 and 1, where 1 is full
186 contact and 0 is no contact."
187 [touch-region [coords contact :as touch]]
188 (-> (zipmap coords contact)
189 (select-keys touch-region)
190 (vals)
191 (#(map first %))
192 (average)
193 (* 10)
194 (- 1)
195 (Math/abs)))
197 (defn resting?
198 "Is the worm resting on the ground?"
199 [experiences]
200 (every?
201 (fn [touch-data]
202 (< 0.9 (contact worm-segment-bottom touch-data)))
203 (:touch (peek experiences))))
205 (defn vector:last-n [v n]
206 (let [c (count v)]
207 (if (< c n) v
208 (subvec v (- c n) c))))
210 (defn fft [nums]
211 (map
212 #(.getReal %)
213 (.transform
214 (FastFourierTransformer. DftNormalization/STANDARD)
215 (double-array nums) TransformType/FORWARD)))
217 (def indexed (partial map-indexed vector))
219 (defn max-indexed [s]
220 (first (sort-by (comp - second) (indexed s))))
222 (defn wiggling?
223 "Is the worm wiggling?"
224 [experiences]
225 (let [analysis-interval 96]
226 (when (> (count experiences) analysis-interval)
227 (let [a-flex 3
228 a-ex 2
229 muscle-activity
230 (map :muscle (vector:last-n experiences analysis-interval))
231 base-activity
232 (map #(- (% a-flex) (% a-ex)) muscle-activity)
233 accept?
234 (fn [activity]
235 (->> activity (fft) (take 20) (map #(Math/abs %))
236 (max-indexed) (first) (<= 2)))]
237 (or (accept? (take 64 base-activity))
238 (accept? (take 64 (drop 20 base-activity))))))))
240 (def worm-segment-bottom-tip (rect-region [15 15] [22 22]))
242 (def worm-segment-top-tip (rect-region [0 15] [7 22]))
244 (defn grand-circle?
245 "Does the worm form a majestic circle (one end touching the other)?"
246 [experiences]
247 (and (curled? experiences)
248 (let [worm-touch (:touch (peek experiences))
249 tail-touch (worm-touch 0)
250 head-touch (worm-touch 4)]
251 (and (< 0.1 (contact worm-segment-bottom-tip tail-touch))
252 (< 0.1 (contact worm-segment-top-tip head-touch))))))
255 (defn draped?
256 "Is the worm:
257 -- not flat (the floor is not a 'chair')
258 -- supported (not using its muscles to hold its position)
259 -- stable (not changing its position)
260 -- touching something (must register contact)"
261 [experiences]
262 (let [b2-hash (bin 2)
263 touch (:touch (peek experiences))
264 total-contact
265 (reduce
266 +
267 (map #(contact all-touch-coordinates %)
268 (rest touch)))]
269 (println total-contact)
270 (and (not (resting? experiences))
271 (every?
272 zero?
273 (-> experiences
274 (vector:last-n 25)
275 (#(map :muscle %))
276 (flatten)))
277 (-> experiences
278 (vector:last-n 20)
279 (#(map (comp b2-hash flatten :proprioception) %))
280 (set)
281 (count) (= 1))
282 (< 0.03 total-contact))))
285 (declare phi-space phi-scan debug-experience)
289 (def standard-world-view
290 [(Vector3f. 4.207176, -3.7366982, 3.0816958)
291 (Quaternion. 0.11118768, 0.87678415, 0.24434438, -0.3989771)])
293 (def worm-side-view
294 [(Vector3f. 4.207176, -3.7366982, 3.0816958)
295 (Quaternion. -0.11555642, 0.88188726, -0.2854942, -0.3569518)])
297 (def degenerate-worm-view
298 [(Vector3f. -0.0708936, -8.570261, 2.6487997)
299 (Quaternion. -2.318909E-4, 0.9985348, 0.053941682, 0.004291452)])
301 (defn summon-chair
302 "Create a chair in the world for the worm"
303 [world]
304 (let [chair (box 0.5 0.5 0.5 :position (Vector3f. 0 -5 -2)
305 :mass 350. :color ColorRGBA/Pink)]
306 (add-element world chair (.getRootNode world))))
308 (defn worm-world-defaults []
309 (let [direct-control (worm-direct-control worm-muscle-labels 40)]
310 (merge direct-control
311 {:view worm-side-view
312 :record nil
313 :experiences (atom [])
314 :experience-watch debug-experience
315 :worm worm
316 :end-frame nil
317 :keybindings
318 (merge (:keybindings direct-control)
319 {"key-b" (fn [world pressed?]
320 (if pressed? (summon-chair world)))})})))
322 (defn dir! [file]
323 (if-not (.exists file)
324 (.mkdir file))
325 file)
327 (defn record-experience! [experiences data]
328 (swap! experiences #(conj % data)))
330 (defn enable-shadows [world]
331 (let [bsr (doto
332 (BasicShadowRenderer. (asset-manager) 512)
333 (.setDirection (.normalizeLocal (Vector3f. 1 -1 -1))))]
334 (.addProcessor (.getViewPort world) bsr)))
336 (defn enable-good-shadows [world]
337 (let [pssm
338 (doto (PssmShadowRenderer. (asset-manager) 1024 3)
339 (.setDirection (.normalizeLocal (Vector3f. -1 -3 -1)))
340 (.setLambda (float 0.55))
341 (.setShadowIntensity (float 0.6))
342 (.setCompareMode PssmShadowRenderer$CompareMode/Software)
343 (.setFilterMode PssmShadowRenderer$FilterMode/Bilinear))]
344 (.addProcessor (.getViewPort world) pssm)))
346 (defn debug-experience
347 [experiences text]
348 (cond
349 (draped? experiences) (.setText text "Draped")
350 (grand-circle? experiences) (.setText text "Grand Circle")
351 (curled? experiences) (.setText text "Curled")
352 (wiggling? experiences) (.setText text "Wiggling")
353 (resting? experiences) (.setText text "Resting")
354 :else (.setText text "Unknown")))
357 (defn worm-world
358 [& {:keys [record motor-control keybindings view experiences
359 worm end-frame experience-watch] :as settings}]
360 (let [{:keys [record motor-control keybindings view experiences
361 worm end-frame experience-watch]}
362 (merge (worm-world-defaults) settings)
364 touch-display (view-touch)
365 prop-display (view-proprioception)
366 muscle-display (view-movement)
367 {:keys [proprioception touch muscles body]} (worm)
369 floor
370 (box 5 1 5 :position (Vector3f. 0 -10 0)
371 :mass 0
372 :texture "Textures/aurellem.png"
373 :material "Common/MatDefs/Misc/Unshaded.j3md")
374 timer (IsoTimer. 60)
376 font (.loadFont (asset-manager) "Interface/Fonts/Console.fnt")
377 worm-action (doto (BitmapText. font false)
378 (.setSize 35)
379 (.setColor (ColorRGBA/Black)))]
381 (world
382 (nodify [body floor])
383 (merge standard-debug-controls keybindings)
384 (fn [world]
385 (.setLocalTranslation
386 worm-action 20 470 0)
387 (.attachChild (.getGuiNode world) worm-action)
389 (enable-good-shadows world)
390 (.setShadowMode body RenderQueue$ShadowMode/CastAndReceive)
391 (.setShadowMode floor RenderQueue$ShadowMode/Receive)
393 (.setBackgroundColor (.getViewPort world) (ColorRGBA/White))
394 (.setDisplayStatView world false)
395 (.setDisplayFps world false)
396 (position-camera world view)
397 (.setTimer world timer)
398 ;;(display-dilated-time world timer)
399 (when record
400 (dir! record)
401 (Capture/captureVideo
402 world
403 (dir! (File. record "main-view"))))
404 (speed-up world 0.5)
405 ;;(light-up-everything world)
406 )
407 (fn [world tpf]
408 (if (and end-frame (> (.getTime timer) end-frame))
409 (.stop world))
410 (let [muscle-data (vec (motor-control muscles))
411 proprioception-data (proprioception)
412 touch-data (mapv #(% (.getRootNode world)) touch)]
413 (when experiences
414 (record-experience!
415 experiences {:touch touch-data
416 :proprioception proprioception-data
417 :muscle muscle-data}))
418 (when experience-watch
419 (experience-watch @experiences worm-action))
420 (muscle-display
421 muscle-data
422 (when record (dir! (File. record "muscle"))))
423 (prop-display
424 proprioception-data
425 (when record (dir! (File. record "proprio"))))
426 (touch-display
427 touch-data
428 (when record (dir! (File. record "touch")))))))))
432 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
433 ;;;;;;;; Phi-Space ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
434 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
436 (defn generate-phi-space []
437 (let [experiences (atom [])]
438 (run-world
439 (apply-map
440 worm-world
441 (merge
442 (worm-world-defaults)
443 {:end-frame 700
444 :motor-control
445 (motor-control-program worm-muscle-labels do-all-the-things)
446 :experiences experiences})))
447 @experiences))
449 ;; k-nearest neighbors with spatial binning. Only returns a result if
450 ;; the propriceptive data is within 10% of a previously recorded
451 ;; result in all dimensions.
452 (defn gen-phi-scan [phi-space]
453 (let [bin-keys (map bin [3 2 1])
454 bin-maps
455 (map (fn [bin-key]
456 (group-by
457 (comp bin-key :proprioception phi-space)
458 (range (count phi-space)))) bin-keys)
459 lookups (map (fn [bin-key bin-map]
460 (fn [proprio] (bin-map (bin-key proprio))))
461 bin-keys bin-maps)]
462 (fn lookup [proprio-data]
463 (set (some #(% proprio-data) lookups)))))
466 (defn longest-thread
467 "Find the longest thread from phi-index-sets. The index sets should
468 be ordered from most recent to least recent."
469 [phi-index-sets]
470 (loop [result '()
471 [thread-bases & remaining :as phi-index-sets] phi-index-sets]
472 (if (empty? phi-index-sets)
473 (vec result)
474 (let [threads
475 (for [thread-base thread-bases]
476 (loop [thread (list thread-base)
477 remaining remaining]
478 (let [next-index (dec (first thread))]
479 (cond (empty? remaining) thread
480 (contains? (first remaining) next-index)
481 (recur
482 (cons next-index thread) (rest remaining))
483 :else thread))))
484 longest-thread
485 (reduce (fn [thread-a thread-b]
486 (if (> (count thread-a) (count thread-b))
487 thread-a thread-b))
488 '(nil)
489 threads)]
490 (recur (concat longest-thread result)
491 (drop (count longest-thread) phi-index-sets))))))
494 (defn init []
495 (def phi-space (generate-phi-space))
496 (def phi-scan (gen-phi-scan phi-space))
497 )
500 (defn infer-nils
501 "Replace nils with the next available non-nil element in the
502 sequence, or barring that, 0."
503 [s]
504 (loop [i (dec (count s))
505 v (transient s)]
506 (if (zero? i) (persistent! v)
507 (if-let [cur (v i)]
508 (if (get v (dec i) 0)
509 (recur (dec i) v)
510 (recur (dec i) (assoc! v (dec i) cur)))
511 (recur i (assoc! v i 0))))))
513 ;; tests
515 ;;(infer-nils [1 nil 1 1]) [1 1 1 1]
516 ;;(infer-nils [1 1 1 nil]) [1 1 1 0]
517 ;;(infer-nils [nil 2 1 1]) [2 2 1 1]
520 (defn empathy-demonstration []
521 (let [proprio (atom ())]
522 (fn
523 [experiences text]
524 (let [phi-indices (phi-scan (:proprioception (peek experiences)))]
525 (swap! proprio (partial cons phi-indices))
526 (let [exp-thread (longest-thread (take 300 @proprio))
527 empathy (mapv phi-space (infer-nils exp-thread))]
528 (println-repl (vector:last-n exp-thread 22))
529 (cond
530 (draped? empathy) (.setText text "Draped")
531 (grand-circle? empathy) (.setText text "Grand Circle")
532 (curled? empathy) (.setText text "Curled")
533 (wiggling? empathy) (.setText text "Wiggling")
534 (resting? empathy) (.setText text "Resting")
535 :else (.setText text "Unknown")))))))
537 (defn init-interactive []
538 (def phi-space
539 (let [experiences (atom [])]
540 (run-world
541 (apply-map
542 worm-world
543 (merge
544 (worm-world-defaults)
545 {:experiences experiences})))
546 @experiences))
547 (def phi-scan (gen-phi-scan phi-space)))
549 (defn empathy-experiment-0 [record]
550 (.start (worm-world :record record)))
554 (defn empathy-experiment-1 [record]
555 (.start (worm-world :experience-watch (empathy-demonstration)
556 :record record :worm worm*)))
559 (def worm-action-label
560 (juxt grand-circle? curled? wiggling?))
562 (defn compare-empathy-with-baseline [accuracy]
563 (let [proprio (atom ())]
564 (fn
565 [experiences text]
566 (let [phi-indices (phi-scan (:proprioception (peek experiences)))]
567 (swap! proprio (partial cons phi-indices))
568 (let [exp-thread (longest-thread (take 300 @proprio))
569 empathy (mapv phi-space (infer-nils exp-thread))
570 experience-matches-empathy
571 (= (worm-action-label experiences)
572 (worm-action-label empathy))]
573 (cond
574 (grand-circle? empathy) (.setText text "Grand Circle")
575 (curled? empathy) (.setText text "Curled")
576 (wiggling? empathy) (.setText text "Wiggling")
577 (resting? empathy) (.setText text "Resting")
578 :else (.setText text "Unknown"))
580 (println-repl experience-matches-empathy)
581 (swap! accuracy #(conj % experience-matches-empathy)))))))
583 (defn empathy-experiment-2 []
584 (.start (worm-world :experience-watch (compare-empathy-with-baseline
585 (atom []))
586 :record false :worm worm*)))
588 (defn accuracy [v]
589 (float (/ (count (filter true? v)) (count v))))
591 (defn test-empathy-accuracy []
592 (let [res (atom [])]
593 (run-world
594 (worm-world :experience-watch
595 (compare-empathy-with-baseline res)
596 :worm worm*))
597 (accuracy @res)))
601 (defn dylan-collect-bolts [longest-threads index-sets]
602 (fn
603 [experiences text]
604 (let [phi-indices (phi-scan (:proprioception (peek experiences)))
605 long-thread (longest-thread (vector:last-n @index-sets 300))]
606 (swap! index-sets #(conj % phi-indices))
607 (swap! longest-threads #(conj % long-thread)))))