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 +

     2.1 --- a/org/worm_learn.clj	Tue Mar 18 21:44:15 2014 -0400
     2.2 +++ b/org/worm_learn.clj	Tue Mar 18 22:29:03 2014 -0400
     2.3 @@ -196,9 +196,8 @@
     2.4       :worm-model worm-model
     2.5       :end-frame nil}))
     2.6  
     2.7 -
     2.8  (defn dir! [file]
     2.9 -  (if (not (.exists file))
    2.10 +  (if-not (.exists file)
    2.11      (.mkdir file))
    2.12    file)
    2.13  
    2.14 @@ -238,7 +237,7 @@
    2.15           (speed-up world)
    2.16           (light-up-everything world))
    2.17         (fn [world tpf]
    2.18 -         (if (> (.getTime timer) end-frame)
    2.19 +         (if (and end-frame (> (.getTime timer) end-frame))
    2.20             (.stop world))
    2.21           (let [muscle-data (motor-control muscles)
    2.22                 proprioception-data (prop)
    2.23 @@ -266,130 +265,4 @@
    2.24              (if record (dir! (File. record "touch")))))))))
    2.25  
    2.26  
    2.27 -;; A demonstration of self organiging touch maps through experience. 
    2.28  
    2.29 -(def single-worm-segment-view
    2.30 -  [(Vector3f. 2.0681207, -6.1406755, 1.6106138)
    2.31 -   (Quaternion. -0.15558705, 0.843615, -0.3428654, -0.38281822)])
    2.32 -
    2.33 -(def worm-single-segment-muscle-labels
    2.34 -  [:lift-1 :lift-2 :roll-1 :roll-2])
    2.35 -
    2.36 -(defn touch-kinesthetics []
    2.37 -  [[170 :lift-1 40]
    2.38 -   [190 :lift-1 20]
    2.39 -   [206 :lift-1  0]
    2.40 -
    2.41 -   [400 :lift-2 40]
    2.42 -   [410 :lift-2  0]
    2.43 -
    2.44 -   [570 :lift-2 40]
    2.45 -   [590 :lift-2 20]
    2.46 -   [606 :lift-2  0]
    2.47 -
    2.48 -   [800 :lift-1 30]
    2.49 -   [809 :lift-1 0]
    2.50 -
    2.51 -   [900 :roll-2 40]
    2.52 -   [905 :roll-2 20]
    2.53 -   [910 :roll-2  0]
    2.54 -
    2.55 -   [1000 :roll-2 40]
    2.56 -   [1005 :roll-2 20]
    2.57 -   [1010 :roll-2  0]
    2.58 -   
    2.59 -   [1100 :roll-2 40]
    2.60 -   [1105 :roll-2 20]
    2.61 -   [1110 :roll-2  0]
    2.62 -   ])
    2.63 -
    2.64 -(defn single-worm-segment []
    2.65 -  (load-blender-model "Models/worm/worm-single-segment.blend"))
    2.66 -
    2.67 -(defn worm-segment-defaults []
    2.68 -  (let [direct-control (worm-direct-control worm-muscle-labels 40)]
    2.69 -    (merge (worm-world-defaults)
    2.70 -           {:worm-model single-worm-segment
    2.71 -            :view single-worm-segment-view
    2.72 -            :motor-control
    2.73 -            (motor-control-program
    2.74 -             worm-single-segment-muscle-labels
    2.75 -             (touch-kinesthetics))
    2.76 -            :end-frame 1200})))
    2.77 -
    2.78 -(def full-contact [(float 0.0) (float 0.1)])
    2.79 -
    2.80 -(defn pure-touch?
    2.81 -  "This is worm specific code to determine if a large region of touch
    2.82 -   sensors is either all on or all off."
    2.83 -  [[coords touch :as touch-data]]
    2.84 -  (= (set (map first touch)) (set full-contact)))
    2.85 -
    2.86 -(defn remove-similar
    2.87 -  [coll]
    2.88 -  (loop [result () coll (sort-by (comp - count) coll)]
    2.89 -    (if (empty? coll) result
    2.90 -        (let  [x  (first coll)
    2.91 -               xs (rest coll)
    2.92 -               c (count x)]
    2.93 -          (if (some
    2.94 -               (fn [other-set]
    2.95 -                 (let [oc (count other-set)]
    2.96 -                   (< (- (count (union other-set x)) c) (* oc 0.1))))
    2.97 -               xs)
    2.98 -            (recur result xs)
    2.99 -            (recur (cons x result) xs))))))
   2.100 -
   2.101 -
   2.102 -(defn rect-region [[x0 y0] [x1 y1]]
   2.103 -  (vec
   2.104 -   (for [x (range x0 (inc x1))
   2.105 -         y (range y0 (inc y1))]
   2.106 -     [x y])))
   2.107 -
   2.108 -(def all-touch-coordinates
   2.109 -  (concat
   2.110 -   (rect-region [0  15] [7  22])
   2.111 -   (rect-region [8   0] [14 29])
   2.112 -   (rect-region [15 15] [22 22])))
   2.113 -
   2.114 -(defn view-touch-region [coords]
   2.115 -  (let [touched-region
   2.116 -        (reduce
   2.117 -         (fn [m k]
   2.118 -           (assoc m k [0.0 0.1]))
   2.119 -         (zipmap all-touch-coordinates (repeat [0.1 0.1])) coords)
   2.120 -        data
   2.121 -        [[(vec (keys touched-region)) (vec (vals touched-region))]]
   2.122 -        touch-display (view-touch)]
   2.123 -    (touch-display data)
   2.124 -    (touch-display data)))
   2.125 -
   2.126 -(defn learn-touch-regions []
   2.127 -  (let [experiences (atom [])
   2.128 -        world (apply-map
   2.129 -               worm-world
   2.130 -               (assoc (worm-segment-defaults)
   2.131 -                 :experiences experiences))]
   2.132 -    (run-world world)
   2.133 -    (->>
   2.134 -     @experiences
   2.135 -     (drop 175)
   2.136 -     ;; access the single segment's touch data
   2.137 -     (map (comp first :touch))
   2.138 -     ;; only deal with "pure" touch data to determine surfaces
   2.139 -     (filter pure-touch?)
   2.140 -     ;; associate coordinates with touch values
   2.141 -     (map (partial apply zipmap))
   2.142 -     ;; select those regions where contact is being made
   2.143 -     (map (partial group-by second))
   2.144 -     (map #(get % full-contact))
   2.145 -     (map (partial map first))
   2.146 -     ;; remove redundant/subset regions
   2.147 -     (map set)
   2.148 -     remove-similar)))
   2.149 -
   2.150 -(defn learn-and-view-touch-regions []
   2.151 -  (map view-touch-region
   2.152 -       (learn-touch-regions)))
   2.153 -