場を使った相対論的オブジェクト間コミュニケーション

1-simulation.scm

(load "./2-voc-w-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)))

2-voc-w-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 c 1)

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

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

(define-method ** (x y) (* x y))

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

(define-method ++ [(x <string>) (y <string>)]
  x)

(define-method ++ [(x <boolean>) y]
  y)

(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)
                                (map (lambda (neighbor)
                                       (let1 val (** (cadr effect) ((decay effect) (distance neighbor)))
                                             (list (cadr neighbor) (car effect) val (+ t (/ (distance neighbor) (* c (speed effect)))))))
                                     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)))