Mercurial > cortex

comparison org/worm_learn.clj @ 410:e6a7e80f885a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
refactor, fix null pointer bug.
author Robert McIntyre <rlm@mit.edu>
date Tue, 18 Mar 2014 22:29:03 -0400
parents 3b4012b42611
children a331d5ff73e0
comparison
equal deleted inserted replaced
409:ea524e4d8f8d 410:e6a7e80f885a
194 :record nil 194 :record nil
195 :experiences nil 195 :experiences nil
196 :worm-model worm-model 196 :worm-model worm-model
197 :end-frame nil})) 197 :end-frame nil}))
198 198
199
200 (defn dir! [file] 199 (defn dir! [file]
201 (if (not (.exists file)) 200 (if-not (.exists file)
202 (.mkdir file)) 201 (.mkdir file))
203 file) 202 file)
204 203
205 (defn record-experience! [experiences data] 204 (defn record-experience! [experiences data]
206 (swap! experiences #(conj % data))) 205 (swap! experiences #(conj % data)))
236 world 235 world
237 (dir! (File. record "main-view")))) 236 (dir! (File. record "main-view"))))
238 (speed-up world) 237 (speed-up world)
239 (light-up-everything world)) 238 (light-up-everything world))
240 (fn [world tpf] 239 (fn [world tpf]
241 (if (> (.getTime timer) end-frame) 240 (if (and end-frame (> (.getTime timer) end-frame))
242 (.stop world)) 241 (.stop world))
243 (let [muscle-data (motor-control muscles) 242 (let [muscle-data (motor-control muscles)
244 proprioception-data (prop) 243 proprioception-data (prop)
245 touch-data (map #(% (.getRootNode world)) touch)] 244 touch-data (map #(% (.getRootNode world)) touch)]
246 (when experiences 245 (when experiences
264 (touch-display 263 (touch-display
265 touch-data 264 touch-data
266 (if record (dir! (File. record "touch"))))))))) 265 (if record (dir! (File. record "touch")))))))))
267 266
268 267
269 ;; A demonstration of self organiging touch maps through experience. 268
270
271 (def single-worm-segment-view
272 [(Vector3f. 2.0681207, -6.1406755, 1.6106138)
273 (Quaternion. -0.15558705, 0.843615, -0.3428654, -0.38281822)])
274
275 (def worm-single-segment-muscle-labels
276 [:lift-1 :lift-2 :roll-1 :roll-2])
277
278 (defn touch-kinesthetics []
279 [[170 :lift-1 40]
280 [190 :lift-1 20]
281 [206 :lift-1 0]
282
283 [400 :lift-2 40]
284 [410 :lift-2 0]
285
286 [570 :lift-2 40]
287 [590 :lift-2 20]
288 [606 :lift-2 0]
289
290 [800 :lift-1 30]
291 [809 :lift-1 0]
292
293 [900 :roll-2 40]
294 [905 :roll-2 20]
295 [910 :roll-2 0]
296
297 [1000 :roll-2 40]
298 [1005 :roll-2 20]
299 [1010 :roll-2 0]
300
301 [1100 :roll-2 40]
302 [1105 :roll-2 20]
303 [1110 :roll-2 0]
304 ])
305
306 (defn single-worm-segment []
307 (load-blender-model "Models/worm/worm-single-segment.blend"))
308
309 (defn worm-segment-defaults []
310 (let [direct-control (worm-direct-control worm-muscle-labels 40)]
311 (merge (worm-world-defaults)
312 {:worm-model single-worm-segment
313 :view single-worm-segment-view
314 :motor-control
315 (motor-control-program
316 worm-single-segment-muscle-labels
317 (touch-kinesthetics))
318 :end-frame 1200})))
319
320 (def full-contact [(float 0.0) (float 0.1)])
321
322 (defn pure-touch?
323 "This is worm specific code to determine if a large region of touch
324 sensors is either all on or all off."
325 [[coords touch :as touch-data]]
326 (= (set (map first touch)) (set full-contact)))
327
328 (defn remove-similar
329 [coll]
330 (loop [result () coll (sort-by (comp - count) coll)]
331 (if (empty? coll) result
332 (let [x (first coll)
333 xs (rest coll)
334 c (count x)]
335 (if (some
336 (fn [other-set]
337 (let [oc (count other-set)]
338 (< (- (count (union other-set x)) c) (* oc 0.1))))
339 xs)
340 (recur result xs)
341 (recur (cons x result) xs))))))
342
343
344 (defn rect-region [[x0 y0] [x1 y1]]
345 (vec
346 (for [x (range x0 (inc x1))
347 y (range y0 (inc y1))]
348 [x y])))
349
350 (def all-touch-coordinates
351 (concat
352 (rect-region [0 15] [7 22])
353 (rect-region [8 0] [14 29])
354 (rect-region [15 15] [22 22])))
355
356 (defn view-touch-region [coords]
357 (let [touched-region
358 (reduce
359 (fn [m k]
360 (assoc m k [0.0 0.1]))
361 (zipmap all-touch-coordinates (repeat [0.1 0.1])) coords)
362 data
363 [[(vec (keys touched-region)) (vec (vals touched-region))]]
364 touch-display (view-touch)]
365 (touch-display data)
366 (touch-display data)))
367
368 (defn learn-touch-regions []
369 (let [experiences (atom [])
370 world (apply-map
371 worm-world
372 (assoc (worm-segment-defaults)
373 :experiences experiences))]
374 (run-world world)
375 (->>
376 @experiences
377 (drop 175)
378 ;; access the single segment's touch data
379 (map (comp first :touch))
380 ;; only deal with "pure" touch data to determine surfaces
381 (filter pure-touch?)
382 ;; associate coordinates with touch values
383 (map (partial apply zipmap))
384 ;; select those regions where contact is being made
385 (map (partial group-by second))
386 (map #(get % full-contact))
387 (map (partial map first))
388 ;; remove redundant/subset regions
389 (map set)
390 remove-similar)))
391
392 (defn learn-and-view-touch-regions []
393 (map view-touch-region
394 (learn-touch-regions)))
395