136 lines
4.5 KiB
Common Lisp
136 lines
4.5 KiB
Common Lisp
;;;; cl-scopes/csys/environ - communication system environment
|
|
|
|
(defpackage :scopes/csys/environ
|
|
(:use :common-lisp)
|
|
(:local-nicknames (:actor :scopes/core/actor)
|
|
(:csys :scopes/csys)
|
|
(:index :scopes/util/index)
|
|
(:message :scopes/core/message)
|
|
(:shape :scopes/shape)
|
|
(:util :scopes/util))
|
|
(:export #:*env*
|
|
#:create #:simple-setup #:simple-proc
|
|
#:actions
|
|
#:send-value #:send-connect))
|
|
|
|
(in-package :scopes/csys/environ)
|
|
|
|
(defvar *env* nil)
|
|
|
|
(defclass scope (csys:scope)
|
|
((cells :reader cells :initform (make-hash-table :test #'equal))))
|
|
|
|
(defun create (proc meta-env &key eff-contacts)
|
|
(let* ((prg (csys:make-program proc))
|
|
(scope (csys:scope prg meta-env :cls 'scope :categ '(:env :c00)))
|
|
(env (csys:neuron scope)))
|
|
(create-contact-cells eff-contacts env (cells scope))
|
|
env))
|
|
|
|
(defun simple-setup (cfg)
|
|
(destructuring-bind (prg &key (zero-cat :c00) (zero-val 0) eff-contacts) cfg
|
|
(let ((env (create #'simple-proc (csys:printer) :eff-contacts eff-contacts)))
|
|
(csys:create-zero prg env :categ (list csys:*domain* zero-cat))
|
|
env)))
|
|
|
|
(defun simple-proc (msg scope)
|
|
(util:mv-bind (nmsg (scope scope))
|
|
(csys:handle-action msg scope :actions (actions))
|
|
(util:lgi msg nmsg)
|
|
(when nmsg
|
|
(actor:send (csys:environ scope) nmsg))))
|
|
|
|
;;;; eff contact cells
|
|
|
|
(defclass contact-scope (csys:scope)
|
|
((loc :reader loc :initarg :loc)))
|
|
|
|
(defun create-contact-cells (eff-contacts env cells)
|
|
(util:loop-plist eff-contacts cat locs do
|
|
(dolist (loc locs)
|
|
(let ((ct (csys:neuron
|
|
(csys:scope (csys:make-program #'proc-contact) env
|
|
:cls 'contact-scope
|
|
:categ (list :env cat) :loc loc))))
|
|
;(util:lgi cells cat loc)
|
|
(register-cell cells (list :env cat loc) ct)))))
|
|
|
|
(defun proc-contact (msg scope)
|
|
(let ((head (copy-list (shape:head msg))))
|
|
(setf (nth 3 head) (loc scope))
|
|
(csys:send-message (csys:environ scope) head (shape:data msg))))
|
|
|
|
;;;; action handlers
|
|
|
|
(defun actions ()
|
|
(list :created #'cell-created
|
|
:notify (csys:no-op)
|
|
:effect (csys:no-op)
|
|
:value #'forward
|
|
:connect #'forward-connect
|
|
:default (csys:no-op :no-forward t)))
|
|
|
|
(defun cell-created (msg scope)
|
|
(let* ((data (shape:data msg))
|
|
(addr (getf data :addr (getf data :categ)))
|
|
(new (getf data :new)))
|
|
(when addr
|
|
(register-cell (cells scope) addr new))
|
|
(let* ((ct-addr (cons :env (cdr addr)))
|
|
(ct (find-cell (cells scope) ct-addr)))
|
|
(when ct (csys:send-connect new ct)))
|
|
(csys:send-message new (list (message:domain msg) :next) data)
|
|
nil))
|
|
|
|
(defun forward (msg scope)
|
|
(let ((addr (message:addr msg)))
|
|
(if addr
|
|
(dolist (cell (find-cells (cells scope) (message:addr msg)))
|
|
(actor:send cell msg))
|
|
(let ((rcvr (getf (shape:data msg) :to)))
|
|
(if rcvr
|
|
(actor:send rcvr msg)
|
|
(util:lgw "no addr and no :to field in message" msg scope)))))
|
|
nil)
|
|
|
|
(defun forward-connect (msg scope)
|
|
(let* ((data (shape:data msg))
|
|
(tgt (car (find-cells (cells scope) (getf data :target)))))
|
|
(setf (getf data :target) tgt)
|
|
(forward (message:create (shape:head msg) :data data) scope)))
|
|
|
|
;;;; public shortcuts
|
|
|
|
(defun send-value (cat-loc val &key (domain csys:*domain*) (env *env*))
|
|
(let ((head (cons domain (cons :value cat-loc))))
|
|
(actor:send env (message:create head :data `(:value ,val)))))
|
|
|
|
(defun send-connect (env &rest args &key (domain csys:*domain*) addr to target op)
|
|
(let ((head (list domain :connect)))
|
|
(actor:send env (message:create head :data args))))
|
|
|
|
;;;; internal helpers
|
|
|
|
(defun register-cell (reg addr cell)
|
|
(destructuring-bind (dom cat &optional (key "")) addr
|
|
(let* ((categ (list dom cat))
|
|
(idx (gethash categ reg)))
|
|
(unless idx
|
|
(setf idx (index:create))
|
|
(setf (gethash categ reg) idx))
|
|
(index:put idx key cell))))
|
|
|
|
(defun find-cells (reg addr)
|
|
(destructuring-bind (dom cat &optional (key "")) addr
|
|
(let* ((idx (gethash (list dom cat) reg))
|
|
(cells (when idx (index:query idx key))))
|
|
(unless cells
|
|
(util:lgw "not found" addr reg idx))
|
|
cells)))
|
|
|
|
(defun find-cell (reg addr)
|
|
(let ((cells (find-cells reg addr)))
|
|
(when (> (length cells) 1)
|
|
(util:lgw "more than one cell found" addr reg cells))
|
|
(car cells)))
|
|
|