voc with fields

arduino.scm

(load "./field.scm")
(use srfi-27)

(random-source-randomize! default-random-source)

(define c 10)

(define-class <arduino> (<thing>)
  ((sensors :init-keyword :sensors
            :init-value '() ;;[field-name]
            :accessor <-sensors)
   (transmitters :init-keyword :transmitters
                 :init-value '() ;;[(x->())]
                 :accessor <-transmitters)
   (code :init-keyword :code
         :accessor <-code)
   (props :init-keyword :properties
          :accessor <-properties)))

(define-method ai ([arduino <arduino>])
  (let ([sensors (<-sensors arduino)]
        [transmitters (<-transmitters arduino)])
    ((<-code arduino)
     arduino
     (map (^s (read-field s arduino)) sensors)
     transmitters)))


;;measures temperature and transmits it thru BLE
(define (tempereture-sensor)
  (make <arduino>
    :sensors '(temperature)
    :transmitters (list (lambda (x) (list 'BLE-100 x inverse-square-d 1)))
    :code
    (lambda (self vals trs)
      (let1 temp (or (car vals) (random-integer 100))
            (list ((car trs) temp))))))

;;beacon
(define (beacon props)
  (make <arduino>
    :transmitters (list (lambda (x) (list 'BLE-200 x inverse-square-d 1)))
    :properties props
    :code
    (lambda (self _ trs)
      (list ((car trs) (<-properties self))))))

;;reader
(define (reader)
  (make <arduino>
    :sensors '(BLE-100 BLE-200)
    :code
    (lambda (self vals _)
      (when (and (car vals) (> 30 (car vals) 10))
            (print (cadr vals)))
      '())))


(define (main . args)
  (let ([t1 (tempereture-sensor)]
        [b1 (beacon '((url . "http://google.com")))]
        [r1 (reader)])
    (run-space (list t1 b1 r1)
               (make-graph
                (list t1 r1 1)
                (list b1 r1 1))
               30)))

cats.scm

(load "./field.scm")

(define-class <cat> (<thing>)
  ((body-temperature :init-keyword :body-temperature
                     :accessor body-temperature)))

(define-class <sun> (<thing>)
  ((temperature :init-keyword :temperature
                :accessor temperature)))

;;猫のAI
(define-method ai ([cat <cat>])
  (if (read-field 'temperature cat)
      (let* ([temp (read-field 'temperature cat)]
             [ave  (/ (+ temp (body-temperature cat)) 2)]
             [voice (cond
                     [(> temp 30) "too hot meow"]
                     [(< temp 10) "too cold meow"]
                     [else "nice and warm meow"])])
        (set! (body-temperature cat) ave)
        (list (list 'sound voice (cheat 200)  (/ 1 3))))
      '()))

;;太陽のAI
(define-method ai ([sun <sun>])
  (list (list 'electromagnetic "noise" inverse-square 1)
        (list 'temperature (temperature sun) inverse-square 1)))

;;オブジェクトのグラフを組み立てて、シミュレーションを実行する。
(define (main . args)
  (let ([cat1 (make <cat> :fields '(sound temperature)
                    :body-temperature 34)]
        [cat2 (make <cat> :fields '(sound temperature)
                    :body-temperature 34)]
        [sun  (make <sun> :fields '(temperature electromagnetic)
                    :temperature 1000000)])
    (run-space (list cat1 cat2 sun)
               (make-graph
                (list sun cat1 100)
                (list sun cat2 200)
                (list cat1 cat2 150))
               1100)))

field.scm

(define-class <thing> (<object>)
  ((field-names :init-keyword :fields
                :accessor fields)
   (field-values :init-value '()
                 :accessor field-vals)))

(define-method read-field [name (x <thing>)]
  (cadr (or (assq name (field-vals x)) '(#f #f))))

(define (inverse-square x)
  (* 1.0 (expt x -2)))

(define (inverse-square-d x)
  (if (> (* 1.0 (expt x -2)) 0.5)
      1 0))

(define c 1)

(define (cheat dist)
  (lambda (x) (if (< x dist) 1 0)))

(define-method ** (x [y <number>])
  (if (> y 0) x #f))

(define-method ** ([x <number>] [y <number>])
  (* x y))

;;average
(define-method ++ [(x <number>) (y <number>)]
  (/ (+ x y) 2))

;;overwrite
(define-method ++ [x y]
  x)


(define decay caddr)
(define distance caddr)
(define speed cadddr)

(define (eval-space things graph t)
  (apply append
         (map (lambda (thing)
                (let ([neighbors (filter (lambda [x] (equal? (car x) thing)) graph)])
                  (apply append
                         (map (lambda (effect)
                                (fold (lambda (neighbor xs)
                                        (let* ([decayed-val ((decay effect) (distance neighbor))]
                                               [val (** (cadr effect) decayed-val)])
                                          (if (> decayed-val 0)
                                              (cons (list (cadr neighbor) (car effect) val (+ t (/ (distance neighbor) (* c (speed effect))))) xs)
                                              xs)))
                                      '()
                                      neighbors))
                              (ai thing)))))
              things)))

(define (run-space things graph max-t)
  (define (loop effects t)
    (if (> t max-t)
        things
        (let* ([ef-now (filter (lambda (effect) (<= (cadddr effect) t)) effects)]
               [ef-future (filter (lambda (effect) (> (cadddr effect) t)) effects)])
          (for-each (lambda (effect)
                      (let* ([target (car effect)]
                             [val (caddr effect)]
                             [field-name (cadr effect)]
                             [grid (field-vals target)])
                        (when (not (equal? (++ val (read-field field-name target))
                                         (read-field field-name target)))
                            (set! (field-vals target)
                                  (cons (list field-name (++ val (read-field field-name target))) grid))
                            (format #t "t ~4'0D: ~15'\sA field around ~S is vibrating at ~S\n" t field-name target val)
                            )))
                    ef-now)
          (loop (append ef-future (eval-space things graph t)) (+ t 1)))))
  (loop '() 0))

(define (make-graph . edges)
  (apply append (map (lambda (edge)
                       (list edge (list (cadr edge) (car edge) (caddr edge))))
                     edges)))