1.1 --- a/org/worm_learn.clj	Tue Mar 18 19:53:42 2014 -0400
     1.2 +++ b/org/worm_learn.clj	Tue Mar 18 21:28:04 2014 -0400
     1.3 @@ -2,7 +2,8 @@
     1.4    "General worm creation framework."
     1.5    {:author "Robert McIntyre"}
     1.6    (:use (cortex world util import body sense
     1.7 -                hearing touch vision proprioception movement))
     1.8 +                hearing touch vision proprioception movement
     1.9 +                test))
    1.10    (:import (com.jme3.math ColorRGBA Vector3f))
    1.11    (:import java.io.File)
    1.12    (:import com.jme3.audio.AudioNode)
    1.13 @@ -11,7 +12,7 @@
    1.14    (:import (com.jme3.math Vector3f ColorRGBA)))
    1.15  
    1.16  (use 'clojure.pprint)
    1.17 -
    1.18 +(use 'clojure.set)
    1.19  (dorun (cortex.import/mega-import-jme3))
    1.20  (rlm.rlm-commands/help)
    1.21  
    1.22 @@ -247,7 +248,7 @@
    1.23                experiences {:touch touch-data
    1.24                             :proprioception proprioception-data
    1.25                             :muscle muscle-data})
    1.26 -             (if (curled? @experiences) (println "Curled"))
    1.27 +             ;;(if (curled? @experiences) (println "Curled"))
    1.28               ;;(if (straight? @experiences)    (println "Straight"))
    1.29               ;; (println-repl
    1.30               ;;  (apply format "%.2f %.2f %.2f %.2f %.2f\n"
    1.31 @@ -286,7 +287,7 @@
    1.32     [590 :lift-2 20]
    1.33     [606 :lift-2  0]
    1.34  
    1.35 -   [800 :lift-1 40]
    1.36 +   [800 :lift-1 30]
    1.37     [809 :lift-1 0]
    1.38  
    1.39     [900 :roll-2 40]
    1.40 @@ -302,6 +303,9 @@
    1.41     [1110 :roll-2  0]
    1.42     ])
    1.43  
    1.44 +(defn single-worm-segment []
    1.45 +  (load-blender-model "Models/worm/worm-single-segment.blend"))
    1.46 +
    1.47  (defn worm-segment-defaults []
    1.48    (let [direct-control (worm-direct-control worm-muscle-labels 40)]
    1.49      (merge (worm-world-defaults)
    1.50 @@ -310,14 +314,82 @@
    1.51              :motor-control
    1.52              (motor-control-program
    1.53               worm-single-segment-muscle-labels
    1.54 -             (touch-kinesthetics))})))
    1.55 +             (touch-kinesthetics))
    1.56 +            :end-frame 1200})))
    1.57  
    1.58 -(defn single-worm-segment []
    1.59 -  (load-blender-model "Models/worm/worm-single-segment.blend"))
    1.60 -
    1.61 +(def full-contact [(float 0.0) (float 0.1)])
    1.62  
    1.63  (defn pure-touch?
    1.64    "This is worm specific code to determine if a large region of touch
    1.65     sensors is either all on or all off."
    1.66    [[coords touch :as touch-data]]
    1.67 -  (= (set (map first touch)) #{(float 0.1)  (float 0.0)}))
    1.68 \ No newline at end of file
    1.69 +  (= (set (map first touch)) (set full-contact)))
    1.70 +
    1.71 +(defn remove-similar
    1.72 +  [coll]
    1.73 +  (loop [result () coll (sort-by (comp - count) coll)]
    1.74 +    (if (empty? coll) result
    1.75 +        (let  [x  (first coll)
    1.76 +               xs (rest coll)
    1.77 +               c (count x)]
    1.78 +          (if (some
    1.79 +               (fn [other-set]
    1.80 +                 (let [oc (count other-set)]
    1.81 +                   (< (- (count (union other-set x)) c) (* oc 0.1))))
    1.82 +               xs)
    1.83 +            (recur result xs)
    1.84 +            (recur (cons x result) xs))))))
    1.85 +
    1.86 +
    1.87 +(defn rect-region [[x0 y0] [x1 y1]]
    1.88 +  (vec
    1.89 +   (for [x (range x0 (inc x1))
    1.90 +         y (range y0 (inc y1))]
    1.91 +     [x y])))
    1.92 +
    1.93 +(def all-touch-coordinates
    1.94 +  (concat
    1.95 +   (rect-region [0  15] [7  22])
    1.96 +   (rect-region [8   0] [14 29])
    1.97 +   (rect-region [15 15] [22 22])))
    1.98 +
    1.99 +(defn view-touch-region [coords]
   1.100 +  (let [touched-region
   1.101 +        (reduce
   1.102 +         (fn [m k]
   1.103 +           (assoc m k [0.0 0.1]))
   1.104 +         (zipmap all-touch-coordinates (repeat [0.1 0.1])) coords)
   1.105 +        data
   1.106 +        [[(vec (keys touched-region)) (vec (vals touched-region))]]
   1.107 +        touch-display (view-touch)]
   1.108 +    (touch-display data)
   1.109 +    (touch-display data)))
   1.110 +
   1.111 +(defn learn-touch-regions []
   1.112 +  (let [experiences (atom [])
   1.113 +        world (apply-map
   1.114 +               worm-world
   1.115 +               (assoc (worm-segment-defaults)
   1.116 +                 :experiences experiences))]
   1.117 +    (run-world world)
   1.118 +    (->>
   1.119 +     @experiences
   1.120 +     (drop 175)
   1.121 +     ;; access the single segment's touch data
   1.122 +     (map (comp first :touch))
   1.123 +     ;; only deal with "pure" touch data to determine surfaces
   1.124 +     (filter pure-touch?)
   1.125 +     ;; associate coordinates with touch values
   1.126 +     (map (partial apply zipmap))
   1.127 +     ;; select those regions where contact is being made
   1.128 +     (map (partial group-by second))
   1.129 +     (map #(get % full-contact))
   1.130 +     (map (partial map first))
   1.131 +     ;; remove redundant/subset regions
   1.132 +     (map set)
   1.133 +     remove-similar)))
   1.134 +
   1.135 +(defn learn-and-view-touch-regions []
   1.136 +  (map view-touch-region
   1.137 +       (learn-touch-regions)))
   1.138 +