1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/org/self_organizing_touch.clj	Thu Mar 27 17:57:01 2014 -0400
     1.3 @@ -0,0 +1,169 @@
     1.4 +(ns org.aurellem.self-organizing-touch
     1.5 +  "Using free play to automatically organize touch perception into regions."
     1.6 +  {:author "Robert McIntyre"}
     1.7 +  (:use (cortex world util import body sense
     1.8 +                hearing touch vision proprioception movement
     1.9 +                test))
    1.10 +  (:use [clojure set pprint])
    1.11 +  (:import (com.jme3.math ColorRGBA Vector3f))
    1.12 +  (:import java.io.File)
    1.13 +  (:import com.jme3.audio.AudioNode)
    1.14 +  (:import com.aurellem.capture.RatchetTimer)
    1.15 +  (:import (com.aurellem.capture Capture IsoTimer))
    1.16 +  (:import (com.jme3.math Vector3f ColorRGBA)))
    1.17 +
    1.18 +(use 'org.aurellem.worm-learn)
    1.19 +(dorun (cortex.import/mega-import-jme3))
    1.20 +
    1.21 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.22 +;; A demonstration of self organiging touch maps through experience. ;
    1.23 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.24 +
    1.25 +(def single-worm-segment-view
    1.26 +  [(Vector3f. 2.0681207, -6.1406755, 1.6106138)
    1.27 +   (Quaternion. -0.15558705, 0.843615, -0.3428654, -0.38281822)])
    1.28 +
    1.29 +(def worm-single-segment-muscle-labels
    1.30 +  [:lift-1 :lift-2 :roll-1 :roll-2])
    1.31 +
    1.32 +(defn touch-kinesthetics []
    1.33 +  [[170 :lift-1 40]
    1.34 +   [190 :lift-1 19]
    1.35 +   [206 :lift-1  0]
    1.36 +
    1.37 +   [400 :lift-2 40]
    1.38 +   [410 :lift-2  0]
    1.39 +
    1.40 +   [570 :lift-2 40]
    1.41 +   [590 :lift-2 21]
    1.42 +   [606 :lift-2  0]
    1.43 +
    1.44 +   [800 :lift-1 30]
    1.45 +   [809 :lift-1 0]
    1.46 +
    1.47 +   [900 :roll-2 40]
    1.48 +   [905 :roll-2 20]
    1.49 +   [910 :roll-2  0]
    1.50 +
    1.51 +   [1000 :roll-2 40]
    1.52 +   [1005 :roll-2 20]
    1.53 +   [1010 :roll-2  0]
    1.54 +   
    1.55 +   [1100 :roll-2 40]
    1.56 +   [1105 :roll-2 20]
    1.57 +   [1110 :roll-2  0]
    1.58 +   ])
    1.59 +
    1.60 +(defn single-worm-segment []
    1.61 +  (load-blender-model "Models/worm/worm-single-segment.blend"))
    1.62 +
    1.63 +(defn worm-segment []
    1.64 +  (let [model (single-worm-segment)]
    1.65 +    {:body (doto model (body!))
    1.66 +     :touch (touch! model)
    1.67 +     :proprioception (proprioception! model)
    1.68 +     :muscles (movement! model)}))
    1.69 +
    1.70 +
    1.71 +(defn worm-segment-defaults []
    1.72 +  (let [direct-control (worm-direct-control worm-muscle-labels 40)]
    1.73 +    (merge (worm-world-defaults)
    1.74 +           {:worm worm-segment
    1.75 +            :view single-worm-segment-view
    1.76 +            :experience-watch nil
    1.77 +            :motor-control
    1.78 +            (motor-control-program
    1.79 +             worm-single-segment-muscle-labels
    1.80 +             (touch-kinesthetics))
    1.81 +            :end-frame 1200})))
    1.82 +
    1.83 +(def full-contact [(float 0.0) (float 0.1)])
    1.84 +
    1.85 +(defn pure-touch?
    1.86 +  "This is worm specific code to determine if a large region of touch
    1.87 +   sensors is either all on or all off."
    1.88 +  [[coords touch :as touch-data]]
    1.89 +  (= (set (map first touch)) (set full-contact)))
    1.90 +
    1.91 +(defn remove-similar
    1.92 +  [coll]
    1.93 +  (loop [result () coll (sort-by (comp - count) coll)]
    1.94 +    (if (empty? coll) result
    1.95 +        (let  [[x & xs] coll
    1.96 +               c (count x)]
    1.97 +          (if (some
    1.98 +               (fn [other-set]
    1.99 +                 (let [oc (count other-set)]
   1.100 +                   (< (- (count (union other-set x)) c) (* oc 0.1))))
   1.101 +               xs)
   1.102 +            (recur result xs)
   1.103 +            (recur (cons x result) xs))))))
   1.104 +
   1.105 +(def all-touch-coordinates
   1.106 +  (concat
   1.107 +   (rect-region [0  15] [7  22])
   1.108 +   (rect-region [8   0] [14 29])
   1.109 +   (rect-region [15 15] [22 22])))
   1.110 +
   1.111 +(defn view-touch-region
   1.112 +  ([coords out]
   1.113 +     (let [touched-region
   1.114 +           (reduce
   1.115 +            (fn [m k]
   1.116 +              (assoc m k [0.0 0.1]))
   1.117 +            (zipmap all-touch-coordinates (repeat [0.1 0.1])) coords)
   1.118 +           data
   1.119 +           [[(vec (keys touched-region)) (vec (vals touched-region))]]
   1.120 +           touch-display (view-touch)]
   1.121 +       (touch-display data out)))
   1.122 +  ([coords] (view-touch-region nil)))
   1.123 +
   1.124 +
   1.125 +(defn learn-touch-regions []
   1.126 +  (let [experiences (atom [])
   1.127 +        world (apply-map
   1.128 +               worm-world
   1.129 +               (assoc (worm-segment-defaults)
   1.130 +                 :experiences experiences
   1.131 +                 :record (File. "/home/r/proj/cortex/thesis/video/touch-learn-2/")))]
   1.132 +    (run-world world)
   1.133 +    (->>
   1.134 +     @experiences
   1.135 +     (drop 175)
   1.136 +     ;; access the single segment's touch data
   1.137 +     (map (comp first :touch))
   1.138 +     ;; only deal with "pure" touch data to determine surfaces
   1.139 +     (filter pure-touch?)
   1.140 +     ;; associate coordinates with touch values
   1.141 +     (map (partial apply zipmap))
   1.142 +     ;; select those regions where contact is being made
   1.143 +     (map (partial group-by second))
   1.144 +     (map #(get % full-contact))
   1.145 +     (map (partial map first))
   1.146 +     ;; remove redundant/subset regions
   1.147 +     (map set)
   1.148 +     remove-similar)))
   1.149 +
   1.150 +
   1.151 +(def all-touch-coordinates
   1.152 +  (concat
   1.153 +   (rect-region [0  15] [7  22])
   1.154 +   (rect-region [8   0] [14 29])
   1.155 +   (rect-region [15 15] [22 22])))
   1.156 +
   1.157 +(defn view-touch-region [coords]
   1.158 +  (let [touched-region
   1.159 +        (reduce
   1.160 +         (fn [m k]
   1.161 +           (assoc m k [0.0 0.1]))
   1.162 +         (zipmap all-touch-coordinates (repeat [0.1 0.1])) coords)
   1.163 +        data
   1.164 +        [[(vec (keys touched-region)) (vec (vals touched-region))]]
   1.165 +        touch-display (view-touch)]
   1.166 +    (dorun (repeatedly 5 #(touch-display data)))))
   1.167 +
   1.168 +(defn learn-and-view-touch-regions []
   1.169 +  (map view-touch-region
   1.170 +       (learn-touch-regions)))
   1.171 +
   1.172 +