1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/org/worm_learn.clj	Thu Mar 27 17:57:01 2014 -0400
     1.3 @@ -0,0 +1,562 @@
     1.4 +(ns org.aurellem.worm-learn
     1.5 +  "General worm creation framework."
     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 +  (:import (com.jme3.math ColorRGBA Vector3f))
    1.11 +  (:import java.io.File)
    1.12 +  (:import com.jme3.audio.AudioNode)
    1.13 +  (:import com.aurellem.capture.RatchetTimer)
    1.14 +  (:import (com.aurellem.capture Capture IsoTimer))
    1.15 +  (:import (com.jme3.math Vector3f ColorRGBA)))
    1.16 +
    1.17 +(import org.apache.commons.math3.transform.TransformType)
    1.18 +(import org.apache.commons.math3.transform.FastFourierTransformer)
    1.19 +(import org.apache.commons.math3.transform.DftNormalization)
    1.20 +
    1.21 +(use 'clojure.pprint)
    1.22 +(use 'clojure.set)
    1.23 +(dorun (cortex.import/mega-import-jme3))
    1.24 +(rlm.rlm-commands/help)
    1.25 +
    1.26 +(load-bullet)
    1.27 +
    1.28 +(def hand "Models/test-creature/hand.blend")
    1.29 +
    1.30 +(defn worm-model []
    1.31 +  (load-blender-model "Models/worm/worm.blend"))
    1.32 +
    1.33 +(defn worm []
    1.34 +  (let [model (load-blender-model "Models/worm/worm.blend")]
    1.35 +    {:body (doto model (body!))
    1.36 +     :touch (touch! model)
    1.37 +     :proprioception (proprioception! model)
    1.38 +     :muscles (movement! model)}))
    1.39 +
    1.40 +(defn worm* []
    1.41 +  (let [model (load-blender-model "Models/worm/worm-of-the-imagination.blend")]
    1.42 +    {:body (doto model (body!))
    1.43 +     :touch (touch! model)
    1.44 +     :proprioception (proprioception! model)
    1.45 +     :muscles (movement! model)}))
    1.46 +
    1.47 +
    1.48 +(def output-base (File. "/home/r/proj/cortex/render/worm-learn/curl"))
    1.49 +
    1.50 +
    1.51 +(defn motor-control-program
    1.52 +  "Create a function which will execute the motor script"
    1.53 +  [muscle-labels
    1.54 +   script]
    1.55 +  (let [current-frame (atom -1)
    1.56 +        keyed-script (group-by first script)
    1.57 +        current-forces (atom {}) ]
    1.58 +    (fn [effectors]
    1.59 +      (let [indexed-effectors (vec effectors)]
    1.60 +        (dorun 
    1.61 +         (for [[_ part force] (keyed-script (swap! current-frame inc))]
    1.62 +           (swap! current-forces (fn [m] (assoc m part force)))))
    1.63 +        (doall (map (fn [effector power]
    1.64 +                      (effector (int power)))
    1.65 +                    effectors
    1.66 +                    (map #(@current-forces % 0) muscle-labels)))))))
    1.67 +
    1.68 +(defn worm-direct-control
    1.69 +  "Create keybindings and a muscle control program that will enable
    1.70 +   the user to control the worm via the keyboard."
    1.71 +  [muscle-labels activation-strength]
    1.72 +  (let [strengths (mapv (fn [_] (atom 0)) muscle-labels)
    1.73 +        activator
    1.74 +        (fn [n]
    1.75 +          (fn [world pressed?]
    1.76 +            (let [strength (if pressed? activation-strength 0)]
    1.77 +              (swap! (nth strengths n) (constantly strength)))))
    1.78 +        activators
    1.79 +        (map activator (range (count muscle-labels)))
    1.80 +        worm-keys
    1.81 +        ["key-f" "key-r"
    1.82 +         "key-g" "key-t"
    1.83 +         "key-h" "key-y"
    1.84 +         "key-j" "key-u"
    1.85 +         "key-k" "key-i"
    1.86 +         "key-l" "key-o"]]
    1.87 +    {:motor-control
    1.88 +     (fn [effectors]
    1.89 +      (doall
    1.90 +       (map (fn [strength effector]
    1.91 +              (effector (deref strength)))
    1.92 +            strengths effectors)))
    1.93 +     :keybindings
    1.94 +     ;; assume muscles are listed in pairs and map them to keys.
    1.95 +     (zipmap worm-keys activators)}))
    1.96 +
    1.97 +;; These are scripts that direct the worm to move in two radically
    1.98 +;; different patterns -- a sinusoidal wiggling motion, and a curling
    1.99 +;; motions that causes the worm to form a circle.
   1.100 +
   1.101 +(def curl-script
   1.102 +  [[150 :d-flex 40]
   1.103 +   [250 :d-flex 0]])
   1.104 +
   1.105 +(def period 18)
   1.106 +
   1.107 +(def worm-muscle-labels
   1.108 +  [:base-ex :base-flex
   1.109 +   :a-ex :a-flex
   1.110 +   :b-ex :b-flex
   1.111 +   :c-ex :c-flex
   1.112 +   :d-ex :d-flex])
   1.113 +
   1.114 +(defn gen-wiggle [[flexor extensor :as muscle-pair] time-base]
   1.115 +  (let [period period
   1.116 +        power 45]
   1.117 +    [[time-base flexor power]
   1.118 +     [(+ time-base period) flexor 0]
   1.119 +     [(+ time-base period 1) extensor power]
   1.120 +     [(+ time-base (+ (* 2 period) 2))  extensor 0]]))
   1.121 +  
   1.122 +(def wiggle-script
   1.123 +  (mapcat gen-wiggle (repeat 4000 [:a-ex :a-flex])
   1.124 +                     (range 100 1000000 (+ 3 (* period 2)))))
   1.125 +
   1.126 +
   1.127 +(defn shift-script [shift script]
   1.128 +  (map (fn [[time label power]] [(+ time shift) label power])
   1.129 +       script))
   1.130 +
   1.131 +(def do-all-the-things 
   1.132 +  (concat
   1.133 +   curl-script
   1.134 +   [[300 :d-ex 40]
   1.135 +    [320 :d-ex 0]]
   1.136 +   (shift-script 280 (take 16 wiggle-script))))
   1.137 +
   1.138 +;; Normally, we'd use unsupervised/supervised machine learning to pick
   1.139 +;; out the defining features of the different actions available to the
   1.140 +;; worm. For this project, I am going to explicitely define functions
   1.141 +;; that recognize curling and wiggling respectively. These functions
   1.142 +;; are defined using all the information available from an embodied
   1.143 +;; simulation of the action. Note how much easier they are to define
   1.144 +;; than if I only had vision to work with. Things like scale/position
   1.145 +;; invariance are complete non-issues here. This is the advantage of
   1.146 +;; body-centered action recognition and what I hope to show with this
   1.147 +;; thesis.
   1.148 +
   1.149 +
   1.150 +;; curled? relies on proprioception, resting? relies on touch,
   1.151 +;; wiggling? relies on a fourier analysis of muscle contraction, and
   1.152 +;; grand-circle? relies on touch and reuses curled? as a gaurd.
   1.153 +
   1.154 +(defn curled?
   1.155 +  "Is the worm curled up?"
   1.156 +  [experiences]
   1.157 +  (every?
   1.158 +   (fn [[_ _ bend]]
   1.159 +     (> (Math/sin bend) 0.64))
   1.160 +   (:proprioception (peek experiences))))
   1.161 +
   1.162 +(defn rect-region [[x0 y0] [x1 y1]]
   1.163 +  (vec
   1.164 +   (for [x (range x0 (inc x1))
   1.165 +         y (range y0 (inc y1))]
   1.166 +     [x y])))
   1.167 +
   1.168 +(def worm-segment-bottom (rect-region [8 15] [14 22]))
   1.169 +
   1.170 +(defn contact
   1.171 +  "Determine how much contact a particular worm segment has with
   1.172 +   other objects. Returns a value between 0 and 1, where 1 is full
   1.173 +   contact and 0 is no contact."
   1.174 +  [touch-region [coords contact :as touch]]
   1.175 +  (-> (zipmap coords contact)
   1.176 +      (select-keys touch-region)
   1.177 +      (vals)
   1.178 +      (#(map first %))
   1.179 +      (average)
   1.180 +      (* 10)
   1.181 +      (- 1)
   1.182 +      (Math/abs)))
   1.183 +
   1.184 +(defn resting?
   1.185 +  "Is the worm resting on the ground?"
   1.186 +  [experiences]
   1.187 +  (every?
   1.188 +   (fn [touch-data]
   1.189 +     (< 0.9 (contact worm-segment-bottom touch-data)))
   1.190 +   (:touch (peek experiences))))
   1.191 +
   1.192 +(defn vector:last-n [v n]
   1.193 +  (let [c (count v)]
   1.194 +    (if (< c n) v
   1.195 +        (subvec v (- c n) c))))
   1.196 +
   1.197 +(defn fft [nums]
   1.198 +  (map
   1.199 +   #(.getReal %)
   1.200 +   (.transform
   1.201 +    (FastFourierTransformer. DftNormalization/STANDARD)
   1.202 +    (double-array nums) TransformType/FORWARD)))
   1.203 +
   1.204 +(def indexed (partial map-indexed vector))
   1.205 +
   1.206 +(defn max-indexed [s]
   1.207 +  (first (sort-by (comp - second) (indexed s))))
   1.208 +
   1.209 +(defn wiggling?
   1.210 +  "Is the worm wiggling?"
   1.211 +  [experiences]
   1.212 +  (let [analysis-interval 96]
   1.213 +    (when (> (count experiences) analysis-interval)
   1.214 +      (let [a-flex 3
   1.215 +            a-ex   2
   1.216 +            muscle-activity
   1.217 +            (map :muscle (vector:last-n experiences analysis-interval))
   1.218 +            base-activity
   1.219 +            (map #(- (% a-flex) (% a-ex)) muscle-activity)
   1.220 +            accept?
   1.221 +            (fn [activity]
   1.222 +              (->> activity (fft) (take 20) (map #(Math/abs %))
   1.223 +                   (max-indexed) (first) (<= 2)))]
   1.224 +        (or (accept? (take 64 base-activity))
   1.225 +            (accept? (take 64 (drop 20 base-activity))))))))
   1.226 +
   1.227 +
   1.228 +
   1.229 +(def worm-segment-bottom-tip (rect-region [15 15] [22 22]))
   1.230 +
   1.231 +(def worm-segment-top-tip (rect-region [0 15] [7 22]))
   1.232 +
   1.233 +(defn grand-circle?
   1.234 +  "Does the worm form a majestic circle (one end touching the other)?"
   1.235 +  [experiences]
   1.236 +  (and (curled? experiences)
   1.237 +       (let [worm-touch (:touch (peek experiences))
   1.238 +             tail-touch (worm-touch 0)
   1.239 +             head-touch (worm-touch 4)]
   1.240 +         (and (< 0.1 (contact worm-segment-bottom-tip tail-touch))
   1.241 +              (< 0.1 (contact worm-segment-top-tip    head-touch))))))
   1.242 +
   1.243 +
   1.244 +(declare phi-space phi-scan debug-experience) 
   1.245 +
   1.246 +
   1.247 +
   1.248 +(def standard-world-view
   1.249 +  [(Vector3f. 4.207176, -3.7366982, 3.0816958)
   1.250 +   (Quaternion. 0.11118768, 0.87678415, 0.24434438, -0.3989771)])
   1.251 +
   1.252 +(def worm-side-view
   1.253 +  [(Vector3f. 4.207176, -3.7366982, 3.0816958)
   1.254 +   (Quaternion. -0.11555642, 0.88188726, -0.2854942, -0.3569518)])
   1.255 +
   1.256 +(def degenerate-worm-view
   1.257 +  [(Vector3f. -0.0708936, -8.570261, 2.6487997)
   1.258 +   (Quaternion. -2.318909E-4, 0.9985348, 0.053941682, 0.004291452)])
   1.259 +
   1.260 +(defn worm-world-defaults []
   1.261 +  (let [direct-control (worm-direct-control worm-muscle-labels 40)]
   1.262 +    (merge direct-control     
   1.263 +           {:view worm-side-view
   1.264 +            :record nil
   1.265 +            :experiences (atom [])
   1.266 +            :experience-watch debug-experience
   1.267 +            :worm worm
   1.268 +            :end-frame nil})))
   1.269 +
   1.270 +(defn dir! [file]
   1.271 +  (if-not (.exists file)
   1.272 +    (.mkdir file))
   1.273 +  file)
   1.274 +
   1.275 +(defn record-experience! [experiences data]
   1.276 +  (swap! experiences #(conj % data)))
   1.277 +
   1.278 +(defn enable-shadows [world]
   1.279 +  (let [bsr (doto
   1.280 +                (BasicShadowRenderer. (asset-manager) 512)
   1.281 +              (.setDirection (.normalizeLocal (Vector3f. 1 -1 -1))))]
   1.282 +    (.addProcessor (.getViewPort world) bsr)))
   1.283 +
   1.284 +(defn enable-good-shadows [world]
   1.285 +  (let [pssm
   1.286 +        (doto (PssmShadowRenderer. (asset-manager) 1024 3)
   1.287 +          (.setDirection  (.normalizeLocal (Vector3f. -1 -3 -1)))
   1.288 +          (.setLambda (float 0.55))
   1.289 +          (.setShadowIntensity (float 0.6))
   1.290 +          (.setCompareMode PssmShadowRenderer$CompareMode/Software)
   1.291 +          (.setFilterMode  PssmShadowRenderer$FilterMode/Bilinear))]
   1.292 +    (.addProcessor (.getViewPort world) pssm)))
   1.293 +        
   1.294 +(defn debug-experience
   1.295 +  [experiences text]
   1.296 +  (cond
   1.297 +   (grand-circle? experiences) (.setText text "Grand Circle")
   1.298 +   (curled? experiences)       (.setText text "Curled")
   1.299 +   (wiggling? experiences)     (.setText text "Wiggling")
   1.300 +   (resting? experiences)      (.setText text "Resting")
   1.301 +   :else                       (.setText text "Unknown")))
   1.302 +
   1.303 +
   1.304 +(defn worm-world
   1.305 +  [& {:keys    [record motor-control keybindings view experiences
   1.306 +                worm end-frame experience-watch] :as settings}]
   1.307 +  (let [{:keys [record motor-control keybindings view experiences
   1.308 +                worm end-frame experience-watch]}
   1.309 +        (merge (worm-world-defaults) settings)
   1.310 +       
   1.311 +        touch-display  (view-touch)
   1.312 +        prop-display   (view-proprioception)
   1.313 +        muscle-display (view-movement)
   1.314 +        {:keys [proprioception touch muscles body]} (worm)
   1.315 +        
   1.316 +        floor
   1.317 +        (box 5 1 5 :position (Vector3f. 0 -10 0)
   1.318 +             :mass 0
   1.319 +             :texture "Textures/aurellem.png"
   1.320 +             :material "Common/MatDefs/Misc/Unshaded.j3md")
   1.321 +        timer (IsoTimer. 60)
   1.322 +
   1.323 +        font (.loadFont (asset-manager) "Interface/Fonts/Console.fnt")
   1.324 +        worm-action (doto (BitmapText. font false)
   1.325 +                      (.setSize 35)
   1.326 +                      (.setColor (ColorRGBA/Black)))]
   1.327 +
   1.328 +    (world
   1.329 +     (nodify [body floor])
   1.330 +       (merge standard-debug-controls keybindings)
   1.331 +       (fn [world]
   1.332 +         (.setLocalTranslation
   1.333 +          worm-action 20 470 0)
   1.334 +         (.attachChild (.getGuiNode world) worm-action)
   1.335 +         
   1.336 +         (enable-good-shadows world)
   1.337 +         (.setShadowMode body RenderQueue$ShadowMode/CastAndReceive)
   1.338 +         (.setShadowMode floor RenderQueue$ShadowMode/Receive)
   1.339 +                  
   1.340 +         (.setBackgroundColor (.getViewPort world) (ColorRGBA/White))
   1.341 +         (.setDisplayStatView world false)
   1.342 +         (.setDisplayFps world false)
   1.343 +         (position-camera world view)
   1.344 +         (.setTimer world timer)
   1.345 +         ;;(display-dilated-time world timer)
   1.346 +         (when record
   1.347 +           (dir! record)
   1.348 +           (Capture/captureVideo
   1.349 +            world
   1.350 +            (dir! (File. record "main-view"))))
   1.351 +         (speed-up world 0.5)
   1.352 +         ;;(light-up-everything world)
   1.353 +         )
   1.354 +       (fn [world tpf]
   1.355 +         (if (and end-frame (> (.getTime timer) end-frame))
   1.356 +           (.stop world))
   1.357 +         (let [muscle-data (vec (motor-control muscles))
   1.358 +               proprioception-data (proprioception)
   1.359 +               touch-data (mapv #(% (.getRootNode world)) touch)]
   1.360 +           (when experiences
   1.361 +             (record-experience!
   1.362 +              experiences {:touch touch-data
   1.363 +                           :proprioception proprioception-data
   1.364 +                           :muscle muscle-data}))
   1.365 +           (when experience-watch
   1.366 +             (experience-watch @experiences worm-action))
   1.367 +           (muscle-display
   1.368 +            muscle-data
   1.369 +            (when record (dir! (File. record "muscle"))))
   1.370 +           (prop-display
   1.371 +            proprioception-data
   1.372 +            (when record (dir! (File. record "proprio"))))
   1.373 +           (touch-display 
   1.374 +            touch-data
   1.375 +            (when record (dir! (File. record "touch")))))))))
   1.376 +
   1.377 +
   1.378 +
   1.379 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.380 +;;;;;;;;   Phi-Space   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.381 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.382 +
   1.383 +(defn generate-phi-space []
   1.384 +  (let [experiences (atom [])]
   1.385 +    (run-world
   1.386 +     (apply-map 
   1.387 +      worm-world
   1.388 +      (merge
   1.389 +       (worm-world-defaults)
   1.390 +       {:end-frame 700
   1.391 +        :motor-control
   1.392 +        (motor-control-program worm-muscle-labels do-all-the-things)
   1.393 +        :experiences experiences})))
   1.394 +    @experiences))
   1.395 +
   1.396 +(defn bin [digits]
   1.397 +  (fn [angles]
   1.398 +    (->> angles
   1.399 +         (flatten)
   1.400 +         (map (juxt #(Math/sin %) #(Math/cos %)))
   1.401 +         (flatten)
   1.402 +         (mapv #(Math/round (* % (Math/pow 10 (dec digits))))))))
   1.403 +
   1.404 +;; k-nearest neighbors with spatial binning. Only returns a result if
   1.405 +;; the propriceptive data is within 10% of a previously recorded
   1.406 +;; result in all dimensions.
   1.407 +(defn gen-phi-scan [phi-space]
   1.408 +  (let [bin-keys (map bin [3 2 1])
   1.409 +        bin-maps
   1.410 +        (map (fn [bin-key]
   1.411 +               (group-by
   1.412 +                (comp bin-key :proprioception phi-space)
   1.413 +                (range (count phi-space)))) bin-keys)
   1.414 +        lookups (map (fn [bin-key bin-map]
   1.415 +                      (fn [proprio] (bin-map (bin-key proprio))))
   1.416 +                    bin-keys bin-maps)]
   1.417 +    (fn lookup [proprio-data]
   1.418 +      (set (some #(% proprio-data) lookups)))))
   1.419 +
   1.420 +
   1.421 +(defn longest-thread
   1.422 +  "Find the longest thread from phi-index-sets. The index sets should
   1.423 +   be ordered from most recent to least recent."
   1.424 +  [phi-index-sets]
   1.425 +  (loop [result '()
   1.426 +         [thread-bases & remaining :as phi-index-sets] phi-index-sets]
   1.427 +    (if (empty? phi-index-sets)
   1.428 +      (vec result)
   1.429 +      (let [threads
   1.430 +            (for [thread-base thread-bases]
   1.431 +              (loop [thread (list thread-base)
   1.432 +                     remaining remaining]
   1.433 +                (let [next-index (dec (first thread))]
   1.434 +                  (cond (empty? remaining) thread
   1.435 +                        (contains? (first remaining) next-index)
   1.436 +                        (recur
   1.437 +                         (cons next-index thread) (rest remaining))
   1.438 +                        :else thread))))
   1.439 +            longest-thread
   1.440 +            (reduce (fn [thread-a thread-b]
   1.441 +                      (if (> (count thread-a) (count thread-b))
   1.442 +                        thread-a thread-b))
   1.443 +                    '(nil)
   1.444 +                    threads)]
   1.445 +        (recur (concat longest-thread result)
   1.446 +               (drop (count longest-thread) phi-index-sets))))))
   1.447 +
   1.448 +
   1.449 +(defn init []
   1.450 +  (def phi-space (generate-phi-space))
   1.451 +  (def phi-scan (gen-phi-scan phi-space))
   1.452 +  )
   1.453 +
   1.454 +;; (defn infer-nils-dyl [s]
   1.455 +;;   (loop [closed ()
   1.456 +;;          open s
   1.457 +;;          anchor 0]
   1.458 +;;     (if-not (empty? open)
   1.459 +;;       (recur (conj closed
   1.460 +;;                    (or (peek open)
   1.461 +;;                        anchor))
   1.462 +;;              (pop open)
   1.463 +;;              (or (peek open) anchor))
   1.464 +;;        closed)))
   1.465 +      
   1.466 +;; (defn infer-nils [s]
   1.467 +;;   (for [i (range (count s))]
   1.468 +;;     (or (get s i)
   1.469 +;;         (some (comp not nil?) (vector:last-n (- (count s) i)))
   1.470 +;;         0)))
   1.471 +
   1.472 +
   1.473 +(defn infer-nils
   1.474 +  "Replace nils with the next available non-nil element in the
   1.475 +   sequence, or barring that, 0."
   1.476 +  [s]
   1.477 +  (loop [i (dec (count s))
   1.478 +         v (transient s)]
   1.479 +    (if (zero? i) (persistent! v)
   1.480 +        (if-let [cur (v i)]
   1.481 +          (if (get v (dec i) 0)
   1.482 +            (recur (dec i) v)
   1.483 +            (recur (dec i) (assoc! v (dec i) cur)))
   1.484 +          (recur i (assoc! v i 0))))))
   1.485 +
   1.486 +;; tests
   1.487 +
   1.488 +;;(infer-nils [1 nil 1 1]) [1 1 1 1]
   1.489 +;;(infer-nils [1 1 1 nil]) [1 1 1 0]
   1.490 +;;(infer-nils [nil 2 1 1]) [2 2 1 1]       
   1.491 +  
   1.492 +
   1.493 +(defn empathy-demonstration []
   1.494 +  (let [proprio (atom ())]
   1.495 +    (fn
   1.496 +      [experiences text]
   1.497 +      (let [phi-indices (phi-scan (:proprioception (peek experiences)))]
   1.498 +        (swap! proprio (partial cons phi-indices))
   1.499 +        (let [exp-thread (longest-thread (take 300 @proprio))
   1.500 +              empathy (mapv phi-space (infer-nils exp-thread))]
   1.501 +          (println-repl (vector:last-n exp-thread 22))
   1.502 +          (cond
   1.503 +           (grand-circle? empathy) (.setText text "Grand Circle")
   1.504 +           (curled? empathy)       (.setText text "Curled")
   1.505 +           (wiggling? empathy)     (.setText text "Wiggling")
   1.506 +           (resting? empathy)      (.setText text "Resting")
   1.507 +           :else                   (.setText text "Unknown")))))))
   1.508 +
   1.509 +(defn init-interactive []
   1.510 +  (def phi-space
   1.511 +    (let [experiences (atom [])]
   1.512 +      (run-world
   1.513 +       (apply-map 
   1.514 +        worm-world
   1.515 +        (merge
   1.516 +         (worm-world-defaults)
   1.517 +         {:experiences experiences})))
   1.518 +      @experiences))
   1.519 +  (def phi-scan (gen-phi-scan phi-space)))
   1.520 +
   1.521 +(defn empathy-experiment-1 [record]
   1.522 +  (.start (worm-world :experience-watch (empathy-demonstration)
   1.523 +                      :record record :worm worm*)))
   1.524 +
   1.525 +
   1.526 +(def worm-action-label
   1.527 +  (juxt grand-circle? curled? wiggling?))
   1.528 +
   1.529 +(defn compare-empathy-with-baseline [accuracy]
   1.530 +  (let [proprio (atom ())]
   1.531 +    (fn
   1.532 +      [experiences text]
   1.533 +      (let [phi-indices (phi-scan (:proprioception (peek experiences)))]
   1.534 +        (swap! proprio (partial cons phi-indices))
   1.535 +        (let [exp-thread (longest-thread (take 300 @proprio))
   1.536 +              empathy (mapv phi-space (infer-nils exp-thread))
   1.537 +              experience-matches-empathy
   1.538 +              (= (worm-action-label experiences)
   1.539 +                 (worm-action-label empathy))]
   1.540 +          (cond
   1.541 +           (grand-circle? empathy) (.setText text "Grand Circle")
   1.542 +           (curled? empathy)       (.setText text "Curled")
   1.543 +           (wiggling? empathy)     (.setText text "Wiggling")
   1.544 +           (resting? empathy)      (.setText text "Resting")
   1.545 +           :else                   (.setText text "Unknown"))
   1.546 +
   1.547 +          (println-repl experience-matches-empathy)
   1.548 +          (swap! accuracy #(conj % experience-matches-empathy)))))))
   1.549 +              
   1.550 +(defn accuracy [v]
   1.551 +  (float (/ (count (filter true? v)) (count v))))
   1.552 +
   1.553 +(defn test-empathy-accuracy []
   1.554 +  (let [res (atom [])]
   1.555 +    (run-world
   1.556 +     (worm-world :experience-watch
   1.557 +                 (compare-empathy-with-baseline res)
   1.558 +                 :worm worm*))
   1.559 +    (accuracy @res)))
   1.560 +
   1.561 +
   1.562 +
   1.563 +
   1.564 +
   1.565 +