# HG changeset patch
# User Robert McIntyre <rlm@mit.edu>
# Date 1395192484 14400
# Node ID 3b4012b426114503f57d4ef6c8e62563ae428ce4
# Parent  bd6d03596ea8312a6bd6e9e90ec91074df0fa97a
completed demonstration showing automatic partitioning of touch space based on experience.

diff -r bd6d03596ea8 -r 3b4012b42611 org/worm_learn.clj
--- a/org/worm_learn.clj	Tue Mar 18 19:53:42 2014 -0400
+++ b/org/worm_learn.clj	Tue Mar 18 21:28:04 2014 -0400
@@ -2,7 +2,8 @@
   "General worm creation framework."
   {:author "Robert McIntyre"}
   (:use (cortex world util import body sense
-                hearing touch vision proprioception movement))
+                hearing touch vision proprioception movement
+                test))
   (:import (com.jme3.math ColorRGBA Vector3f))
   (:import java.io.File)
   (:import com.jme3.audio.AudioNode)
@@ -11,7 +12,7 @@
   (:import (com.jme3.math Vector3f ColorRGBA)))
 
 (use 'clojure.pprint)
-
+(use 'clojure.set)
 (dorun (cortex.import/mega-import-jme3))
 (rlm.rlm-commands/help)
 
@@ -247,7 +248,7 @@
               experiences {:touch touch-data
                            :proprioception proprioception-data
                            :muscle muscle-data})
-             (if (curled? @experiences) (println "Curled"))
+             ;;(if (curled? @experiences) (println "Curled"))
              ;;(if (straight? @experiences)    (println "Straight"))
              ;; (println-repl
              ;;  (apply format "%.2f %.2f %.2f %.2f %.2f\n"
@@ -286,7 +287,7 @@
    [590 :lift-2 20]
    [606 :lift-2  0]
 
-   [800 :lift-1 40]
+   [800 :lift-1 30]
    [809 :lift-1 0]
 
    [900 :roll-2 40]
@@ -302,6 +303,9 @@
    [1110 :roll-2  0]
    ])
 
+(defn single-worm-segment []
+  (load-blender-model "Models/worm/worm-single-segment.blend"))
+
 (defn worm-segment-defaults []
   (let [direct-control (worm-direct-control worm-muscle-labels 40)]
     (merge (worm-world-defaults)
@@ -310,14 +314,82 @@
             :motor-control
             (motor-control-program
              worm-single-segment-muscle-labels
-             (touch-kinesthetics))})))
+             (touch-kinesthetics))
+            :end-frame 1200})))
 
-(defn single-worm-segment []
-  (load-blender-model "Models/worm/worm-single-segment.blend"))
-
+(def full-contact [(float 0.0) (float 0.1)])
 
 (defn pure-touch?
   "This is worm specific code to determine if a large region of touch
    sensors is either all on or all off."
   [[coords touch :as touch-data]]
-  (= (set (map first touch)) #{(float 0.1)  (float 0.0)}))
\ No newline at end of file
+  (= (set (map first touch)) (set full-contact)))
+
+(defn remove-similar
+  [coll]
+  (loop [result () coll (sort-by (comp - count) coll)]
+    (if (empty? coll) result
+        (let  [x  (first coll)
+               xs (rest coll)
+               c (count x)]
+          (if (some
+               (fn [other-set]
+                 (let [oc (count other-set)]
+                   (< (- (count (union other-set x)) c) (* oc 0.1))))
+               xs)
+            (recur result xs)
+            (recur (cons x result) xs))))))
+
+
+(defn rect-region [[x0 y0] [x1 y1]]
+  (vec
+   (for [x (range x0 (inc x1))
+         y (range y0 (inc y1))]
+     [x y])))
+
+(def all-touch-coordinates
+  (concat
+   (rect-region [0  15] [7  22])
+   (rect-region [8   0] [14 29])
+   (rect-region [15 15] [22 22])))
+
+(defn view-touch-region [coords]
+  (let [touched-region
+        (reduce
+         (fn [m k]
+           (assoc m k [0.0 0.1]))
+         (zipmap all-touch-coordinates (repeat [0.1 0.1])) coords)
+        data
+        [[(vec (keys touched-region)) (vec (vals touched-region))]]
+        touch-display (view-touch)]
+    (touch-display data)
+    (touch-display data)))
+
+(defn learn-touch-regions []
+  (let [experiences (atom [])
+        world (apply-map
+               worm-world
+               (assoc (worm-segment-defaults)
+                 :experiences experiences))]
+    (run-world world)
+    (->>
+     @experiences
+     (drop 175)
+     ;; access the single segment's touch data
+     (map (comp first :touch))
+     ;; only deal with "pure" touch data to determine surfaces
+     (filter pure-touch?)
+     ;; associate coordinates with touch values
+     (map (partial apply zipmap))
+     ;; select those regions where contact is being made
+     (map (partial group-by second))
+     (map #(get % full-contact))
+     (map (partial map first))
+     ;; remove redundant/subset regions
+     (map set)
+     remove-similar)))
+
+(defn learn-and-view-touch-regions []
+  (map view-touch-region
+       (learn-touch-regions)))
+