Mercurial > cortex

annotate org/worm_learn.clj @ 561:6a61b637a4c5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
correct wrong word choice.
author Robert McIntyre <rlm@mit.edu>
date Sun, 04 May 2014 15:38:11 -0400
parents 0b891e0dd809
children
rev   line source
rlm@394 1 (ns org.aurellem.worm-learn
rlm@394 2 "General worm creation framework."
rlm@394 3 {:author "Robert McIntyre"}
rlm@394 4 (:use (cortex world util import body sense
rlm@408 5 hearing touch vision proprioception movement
rlm@408 6 test))
rlm@394 7 (:import (com.jme3.math ColorRGBA Vector3f))
rlm@394 8 (:import java.io.File)
rlm@394 9 (:import com.jme3.audio.AudioNode)
rlm@397 10 (:import com.aurellem.capture.RatchetTimer)
rlm@397 11 (:import (com.aurellem.capture Capture IsoTimer))
rlm@397 12 (:import (com.jme3.math Vector3f ColorRGBA)))
rlm@406 13
rlm@413 14 (import org.apache.commons.math3.transform.TransformType)
rlm@413 15 (import org.apache.commons.math3.transform.FastFourierTransformer)
rlm@413 16 (import org.apache.commons.math3.transform.DftNormalization)
rlm@413 17
rlm@406 18 (use 'clojure.pprint)
rlm@408 19 (use 'clojure.set)
rlm@394 20 (dorun (cortex.import/mega-import-jme3))
rlm@394 21 (rlm.rlm-commands/help)
rlm@394 22
rlm@548 23
rlm@400 24 (load-bullet)
rlm@394 25
rlm@548 26 (defn bin [digits]
rlm@548 27 (fn [angles]
rlm@548 28 (->> angles
rlm@548 29 (flatten)
rlm@548 30 (map (juxt #(Math/sin %) #(Math/cos %)))
rlm@548 31 (flatten)
rlm@548 32 (mapv #(Math/round (* % (Math/pow 10 (dec digits))))))))
rlm@548 33
rlm@548 34
rlm@399 35 (def hand "Models/test-creature/hand.blend")
rlm@394 36
rlm@399 37 (defn worm-model []
rlm@399 38 (load-blender-model "Models/worm/worm.blend"))
rlm@394 39
rlm@449 40 (defn worm []
rlm@449 41 (let [model (load-blender-model "Models/worm/worm.blend")]
rlm@449 42 {:body (doto model (body!))
rlm@449 43 :touch (touch! model)
rlm@449 44 :proprioception (proprioception! model)
rlm@449 45 :muscles (movement! model)}))
rlm@449 46
rlm@451 47 (defn worm* []
rlm@451 48 (let [model (load-blender-model "Models/worm/worm-of-the-imagination.blend")]
rlm@451 49 {:body (doto model (body!))
rlm@451 50 :touch (touch! model)
rlm@451 51 :proprioception (proprioception! model)
rlm@451 52 :muscles (movement! model)}))
rlm@451 53
rlm@451 54
rlm@400 55 (def output-base (File. "/home/r/proj/cortex/render/worm-learn/curl"))
rlm@394 56
rlm@397 57
rlm@399 58 (defn motor-control-program
rlm@399 59 "Create a function which will execute the motor script"
rlm@406 60 [muscle-labels
rlm@399 61 script]
rlm@399 62 (let [current-frame (atom -1)
rlm@399 63 keyed-script (group-by first script)
rlm@399 64 current-forces (atom {}) ]
rlm@399 65 (fn [effectors]
rlm@399 66 (let [indexed-effectors (vec effectors)]
rlm@399 67 (dorun
rlm@399 68 (for [[_ part force] (keyed-script (swap! current-frame inc))]
rlm@399 69 (swap! current-forces (fn [m] (assoc m part force)))))
rlm@399 70 (doall (map (fn [effector power]
rlm@399 71 (effector (int power)))
rlm@399 72 effectors
rlm@406 73 (map #(@current-forces % 0) muscle-labels)))))))
rlm@397 74
rlm@404 75 (defn worm-direct-control
rlm@404 76 "Create keybindings and a muscle control program that will enable
rlm@404 77 the user to control the worm via the keyboard."
rlm@404 78 [muscle-labels activation-strength]
rlm@404 79 (let [strengths (mapv (fn [_] (atom 0)) muscle-labels)
rlm@404 80 activator
rlm@404 81 (fn [n]
rlm@404 82 (fn [world pressed?]
rlm@404 83 (let [strength (if pressed? activation-strength 0)]
rlm@404 84 (swap! (nth strengths n) (constantly strength)))))
rlm@404 85 activators
rlm@404 86 (map activator (range (count muscle-labels)))
rlm@404 87 worm-keys
rlm@404 88 ["key-f" "key-r"
rlm@404 89 "key-g" "key-t"
rlm@413 90 "key-h" "key-y"
rlm@404 91 "key-j" "key-u"
rlm@413 92 "key-k" "key-i"
rlm@413 93 "key-l" "key-o"]]
rlm@404 94 {:motor-control
rlm@404 95 (fn [effectors]
rlm@404 96 (doall
rlm@404 97 (map (fn [strength effector]
rlm@404 98 (effector (deref strength)))
rlm@404 99 strengths effectors)))
rlm@404 100 :keybindings
rlm@404 101 ;; assume muscles are listed in pairs and map them to keys.
rlm@404 102 (zipmap worm-keys activators)}))
rlm@400 103
rlm@400 104 ;; These are scripts that direct the worm to move in two radically
rlm@400 105 ;; different patterns -- a sinusoidal wiggling motion, and a curling
rlm@400 106 ;; motions that causes the worm to form a circle.
rlm@400 107
rlm@400 108 (def curl-script
rlm@415 109 [[150 :d-flex 40]
rlm@415 110 [250 :d-flex 0]])
rlm@400 111
rlm@400 112 (def period 18)
rlm@400 113
rlm@404 114 (def worm-muscle-labels
rlm@414 115 [:base-ex :base-flex
rlm@414 116 :a-ex :a-flex
rlm@414 117 :b-ex :b-flex
rlm@414 118 :c-ex :c-flex
rlm@414 119 :d-ex :d-flex])
rlm@399 120
rlm@399 121 (defn gen-wiggle [[flexor extensor :as muscle-pair] time-base]
rlm@399 122 (let [period period
rlm@399 123 power 45]
rlm@399 124 [[time-base flexor power]
rlm@399 125 [(+ time-base period) flexor 0]
rlm@399 126 [(+ time-base period 1) extensor power]
rlm@399 127 [(+ time-base (+ (* 2 period) 2)) extensor 0]]))
rlm@399 128
rlm@399 129 (def wiggle-script
rlm@414 130 (mapcat gen-wiggle (repeat 4000 [:a-ex :a-flex])
rlm@406 131 (range 100 1000000 (+ 3 (* period 2)))))
rlm@399 132
rlm@399 133
rlm@415 134 (defn shift-script [shift script]
rlm@415 135 (map (fn [[time label power]] [(+ time shift) label power])
rlm@415 136 script))
rlm@415 137
rlm@415 138 (def do-all-the-things
rlm@415 139 (concat
rlm@415 140 curl-script
rlm@415 141 [[300 :d-ex 40]
rlm@415 142 [320 :d-ex 0]]
rlm@415 143 (shift-script 280 (take 16 wiggle-script))))
rlm@415 144
rlm@400 145 ;; Normally, we'd use unsupervised/supervised machine learning to pick
rlm@400 146 ;; out the defining features of the different actions available to the
rlm@400 147 ;; worm. For this project, I am going to explicitely define functions
rlm@400 148 ;; that recognize curling and wiggling respectively. These functions
rlm@400 149 ;; are defined using all the information available from an embodied
rlm@400 150 ;; simulation of the action. Note how much easier they are to define
rlm@400 151 ;; than if I only had vision to work with. Things like scale/position
rlm@400 152 ;; invariance are complete non-issues here. This is the advantage of
rlm@400 153 ;; body-centered action recognition and what I hope to show with this
rlm@400 154 ;; thesis.
rlm@400 155
rlm@405 156
rlm@415 157 ;; curled? relies on proprioception, resting? relies on touch,
rlm@415 158 ;; wiggling? relies on a fourier analysis of muscle contraction, and
rlm@415 159 ;; grand-circle? relies on touch and reuses curled? as a gaurd.
rlm@405 160
rlm@405 161 (defn curled?
rlm@405 162 "Is the worm curled up?"
rlm@405 163 [experiences]
rlm@405 164 (every?
rlm@405 165 (fn [[_ _ bend]]
rlm@405 166 (> (Math/sin bend) 0.64))
rlm@405 167 (:proprioception (peek experiences))))
rlm@405 168
rlm@411 169 (defn rect-region [[x0 y0] [x1 y1]]
rlm@411 170 (vec
rlm@411 171 (for [x (range x0 (inc x1))
rlm@411 172 y (range y0 (inc y1))]
rlm@411 173 [x y])))
rlm@407 174
rlm@548 175 (def all-touch-coordinates
rlm@548 176 (concat
rlm@548 177 (rect-region [0 15] [7 22])
rlm@548 178 (rect-region [8 0] [14 29])
rlm@548 179 (rect-region [15 15] [22 22])))
rlm@548 180
rlm@415 181 (def worm-segment-bottom (rect-region [8 15] [14 22]))
rlm@407 182
rlm@411 183 (defn contact
rlm@411 184 "Determine how much contact a particular worm segment has with
rlm@411 185 other objects. Returns a value between 0 and 1, where 1 is full
rlm@411 186 contact and 0 is no contact."
rlm@415 187 [touch-region [coords contact :as touch]]
rlm@411 188 (-> (zipmap coords contact)
rlm@415 189 (select-keys touch-region)
rlm@411 190 (vals)
rlm@411 191 (#(map first %))
rlm@411 192 (average)
rlm@411 193 (* 10)
rlm@411 194 (- 1)
rlm@411 195 (Math/abs)))
rlm@406 196
rlm@415 197 (defn resting?
rlm@443 198 "Is the worm resting on the ground?"
rlm@415 199 [experiences]
rlm@415 200 (every?
rlm@415 201 (fn [touch-data]
rlm@415 202 (< 0.9 (contact worm-segment-bottom touch-data)))
rlm@415 203 (:touch (peek experiences))))
rlm@415 204
rlm@415 205 (defn vector:last-n [v n]
rlm@415 206 (let [c (count v)]
rlm@415 207 (if (< c n) v
rlm@415 208 (subvec v (- c n) c))))
rlm@415 209
rlm@413 210 (defn fft [nums]
rlm@414 211 (map
rlm@414 212 #(.getReal %)
rlm@414 213 (.transform
rlm@414 214 (FastFourierTransformer. DftNormalization/STANDARD)
rlm@414 215 (double-array nums) TransformType/FORWARD)))
rlm@413 216
rlm@413 217 (def indexed (partial map-indexed vector))
rlm@413 218
rlm@414 219 (defn max-indexed [s]
rlm@414 220 (first (sort-by (comp - second) (indexed s))))
rlm@414 221
rlm@400 222 (defn wiggling?
rlm@405 223 "Is the worm wiggling?"
rlm@405 224 [experiences]
rlm@451 225 (let [analysis-interval 96]
rlm@414 226 (when (> (count experiences) analysis-interval)
rlm@414 227 (let [a-flex 3
rlm@414 228 a-ex 2
rlm@414 229 muscle-activity
rlm@414 230 (map :muscle (vector:last-n experiences analysis-interval))
rlm@414 231 base-activity
rlm@451 232 (map #(- (% a-flex) (% a-ex)) muscle-activity)
rlm@451 233 accept?
rlm@451 234 (fn [activity]
rlm@451 235 (->> activity (fft) (take 20) (map #(Math/abs %))
rlm@451 236 (max-indexed) (first) (<= 2)))]
rlm@451 237 (or (accept? (take 64 base-activity))
rlm@451 238 (accept? (take 64 (drop 20 base-activity))))))))
rlm@451 239
rlm@415 240 (def worm-segment-bottom-tip (rect-region [15 15] [22 22]))
rlm@414 241
rlm@415 242 (def worm-segment-top-tip (rect-region [0 15] [7 22]))
rlm@414 243
rlm@415 244 (defn grand-circle?
rlm@415 245 "Does the worm form a majestic circle (one end touching the other)?"
rlm@415 246 [experiences]
rlm@420 247 (and (curled? experiences)
rlm@415 248 (let [worm-touch (:touch (peek experiences))
rlm@415 249 tail-touch (worm-touch 0)
rlm@415 250 head-touch (worm-touch 4)]
rlm@451 251 (and (< 0.1 (contact worm-segment-bottom-tip tail-touch))
rlm@451 252 (< 0.1 (contact worm-segment-top-tip head-touch))))))
rlm@400 253
rlm@418 254
rlm@548 255 (defn draped?
rlm@548 256 "Is the worm:
rlm@548 257 -- not flat (the floor is not a 'chair')
rlm@548 258 -- supported (not using its muscles to hold its position)
rlm@548 259 -- stable (not changing its position)
rlm@548 260 -- touching something (must register contact)"
rlm@548 261 [experiences]
rlm@548 262 (let [b2-hash (bin 2)
rlm@548 263 touch (:touch (peek experiences))
rlm@548 264 total-contact
rlm@548 265 (reduce
rlm@548 266 +
rlm@548 267 (map #(contact all-touch-coordinates %)
rlm@548 268 (rest touch)))]
rlm@548 269 (println total-contact)
rlm@548 270 (and (not (resting? experiences))
rlm@548 271 (every?
rlm@548 272 zero?
rlm@548 273 (-> experiences
rlm@548 274 (vector:last-n 25)
rlm@548 275 (#(map :muscle %))
rlm@548 276 (flatten)))
rlm@548 277 (-> experiences
rlm@548 278 (vector:last-n 20)
rlm@548 279 (#(map (comp b2-hash flatten :proprioception) %))
rlm@548 280 (set)
rlm@548 281 (count) (= 1))
rlm@548 282 (< 0.03 total-contact))))
rlm@548 283
rlm@548 284
rlm@449 285 (declare phi-space phi-scan debug-experience)
rlm@418 286
rlm@418 287
rlm@418 288
rlm@400 289 (def standard-world-view
rlm@400 290 [(Vector3f. 4.207176, -3.7366982, 3.0816958)
rlm@400 291 (Quaternion. 0.11118768, 0.87678415, 0.24434438, -0.3989771)])
rlm@400 292
rlm@400 293 (def worm-side-view
rlm@400 294 [(Vector3f. 4.207176, -3.7366982, 3.0816958)
rlm@400 295 (Quaternion. -0.11555642, 0.88188726, -0.2854942, -0.3569518)])
rlm@400 296
rlm@400 297 (def degenerate-worm-view
rlm@400 298 [(Vector3f. -0.0708936, -8.570261, 2.6487997)
rlm@400 299 (Quaternion. -2.318909E-4, 0.9985348, 0.053941682, 0.004291452)])
rlm@399 300
rlm@548 301 (defn summon-chair
rlm@548 302 "Create a chair in the world for the worm"
rlm@548 303 [world]
rlm@548 304 (let [chair (box 0.5 0.5 0.5 :position (Vector3f. 0 -5 -2)
rlm@548 305 :mass 350. :color ColorRGBA/Pink)]
rlm@548 306 (add-element world chair (.getRootNode world))))
rlm@548 307
rlm@404 308 (defn worm-world-defaults []
rlm@404 309 (let [direct-control (worm-direct-control worm-muscle-labels 40)]
rlm@430 310 (merge direct-control
rlm@430 311 {:view worm-side-view
rlm@430 312 :record nil
rlm@430 313 :experiences (atom [])
rlm@430 314 :experience-watch debug-experience
rlm@451 315 :worm worm
rlm@548 316 :end-frame nil
rlm@548 317 :keybindings
rlm@548 318 (merge (:keybindings direct-control)
rlm@548 319 {"key-b" (fn [world pressed?]
rlm@548 320 (if pressed? (summon-chair world)))})})))
rlm@407 321
rlm@404 322 (defn dir! [file]
rlm@410 323 (if-not (.exists file)
rlm@404 324 (.mkdir file))
rlm@404 325 file)
rlm@405 326
rlm@405 327 (defn record-experience! [experiences data]
rlm@405 328 (swap! experiences #(conj % data)))
rlm@405 329
rlm@444 330 (defn enable-shadows [world]
rlm@444 331 (let [bsr (doto
rlm@444 332 (BasicShadowRenderer. (asset-manager) 512)
rlm@444 333 (.setDirection (.normalizeLocal (Vector3f. 1 -1 -1))))]
rlm@444 334 (.addProcessor (.getViewPort world) bsr)))
rlm@443 335
rlm@444 336 (defn enable-good-shadows [world]
rlm@444 337 (let [pssm
rlm@444 338 (doto (PssmShadowRenderer. (asset-manager) 1024 3)
rlm@444 339 (.setDirection (.normalizeLocal (Vector3f. -1 -3 -1)))
rlm@444 340 (.setLambda (float 0.55))
rlm@444 341 (.setShadowIntensity (float 0.6))
rlm@444 342 (.setCompareMode PssmShadowRenderer$CompareMode/Software)
rlm@444 343 (.setFilterMode PssmShadowRenderer$FilterMode/Bilinear))]
rlm@444 344 (.addProcessor (.getViewPort world) pssm)))
rlm@444 345
rlm@449 346 (defn debug-experience
rlm@449 347 [experiences text]
rlm@449 348 (cond
rlm@548 349 (draped? experiences) (.setText text "Draped")
rlm@449 350 (grand-circle? experiences) (.setText text "Grand Circle")
rlm@449 351 (curled? experiences) (.setText text "Curled")
rlm@449 352 (wiggling? experiences) (.setText text "Wiggling")
rlm@451 353 (resting? experiences) (.setText text "Resting")
rlm@451 354 :else (.setText text "Unknown")))
rlm@443 355
rlm@445 356
rlm@399 357 (defn worm-world
rlm@451 358 [& {:keys [record motor-control keybindings view experiences
rlm@451 359 worm end-frame experience-watch] :as settings}]
rlm@407 360 (let [{:keys [record motor-control keybindings view experiences
rlm@451 361 worm end-frame experience-watch]}
rlm@404 362 (merge (worm-world-defaults) settings)
rlm@449 363
rlm@404 364 touch-display (view-touch)
rlm@404 365 prop-display (view-proprioception)
rlm@404 366 muscle-display (view-movement)
rlm@449 367 {:keys [proprioception touch muscles body]} (worm)
rlm@404 368
rlm@444 369 floor
rlm@444 370 (box 5 1 5 :position (Vector3f. 0 -10 0)
rlm@444 371 :mass 0
rlm@444 372 :texture "Textures/aurellem.png"
rlm@444 373 :material "Common/MatDefs/Misc/Unshaded.j3md")
rlm@445 374 timer (IsoTimer. 60)
rlm@445 375
rlm@445 376 font (.loadFont (asset-manager) "Interface/Fonts/Console.fnt")
rlm@445 377 worm-action (doto (BitmapText. font false)
rlm@445 378 (.setSize 35)
rlm@445 379 (.setColor (ColorRGBA/Black)))]
rlm@399 380
rlm@404 381 (world
rlm@449 382 (nodify [body floor])
rlm@404 383 (merge standard-debug-controls keybindings)
rlm@404 384 (fn [world]
rlm@445 385 (.setLocalTranslation
rlm@445 386 worm-action 20 470 0)
rlm@445 387 (.attachChild (.getGuiNode world) worm-action)
rlm@445 388
rlm@444 389 (enable-good-shadows world)
rlm@449 390 (.setShadowMode body RenderQueue$ShadowMode/CastAndReceive)
rlm@444 391 (.setShadowMode floor RenderQueue$ShadowMode/Receive)
rlm@444 392
rlm@444 393 (.setBackgroundColor (.getViewPort world) (ColorRGBA/White))
rlm@443 394 (.setDisplayStatView world false)
rlm@443 395 (.setDisplayFps world false)
rlm@404 396 (position-camera world view)
rlm@407 397 (.setTimer world timer)
rlm@449 398 ;;(display-dilated-time world timer)
rlm@430 399 (when record
rlm@445 400 (dir! record)
rlm@404 401 (Capture/captureVideo
rlm@404 402 world
rlm@404 403 (dir! (File. record "main-view"))))
rlm@451 404 (speed-up world 0.5)
rlm@444 405 ;;(light-up-everything world)
rlm@444 406 )
rlm@404 407 (fn [world tpf]
rlm@410 408 (if (and end-frame (> (.getTime timer) end-frame))
rlm@407 409 (.stop world))
rlm@414 410 (let [muscle-data (vec (motor-control muscles))
rlm@449 411 proprioception-data (proprioception)
rlm@415 412 touch-data (mapv #(% (.getRootNode world)) touch)]
rlm@405 413 (when experiences
rlm@405 414 (record-experience!
rlm@405 415 experiences {:touch touch-data
rlm@405 416 :proprioception proprioception-data
rlm@418 417 :muscle muscle-data}))
rlm@418 418 (when experience-watch
rlm@445 419 (experience-watch @experiences worm-action))
rlm@404 420 (muscle-display
rlm@405 421 muscle-data
rlm@430 422 (when record (dir! (File. record "muscle"))))
rlm@405 423 (prop-display
rlm@405 424 proprioception-data
rlm@430 425 (when record (dir! (File. record "proprio"))))
rlm@405 426 (touch-display
rlm@405 427 touch-data
rlm@430 428 (when record (dir! (File. record "touch")))))))))
rlm@407 429
rlm@407 430
rlm@407 431
rlm@416 432 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@416 433 ;;;;;;;; Phi-Space ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@416 434 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@416 435
rlm@416 436 (defn generate-phi-space []
rlm@416 437 (let [experiences (atom [])]
rlm@416 438 (run-world
rlm@416 439 (apply-map
rlm@416 440 worm-world
rlm@416 441 (merge
rlm@416 442 (worm-world-defaults)
rlm@416 443 {:end-frame 700
rlm@416 444 :motor-control
rlm@416 445 (motor-control-program worm-muscle-labels do-all-the-things)
rlm@416 446 :experiences experiences})))
rlm@416 447 @experiences))
rlm@416 448
rlm@418 449 ;; k-nearest neighbors with spatial binning. Only returns a result if
rlm@418 450 ;; the propriceptive data is within 10% of a previously recorded
rlm@418 451 ;; result in all dimensions.
rlm@416 452 (defn gen-phi-scan [phi-space]
rlm@416 453 (let [bin-keys (map bin [3 2 1])
rlm@416 454 bin-maps
rlm@417 455 (map (fn [bin-key]
rlm@417 456 (group-by
rlm@417 457 (comp bin-key :proprioception phi-space)
rlm@417 458 (range (count phi-space)))) bin-keys)
rlm@416 459 lookups (map (fn [bin-key bin-map]
rlm@416 460 (fn [proprio] (bin-map (bin-key proprio))))
rlm@416 461 bin-keys bin-maps)]
rlm@416 462 (fn lookup [proprio-data]
rlm@419 463 (set (some #(% proprio-data) lookups)))))
rlm@419 464
rlm@419 465
rlm@419 466 (defn longest-thread
rlm@419 467 "Find the longest thread from phi-index-sets. The index sets should
rlm@419 468 be ordered from most recent to least recent."
rlm@419 469 [phi-index-sets]
rlm@419 470 (loop [result '()
rlm@419 471 [thread-bases & remaining :as phi-index-sets] phi-index-sets]
rlm@419 472 (if (empty? phi-index-sets)
rlm@420 473 (vec result)
rlm@419 474 (let [threads
rlm@419 475 (for [thread-base thread-bases]
rlm@419 476 (loop [thread (list thread-base)
rlm@419 477 remaining remaining]
rlm@419 478 (let [next-index (dec (first thread))]
rlm@419 479 (cond (empty? remaining) thread
rlm@419 480 (contains? (first remaining) next-index)
rlm@419 481 (recur
rlm@419 482 (cons next-index thread) (rest remaining))
rlm@419 483 :else thread))))
rlm@419 484 longest-thread
rlm@419 485 (reduce (fn [thread-a thread-b]
rlm@419 486 (if (> (count thread-a) (count thread-b))
rlm@419 487 thread-a thread-b))
rlm@419 488 '(nil)
rlm@419 489 threads)]
rlm@419 490 (recur (concat longest-thread result)
rlm@419 491 (drop (count longest-thread) phi-index-sets))))))
rlm@419 492
rlm@416 493
rlm@416 494 (defn init []
rlm@416 495 (def phi-space (generate-phi-space))
rlm@416 496 (def phi-scan (gen-phi-scan phi-space))
rlm@416 497 )
rlm@418 498
rlm@420 499
rlm@420 500 (defn infer-nils
rlm@420 501 "Replace nils with the next available non-nil element in the
rlm@420 502 sequence, or barring that, 0."
rlm@420 503 [s]
rlm@430 504 (loop [i (dec (count s))
rlm@430 505 v (transient s)]
rlm@430 506 (if (zero? i) (persistent! v)
rlm@430 507 (if-let [cur (v i)]
rlm@430 508 (if (get v (dec i) 0)
rlm@430 509 (recur (dec i) v)
rlm@430 510 (recur (dec i) (assoc! v (dec i) cur)))
rlm@430 511 (recur i (assoc! v i 0))))))
rlm@420 512
rlm@420 513 ;; tests
rlm@420 514
rlm@420 515 ;;(infer-nils [1 nil 1 1]) [1 1 1 1]
rlm@420 516 ;;(infer-nils [1 1 1 nil]) [1 1 1 0]
rlm@420 517 ;;(infer-nils [nil 2 1 1]) [2 2 1 1]
rlm@548 518
rlm@420 519
rlm@451 520 (defn empathy-demonstration []
rlm@420 521 (let [proprio (atom ())]
rlm@420 522 (fn
rlm@451 523 [experiences text]
rlm@420 524 (let [phi-indices (phi-scan (:proprioception (peek experiences)))]
rlm@420 525 (swap! proprio (partial cons phi-indices))
rlm@420 526 (let [exp-thread (longest-thread (take 300 @proprio))
rlm@451 527 empathy (mapv phi-space (infer-nils exp-thread))]
rlm@420 528 (println-repl (vector:last-n exp-thread 22))
rlm@420 529 (cond
rlm@548 530 (draped? empathy) (.setText text "Draped")
rlm@451 531 (grand-circle? empathy) (.setText text "Grand Circle")
rlm@451 532 (curled? empathy) (.setText text "Curled")
rlm@451 533 (wiggling? empathy) (.setText text "Wiggling")
rlm@451 534 (resting? empathy) (.setText text "Resting")
rlm@451 535 :else (.setText text "Unknown")))))))
rlm@420 536
rlm@420 537 (defn init-interactive []
rlm@420 538 (def phi-space
rlm@420 539 (let [experiences (atom [])]
rlm@420 540 (run-world
rlm@420 541 (apply-map
rlm@420 542 worm-world
rlm@420 543 (merge
rlm@420 544 (worm-world-defaults)
rlm@420 545 {:experiences experiences})))
rlm@420 546 @experiences))
rlm@420 547 (def phi-scan (gen-phi-scan phi-space)))
rlm@420 548
rlm@548 549 (defn empathy-experiment-0 [record]
rlm@548 550 (.start (worm-world :record record)))
rlm@548 551
rlm@548 552
rlm@548 553
rlm@451 554 (defn empathy-experiment-1 [record]
rlm@451 555 (.start (worm-world :experience-watch (empathy-demonstration)
rlm@451 556 :record record :worm worm*)))
rlm@451 557
rlm@451 558
rlm@451 559 (def worm-action-label
rlm@451 560 (juxt grand-circle? curled? wiggling?))
rlm@451 561
rlm@451 562 (defn compare-empathy-with-baseline [accuracy]
rlm@451 563 (let [proprio (atom ())]
rlm@451 564 (fn
rlm@451 565 [experiences text]
rlm@451 566 (let [phi-indices (phi-scan (:proprioception (peek experiences)))]
rlm@451 567 (swap! proprio (partial cons phi-indices))
rlm@451 568 (let [exp-thread (longest-thread (take 300 @proprio))
rlm@451 569 empathy (mapv phi-space (infer-nils exp-thread))
rlm@451 570 experience-matches-empathy
rlm@451 571 (= (worm-action-label experiences)
rlm@451 572 (worm-action-label empathy))]
rlm@451 573 (cond
rlm@451 574 (grand-circle? empathy) (.setText text "Grand Circle")
rlm@451 575 (curled? empathy) (.setText text "Curled")
rlm@451 576 (wiggling? empathy) (.setText text "Wiggling")
rlm@451 577 (resting? empathy) (.setText text "Resting")
rlm@451 578 :else (.setText text "Unknown"))
rlm@451 579
rlm@451 580 (println-repl experience-matches-empathy)
rlm@451 581 (swap! accuracy #(conj % experience-matches-empathy)))))))
rlm@526 582
rlm@526 583 (defn empathy-experiment-2 []
rlm@526 584 (.start (worm-world :experience-watch (compare-empathy-with-baseline
rlm@526 585 (atom []))
rlm@526 586 :record false :worm worm*)))
rlm@526 587
rlm@451 588 (defn accuracy [v]
rlm@451 589 (float (/ (count (filter true? v)) (count v))))
rlm@451 590
rlm@451 591 (defn test-empathy-accuracy []
rlm@451 592 (let [res (atom [])]
rlm@451 593 (run-world
rlm@451 594 (worm-world :experience-watch
rlm@451 595 (compare-empathy-with-baseline res)
rlm@451 596 :worm worm*))
rlm@451 597 (accuracy @res)))
rlm@451 598
rlm@451 599
rlm@451 600
rlm@516 601 (defn dylan-collect-bolts [longest-threads index-sets]
rlm@516 602 (fn
rlm@516 603 [experiences text]
rlm@516 604 (let [phi-indices (phi-scan (:proprioception (peek experiences)))
rlm@516 605 long-thread (longest-thread (vector:last-n @index-sets 300))]
rlm@516 606 (swap! index-sets #(conj % phi-indices))
rlm@516 607 (swap! longest-threads #(conj % long-thread)))))
rlm@451 608
rlm@451 609
rlm@451 610