Mercurial > cortex

annotate org/self_organizing_touch.clj @ 410:e6a7e80f885a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
refactor, fix null pointer bug.
author Robert McIntyre <rlm@mit.edu>
date Tue, 18 Mar 2014 22:29:03 -0400
parents
children a331d5ff73e0
rev   line source
rlm@410 1 (ns org.aurellem.self-organizing-touch
rlm@410 2 "Using free play to automatically organize touch perception into regions."
rlm@410 3 {:author "Robert McIntyre"}
rlm@410 4 (:use (cortex world util import body sense
rlm@410 5 hearing touch vision proprioception movement
rlm@410 6 test))
rlm@410 7 (:use [clojure set pprint])
rlm@410 8 (:import (com.jme3.math ColorRGBA Vector3f))
rlm@410 9 (:import java.io.File)
rlm@410 10 (:import com.jme3.audio.AudioNode)
rlm@410 11 (:import com.aurellem.capture.RatchetTimer)
rlm@410 12 (:import (com.aurellem.capture Capture IsoTimer))
rlm@410 13 (:import (com.jme3.math Vector3f ColorRGBA)))
rlm@410 14
rlm@410 15 (use 'org.aurellem.worm-learn)
rlm@410 16 (dorun (cortex.import/mega-import-jme3))
rlm@410 17
rlm@410 18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@410 19 ;; A demonstration of self organiging touch maps through experience. ;
rlm@410 20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@410 21
rlm@410 22 (def single-worm-segment-view
rlm@410 23 [(Vector3f. 2.0681207, -6.1406755, 1.6106138)
rlm@410 24 (Quaternion. -0.15558705, 0.843615, -0.3428654, -0.38281822)])
rlm@410 25
rlm@410 26 (def worm-single-segment-muscle-labels
rlm@410 27 [:lift-1 :lift-2 :roll-1 :roll-2])
rlm@410 28
rlm@410 29 (defn touch-kinesthetics []
rlm@410 30 [[170 :lift-1 40]
rlm@410 31 [190 :lift-1 20]
rlm@410 32 [206 :lift-1 0]
rlm@410 33
rlm@410 34 [400 :lift-2 40]
rlm@410 35 [410 :lift-2 0]
rlm@410 36
rlm@410 37 [570 :lift-2 40]
rlm@410 38 [590 :lift-2 20]
rlm@410 39 [606 :lift-2 0]
rlm@410 40
rlm@410 41 [800 :lift-1 30]
rlm@410 42 [809 :lift-1 0]
rlm@410 43
rlm@410 44 [900 :roll-2 40]
rlm@410 45 [905 :roll-2 20]
rlm@410 46 [910 :roll-2 0]
rlm@410 47
rlm@410 48 [1000 :roll-2 40]
rlm@410 49 [1005 :roll-2 20]
rlm@410 50 [1010 :roll-2 0]
rlm@410 51
rlm@410 52 [1100 :roll-2 40]
rlm@410 53 [1105 :roll-2 20]
rlm@410 54 [1110 :roll-2 0]
rlm@410 55 ])
rlm@410 56
rlm@410 57 (defn single-worm-segment []
rlm@410 58 (load-blender-model "Models/worm/worm-single-segment.blend"))
rlm@410 59
rlm@410 60 (defn worm-segment-defaults []
rlm@410 61 (let [direct-control (worm-direct-control worm-muscle-labels 40)]
rlm@410 62 (merge (worm-world-defaults)
rlm@410 63 {:worm-model single-worm-segment
rlm@410 64 :view single-worm-segment-view
rlm@410 65 :motor-control
rlm@410 66 (motor-control-program
rlm@410 67 worm-single-segment-muscle-labels
rlm@410 68 (touch-kinesthetics))
rlm@410 69 :end-frame 1200})))
rlm@410 70
rlm@410 71 (def full-contact [(float 0.0) (float 0.1)])
rlm@410 72
rlm@410 73 (defn pure-touch?
rlm@410 74 "This is worm specific code to determine if a large region of touch
rlm@410 75 sensors is either all on or all off."
rlm@410 76 [[coords touch :as touch-data]]
rlm@410 77 (= (set (map first touch)) (set full-contact)))
rlm@410 78
rlm@410 79 (defn remove-similar
rlm@410 80 [coll]
rlm@410 81 (loop [result () coll (sort-by (comp - count) coll)]
rlm@410 82 (if (empty? coll) result
rlm@410 83 (let [x (first coll)
rlm@410 84 xs (rest coll)
rlm@410 85 c (count x)]
rlm@410 86 (if (some
rlm@410 87 (fn [other-set]
rlm@410 88 (let [oc (count other-set)]
rlm@410 89 (< (- (count (union other-set x)) c) (* oc 0.1))))
rlm@410 90 xs)
rlm@410 91 (recur result xs)
rlm@410 92 (recur (cons x result) xs))))))
rlm@410 93
rlm@410 94 (defn rect-region [[x0 y0] [x1 y1]]
rlm@410 95 (vec
rlm@410 96 (for [x (range x0 (inc x1))
rlm@410 97 y (range y0 (inc y1))]
rlm@410 98 [x y])))
rlm@410 99
rlm@410 100 (def all-touch-coordinates
rlm@410 101 (concat
rlm@410 102 (rect-region [0 15] [7 22])
rlm@410 103 (rect-region [8 0] [14 29])
rlm@410 104 (rect-region [15 15] [22 22])))
rlm@410 105
rlm@410 106 (defn view-touch-region [coords]
rlm@410 107 (let [touched-region
rlm@410 108 (reduce
rlm@410 109 (fn [m k]
rlm@410 110 (assoc m k [0.0 0.1]))
rlm@410 111 (zipmap all-touch-coordinates (repeat [0.1 0.1])) coords)
rlm@410 112 data
rlm@410 113 [[(vec (keys touched-region)) (vec (vals touched-region))]]
rlm@410 114 touch-display (view-touch)]
rlm@410 115 (touch-display data)
rlm@410 116 (touch-display data)))
rlm@410 117
rlm@410 118 (defn learn-touch-regions []
rlm@410 119 (let [experiences (atom [])
rlm@410 120 world (apply-map
rlm@410 121 worm-world
rlm@410 122 (assoc (worm-segment-defaults)
rlm@410 123 :experiences experiences))]
rlm@410 124 (run-world world)
rlm@410 125 (->>
rlm@410 126 @experiences
rlm@410 127 (drop 175)
rlm@410 128 ;; access the single segment's touch data
rlm@410 129 (map (comp first :touch))
rlm@410 130 ;; only deal with "pure" touch data to determine surfaces
rlm@410 131 (filter pure-touch?)
rlm@410 132 ;; associate coordinates with touch values
rlm@410 133 (map (partial apply zipmap))
rlm@410 134 ;; select those regions where contact is being made
rlm@410 135 (map (partial group-by second))
rlm@410 136 (map #(get % full-contact))
rlm@410 137 (map (partial map first))
rlm@410 138 ;; remove redundant/subset regions
rlm@410 139 (map set)
rlm@410 140 remove-similar)))
rlm@410 141
rlm@410 142 (defn learn-and-view-touch-regions []
rlm@410 143 (map view-touch-region
rlm@410 144 (learn-touch-regions)))
rlm@410 145
rlm@410 146