1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/org/self_organizing_touch.clj	Tue Mar 18 22:29:03 2014 -0400
     1.3 @@ -0,0 +1,146 @@
     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 20]
    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 20]
    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-defaults []
    1.64 +  (let [direct-control (worm-direct-control worm-muscle-labels 40)]
    1.65 +    (merge (worm-world-defaults)
    1.66 +           {:worm-model single-worm-segment
    1.67 +            :view single-worm-segment-view
    1.68 +            :motor-control
    1.69 +            (motor-control-program
    1.70 +             worm-single-segment-muscle-labels
    1.71 +             (touch-kinesthetics))
    1.72 +            :end-frame 1200})))
    1.73 +
    1.74 +(def full-contact [(float 0.0) (float 0.1)])
    1.75 +
    1.76 +(defn pure-touch?
    1.77 +  "This is worm specific code to determine if a large region of touch
    1.78 +   sensors is either all on or all off."
    1.79 +  [[coords touch :as touch-data]]
    1.80 +  (= (set (map first touch)) (set full-contact)))
    1.81 +
    1.82 +(defn remove-similar
    1.83 +  [coll]
    1.84 +  (loop [result () coll (sort-by (comp - count) coll)]
    1.85 +    (if (empty? coll) result
    1.86 +        (let  [x  (first coll)
    1.87 +               xs (rest coll)
    1.88 +               c (count x)]
    1.89 +          (if (some
    1.90 +               (fn [other-set]
    1.91 +                 (let [oc (count other-set)]
    1.92 +                   (< (- (count (union other-set x)) c) (* oc 0.1))))
    1.93 +               xs)
    1.94 +            (recur result xs)
    1.95 +            (recur (cons x result) xs))))))
    1.96 +
    1.97 +(defn rect-region [[x0 y0] [x1 y1]]
    1.98 +  (vec
    1.99 +   (for [x (range x0 (inc x1))
   1.100 +         y (range y0 (inc y1))]
   1.101 +     [x y])))
   1.102 +
   1.103 +(def all-touch-coordinates
   1.104 +  (concat
   1.105 +   (rect-region [0  15] [7  22])
   1.106 +   (rect-region [8   0] [14 29])
   1.107 +   (rect-region [15 15] [22 22])))
   1.108 +
   1.109 +(defn view-touch-region [coords]
   1.110 +  (let [touched-region
   1.111 +        (reduce
   1.112 +         (fn [m k]
   1.113 +           (assoc m k [0.0 0.1]))
   1.114 +         (zipmap all-touch-coordinates (repeat [0.1 0.1])) coords)
   1.115 +        data
   1.116 +        [[(vec (keys touched-region)) (vec (vals touched-region))]]
   1.117 +        touch-display (view-touch)]
   1.118 +    (touch-display data)
   1.119 +    (touch-display data)))
   1.120 +
   1.121 +(defn learn-touch-regions []
   1.122 +  (let [experiences (atom [])
   1.123 +        world (apply-map
   1.124 +               worm-world
   1.125 +               (assoc (worm-segment-defaults)
   1.126 +                 :experiences experiences))]
   1.127 +    (run-world world)
   1.128 +    (->>
   1.129 +     @experiences
   1.130 +     (drop 175)
   1.131 +     ;; access the single segment's touch data
   1.132 +     (map (comp first :touch))
   1.133 +     ;; only deal with "pure" touch data to determine surfaces
   1.134 +     (filter pure-touch?)
   1.135 +     ;; associate coordinates with touch values
   1.136 +     (map (partial apply zipmap))
   1.137 +     ;; select those regions where contact is being made
   1.138 +     (map (partial group-by second))
   1.139 +     (map #(get % full-contact))
   1.140 +     (map (partial map first))
   1.141 +     ;; remove redundant/subset regions
   1.142 +     (map set)
   1.143 +     remove-similar)))
   1.144 +
   1.145 +(defn learn-and-view-touch-regions []
   1.146 +  (map view-touch-region
   1.147 +       (learn-touch-regions)))
   1.148 +
   1.149 +