rlm@410: (ns org.aurellem.self-organizing-touch
rlm@410:   "Using free play to automatically organize touch perception into regions."
rlm@410:   {:author "Robert McIntyre"}
rlm@410:   (:use (cortex world util import body sense
rlm@410:                 hearing touch vision proprioception movement
rlm@410:                 test))
rlm@410:   (:use [clojure set pprint])
rlm@410:   (:import (com.jme3.math ColorRGBA Vector3f))
rlm@410:   (:import java.io.File)
rlm@410:   (:import com.jme3.audio.AudioNode)
rlm@410:   (:import com.aurellem.capture.RatchetTimer)
rlm@410:   (:import (com.aurellem.capture Capture IsoTimer))
rlm@410:   (:import (com.jme3.math Vector3f ColorRGBA)))
rlm@410: 
rlm@410: (use 'org.aurellem.worm-learn)
rlm@410: (dorun (cortex.import/mega-import-jme3))
rlm@410: 
rlm@410: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@410: ;; A demonstration of self organiging touch maps through experience. ;
rlm@410: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@410: 
rlm@410: (def single-worm-segment-view
rlm@410:   [(Vector3f. 2.0681207, -6.1406755, 1.6106138)
rlm@410:    (Quaternion. -0.15558705, 0.843615, -0.3428654, -0.38281822)])
rlm@410: 
rlm@410: (def worm-single-segment-muscle-labels
rlm@410:   [:lift-1 :lift-2 :roll-1 :roll-2])
rlm@410: 
rlm@410: (defn touch-kinesthetics []
rlm@410:   [[170 :lift-1 40]
rlm@452:    [190 :lift-1 19]
rlm@410:    [206 :lift-1  0]
rlm@410: 
rlm@410:    [400 :lift-2 40]
rlm@410:    [410 :lift-2  0]
rlm@410: 
rlm@410:    [570 :lift-2 40]
rlm@452:    [590 :lift-2 21]
rlm@410:    [606 :lift-2  0]
rlm@410: 
rlm@410:    [800 :lift-1 30]
rlm@410:    [809 :lift-1 0]
rlm@410: 
rlm@410:    [900 :roll-2 40]
rlm@410:    [905 :roll-2 20]
rlm@410:    [910 :roll-2  0]
rlm@410: 
rlm@410:    [1000 :roll-2 40]
rlm@410:    [1005 :roll-2 20]
rlm@410:    [1010 :roll-2  0]
rlm@410:    
rlm@410:    [1100 :roll-2 40]
rlm@410:    [1105 :roll-2 20]
rlm@410:    [1110 :roll-2  0]
rlm@410:    ])
rlm@410: 
rlm@410: (defn single-worm-segment []
rlm@410:   (load-blender-model "Models/worm/worm-single-segment.blend"))
rlm@410: 
rlm@452: (defn worm-segment []
rlm@452:   (let [model (single-worm-segment)]
rlm@452:     {:body (doto model (body!))
rlm@452:      :touch (touch! model)
rlm@452:      :proprioception (proprioception! model)
rlm@452:      :muscles (movement! model)}))
rlm@452: 
rlm@452: 
rlm@410: (defn worm-segment-defaults []
rlm@410:   (let [direct-control (worm-direct-control worm-muscle-labels 40)]
rlm@410:     (merge (worm-world-defaults)
rlm@452:            {:worm worm-segment
rlm@410:             :view single-worm-segment-view
rlm@430:             :experience-watch nil
rlm@410:             :motor-control
rlm@410:             (motor-control-program
rlm@410:              worm-single-segment-muscle-labels
rlm@410:              (touch-kinesthetics))
rlm@410:             :end-frame 1200})))
rlm@410: 
rlm@410: (def full-contact [(float 0.0) (float 0.1)])
rlm@410: 
rlm@410: (defn pure-touch?
rlm@410:   "This is worm specific code to determine if a large region of touch
rlm@410:    sensors is either all on or all off."
rlm@410:   [[coords touch :as touch-data]]
rlm@410:   (= (set (map first touch)) (set full-contact)))
rlm@410: 
rlm@410: (defn remove-similar
rlm@410:   [coll]
rlm@410:   (loop [result () coll (sort-by (comp - count) coll)]
rlm@410:     (if (empty? coll) result
rlm@411:         (let  [[x & xs] coll
rlm@410:                c (count x)]
rlm@410:           (if (some
rlm@410:                (fn [other-set]
rlm@410:                  (let [oc (count other-set)]
rlm@410:                    (< (- (count (union other-set x)) c) (* oc 0.1))))
rlm@410:                xs)
rlm@410:             (recur result xs)
rlm@410:             (recur (cons x result) xs))))))
rlm@410: 
rlm@410: (def all-touch-coordinates
rlm@410:   (concat
rlm@410:    (rect-region [0  15] [7  22])
rlm@410:    (rect-region [8   0] [14 29])
rlm@410:    (rect-region [15 15] [22 22])))
rlm@410: 
rlm@452: (defn view-touch-region
rlm@452:   ([coords out]
rlm@452:      (let [touched-region
rlm@452:            (reduce
rlm@452:             (fn [m k]
rlm@452:               (assoc m k [0.0 0.1]))
rlm@452:             (zipmap all-touch-coordinates (repeat [0.1 0.1])) coords)
rlm@452:            data
rlm@452:            [[(vec (keys touched-region)) (vec (vals touched-region))]]
rlm@452:            touch-display (view-touch)]
rlm@452:        (touch-display data out)))
rlm@452:   ([coords] (view-touch-region nil)))
rlm@452: 
rlm@410: 
rlm@410: (defn learn-touch-regions []
rlm@410:   (let [experiences (atom [])
rlm@410:         world (apply-map
rlm@410:                worm-world
rlm@410:                (assoc (worm-segment-defaults)
rlm@452:                  :experiences experiences
rlm@526:                  :record false
rlm@526:                  ;;(File. "/home/r/proj/cortex/thesis/video/touch-learn-2/")
rlm@526:                  ))]
rlm@410:     (run-world world)
rlm@410:     (->>
rlm@410:      @experiences
rlm@410:      (drop 175)
rlm@410:      ;; access the single segment's touch data
rlm@410:      (map (comp first :touch))
rlm@410:      ;; only deal with "pure" touch data to determine surfaces
rlm@410:      (filter pure-touch?)
rlm@410:      ;; associate coordinates with touch values
rlm@410:      (map (partial apply zipmap))
rlm@410:      ;; select those regions where contact is being made
rlm@410:      (map (partial group-by second))
rlm@410:      (map #(get % full-contact))
rlm@410:      (map (partial map first))
rlm@410:      ;; remove redundant/subset regions
rlm@410:      (map set)
rlm@410:      remove-similar)))
rlm@410: 
rlm@452: 
rlm@452: (def all-touch-coordinates
rlm@452:   (concat
rlm@452:    (rect-region [0  15] [7  22])
rlm@452:    (rect-region [8   0] [14 29])
rlm@452:    (rect-region [15 15] [22 22])))
rlm@452: 
rlm@452: (defn view-touch-region [coords]
rlm@452:   (let [touched-region
rlm@452:         (reduce
rlm@452:          (fn [m k]
rlm@452:            (assoc m k [0.0 0.1]))
rlm@452:          (zipmap all-touch-coordinates (repeat [0.1 0.1])) coords)
rlm@452:         data
rlm@452:         [[(vec (keys touched-region)) (vec (vals touched-region))]]
rlm@452:         touch-display (view-touch)]
rlm@452:     (dorun (repeatedly 5 #(touch-display data)))))
rlm@452: 
rlm@410: (defn learn-and-view-touch-regions []
rlm@410:   (map view-touch-region
rlm@410:        (learn-touch-regions)))
rlm@410: 
rlm@410: