Mercurial > cortex

annotate org/self_organizing_touch.clj @ 507:f2f029e1a6a9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
fixing problems with listings.
author Robert McIntyre <rlm@mit.edu>
date Sun, 30 Mar 2014 00:53:14 -0400
parents f339e3d5cc8c
children 01934317b25b
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@452 31 [190 :lift-1 19]
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@452 38 [590 :lift-2 21]
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@452 60 (defn worm-segment []
rlm@452 61 (let [model (single-worm-segment)]
rlm@452 62 {:body (doto model (body!))
rlm@452 63 :touch (touch! model)
rlm@452 64 :proprioception (proprioception! model)
rlm@452 65 :muscles (movement! model)}))
rlm@452 66
rlm@452 67
rlm@410 68 (defn worm-segment-defaults []
rlm@410 69 (let [direct-control (worm-direct-control worm-muscle-labels 40)]
rlm@410 70 (merge (worm-world-defaults)
rlm@452 71 {:worm worm-segment
rlm@410 72 :view single-worm-segment-view
rlm@430 73 :experience-watch nil
rlm@410 74 :motor-control
rlm@410 75 (motor-control-program
rlm@410 76 worm-single-segment-muscle-labels
rlm@410 77 (touch-kinesthetics))
rlm@410 78 :end-frame 1200})))
rlm@410 79
rlm@410 80 (def full-contact [(float 0.0) (float 0.1)])
rlm@410 81
rlm@410 82 (defn pure-touch?
rlm@410 83 "This is worm specific code to determine if a large region of touch
rlm@410 84 sensors is either all on or all off."
rlm@410 85 [[coords touch :as touch-data]]
rlm@410 86 (= (set (map first touch)) (set full-contact)))
rlm@410 87
rlm@410 88 (defn remove-similar
rlm@410 89 [coll]
rlm@410 90 (loop [result () coll (sort-by (comp - count) coll)]
rlm@410 91 (if (empty? coll) result
rlm@411 92 (let [[x & xs] coll
rlm@410 93 c (count x)]
rlm@410 94 (if (some
rlm@410 95 (fn [other-set]
rlm@410 96 (let [oc (count other-set)]
rlm@410 97 (< (- (count (union other-set x)) c) (* oc 0.1))))
rlm@410 98 xs)
rlm@410 99 (recur result xs)
rlm@410 100 (recur (cons x result) xs))))))
rlm@410 101
rlm@410 102 (def all-touch-coordinates
rlm@410 103 (concat
rlm@410 104 (rect-region [0 15] [7 22])
rlm@410 105 (rect-region [8 0] [14 29])
rlm@410 106 (rect-region [15 15] [22 22])))
rlm@410 107
rlm@452 108 (defn view-touch-region
rlm@452 109 ([coords out]
rlm@452 110 (let [touched-region
rlm@452 111 (reduce
rlm@452 112 (fn [m k]
rlm@452 113 (assoc m k [0.0 0.1]))
rlm@452 114 (zipmap all-touch-coordinates (repeat [0.1 0.1])) coords)
rlm@452 115 data
rlm@452 116 [[(vec (keys touched-region)) (vec (vals touched-region))]]
rlm@452 117 touch-display (view-touch)]
rlm@452 118 (touch-display data out)))
rlm@452 119 ([coords] (view-touch-region nil)))
rlm@452 120
rlm@410 121
rlm@410 122 (defn learn-touch-regions []
rlm@410 123 (let [experiences (atom [])
rlm@410 124 world (apply-map
rlm@410 125 worm-world
rlm@410 126 (assoc (worm-segment-defaults)
rlm@452 127 :experiences experiences
rlm@452 128 :record (File. "/home/r/proj/cortex/thesis/video/touch-learn-2/")))]
rlm@410 129 (run-world world)
rlm@410 130 (->>
rlm@410 131 @experiences
rlm@410 132 (drop 175)
rlm@410 133 ;; access the single segment's touch data
rlm@410 134 (map (comp first :touch))
rlm@410 135 ;; only deal with "pure" touch data to determine surfaces
rlm@410 136 (filter pure-touch?)
rlm@410 137 ;; associate coordinates with touch values
rlm@410 138 (map (partial apply zipmap))
rlm@410 139 ;; select those regions where contact is being made
rlm@410 140 (map (partial group-by second))
rlm@410 141 (map #(get % full-contact))
rlm@410 142 (map (partial map first))
rlm@410 143 ;; remove redundant/subset regions
rlm@410 144 (map set)
rlm@410 145 remove-similar)))
rlm@410 146
rlm@452 147
rlm@452 148 (def all-touch-coordinates
rlm@452 149 (concat
rlm@452 150 (rect-region [0 15] [7 22])
rlm@452 151 (rect-region [8 0] [14 29])
rlm@452 152 (rect-region [15 15] [22 22])))
rlm@452 153
rlm@452 154 (defn view-touch-region [coords]
rlm@452 155 (let [touched-region
rlm@452 156 (reduce
rlm@452 157 (fn [m k]
rlm@452 158 (assoc m k [0.0 0.1]))
rlm@452 159 (zipmap all-touch-coordinates (repeat [0.1 0.1])) coords)
rlm@452 160 data
rlm@452 161 [[(vec (keys touched-region)) (vec (vals touched-region))]]
rlm@452 162 touch-display (view-touch)]
rlm@452 163 (dorun (repeatedly 5 #(touch-display data)))))
rlm@452 164
rlm@410 165 (defn learn-and-view-touch-regions []
rlm@410 166 (map view-touch-region
rlm@410 167 (learn-touch-regions)))
rlm@410 168
rlm@410 169