1.1 --- a/org/worm_learn.clj	Mon Apr 28 15:10:59 2014 -0400
     1.2 +++ b/org/worm_learn.clj	Thu May 01 23:41:41 2014 -0400
     1.3 @@ -20,8 +20,18 @@
     1.4  (dorun (cortex.import/mega-import-jme3))
     1.5  (rlm.rlm-commands/help)
     1.6  
     1.7 +
     1.8  (load-bullet)
     1.9  
    1.10 +(defn bin [digits]
    1.11 +  (fn [angles]
    1.12 +    (->> angles
    1.13 +         (flatten)
    1.14 +         (map (juxt #(Math/sin %) #(Math/cos %)))
    1.15 +         (flatten)
    1.16 +         (mapv #(Math/round (* % (Math/pow 10 (dec digits))))))))
    1.17 +
    1.18 +
    1.19  (def hand "Models/test-creature/hand.blend")
    1.20  
    1.21  (defn worm-model []
    1.22 @@ -162,6 +172,12 @@
    1.23           y (range y0 (inc y1))]
    1.24       [x y])))
    1.25  
    1.26 +(def all-touch-coordinates
    1.27 +  (concat
    1.28 +   (rect-region [0  15] [7  22])
    1.29 +   (rect-region [8   0] [14 29])
    1.30 +   (rect-region [15 15] [22 22])))
    1.31 +
    1.32  (def worm-segment-bottom (rect-region [8 15] [14 22]))
    1.33  
    1.34  (defn contact
    1.35 @@ -221,8 +237,6 @@
    1.36          (or (accept? (take 64 base-activity))
    1.37              (accept? (take 64 (drop 20 base-activity))))))))
    1.38  
    1.39 -
    1.40 -
    1.41  (def worm-segment-bottom-tip (rect-region [15 15] [22 22]))
    1.42  
    1.43  (def worm-segment-top-tip (rect-region [0 15] [7 22]))
    1.44 @@ -238,6 +252,36 @@
    1.45                (< 0.1 (contact worm-segment-top-tip    head-touch))))))
    1.46  
    1.47  
    1.48 +(defn draped?
    1.49 +  "Is the worm:
    1.50 +    -- not flat (the floor is not a 'chair')
    1.51 +    -- supported (not using its muscles to hold its position)
    1.52 +    -- stable (not changing its position)
    1.53 +    -- touching something (must register contact)"
    1.54 +  [experiences]
    1.55 +  (let [b2-hash (bin 2)
    1.56 +        touch (:touch (peek experiences))
    1.57 +        total-contact
    1.58 +        (reduce
    1.59 +         +
    1.60 +         (map #(contact all-touch-coordinates %)
    1.61 +              (rest touch)))]
    1.62 +    (println total-contact)
    1.63 +    (and (not (resting? experiences))
    1.64 +         (every?
    1.65 +          zero?
    1.66 +          (-> experiences
    1.67 +              (vector:last-n 25)
    1.68 +              (#(map :muscle %))
    1.69 +              (flatten)))
    1.70 +         (-> experiences
    1.71 +             (vector:last-n 20)
    1.72 +             (#(map (comp b2-hash flatten :proprioception) %))
    1.73 +             (set)
    1.74 +             (count) (= 1))
    1.75 +         (< 0.03 total-contact))))
    1.76 +
    1.77 +
    1.78  (declare phi-space phi-scan debug-experience) 
    1.79  
    1.80  
    1.81 @@ -254,6 +298,13 @@
    1.82    [(Vector3f. -0.0708936, -8.570261, 2.6487997)
    1.83     (Quaternion. -2.318909E-4, 0.9985348, 0.053941682, 0.004291452)])
    1.84  
    1.85 +(defn summon-chair
    1.86 +  "Create a chair in the world for the worm"
    1.87 +  [world]
    1.88 +  (let [chair (box 0.5 0.5 0.5 :position (Vector3f. 0 -5 -2)
    1.89 +                   :mass 350. :color ColorRGBA/Pink)]
    1.90 +    (add-element world chair (.getRootNode world))))
    1.91 +
    1.92  (defn worm-world-defaults []
    1.93    (let [direct-control (worm-direct-control worm-muscle-labels 40)]
    1.94      (merge direct-control     
    1.95 @@ -262,7 +313,11 @@
    1.96              :experiences (atom [])
    1.97              :experience-watch debug-experience
    1.98              :worm worm
    1.99 -            :end-frame nil})))
   1.100 +            :end-frame nil
   1.101 +            :keybindings
   1.102 +            (merge (:keybindings direct-control)
   1.103 +                   {"key-b" (fn [world pressed?]
   1.104 +                              (if pressed? (summon-chair world)))})})))
   1.105  
   1.106  (defn dir! [file]
   1.107    (if-not (.exists file)
   1.108 @@ -291,6 +346,7 @@
   1.109  (defn debug-experience
   1.110    [experiences text]
   1.111    (cond
   1.112 +   (draped? experiences)       (.setText text "Draped")
   1.113     (grand-circle? experiences) (.setText text "Grand Circle")
   1.114     (curled? experiences)       (.setText text "Curled")
   1.115     (wiggling? experiences)     (.setText text "Wiggling")
   1.116 @@ -390,14 +446,6 @@
   1.117          :experiences experiences})))
   1.118      @experiences))
   1.119  
   1.120 -(defn bin [digits]
   1.121 -  (fn [angles]
   1.122 -    (->> angles
   1.123 -         (flatten)
   1.124 -         (map (juxt #(Math/sin %) #(Math/cos %)))
   1.125 -         (flatten)
   1.126 -         (mapv #(Math/round (* % (Math/pow 10 (dec digits))))))))
   1.127 -
   1.128  ;; k-nearest neighbors with spatial binning. Only returns a result if
   1.129  ;; the propriceptive data is within 10% of a previously recorded
   1.130  ;; result in all dimensions.
   1.131 @@ -467,7 +515,7 @@
   1.132  ;;(infer-nils [1 nil 1 1]) [1 1 1 1]
   1.133  ;;(infer-nils [1 1 1 nil]) [1 1 1 0]
   1.134  ;;(infer-nils [nil 2 1 1]) [2 2 1 1]       
   1.135 -  
   1.136 +
   1.137  
   1.138  (defn empathy-demonstration []
   1.139    (let [proprio (atom ())]
   1.140 @@ -479,6 +527,7 @@
   1.141                empathy (mapv phi-space (infer-nils exp-thread))]
   1.142            (println-repl (vector:last-n exp-thread 22))
   1.143            (cond
   1.144 +           (draped? empathy)       (.setText text "Draped")
   1.145             (grand-circle? empathy) (.setText text "Grand Circle")
   1.146             (curled? empathy)       (.setText text "Curled")
   1.147             (wiggling? empathy)     (.setText text "Wiggling")
   1.148 @@ -497,6 +546,11 @@
   1.149        @experiences))
   1.150    (def phi-scan (gen-phi-scan phi-space)))
   1.151  
   1.152 +(defn empathy-experiment-0 [record]
   1.153 +  (.start (worm-world :record record)))
   1.154 +
   1.155 +
   1.156 +
   1.157  (defn empathy-experiment-1 [record]
   1.158    (.start (worm-world :experience-watch (empathy-demonstration)
   1.159                        :record record :worm worm*)))