diff --git a/csys/csys.lisp b/csys/csys.lisp index 2ad0522..51c2ac0 100644 --- a/csys/csys.lisp +++ b/csys/csys.lisp @@ -10,8 +10,9 @@ (:alx :alexandria)) (:export #:scope #:environ #:make-program - #:neuron #:std-proc #:create + #:neuron #:std-proc #:create-zero #:handle-action + #:no-op #:notify)) (in-package :scopes/csys) @@ -30,17 +31,17 @@ (environ :reader environ :initarg :environ))) (defun scope (prg env &rest args &key (cls 'scope) &allow-other-keys) - (remf args :cls) + (setf args (alx:remove-from-plist args :cls :environ :program)) (apply #'make-instance cls :program prg :environ env args)) (defmethod initialize-instance :after ((sc scope) &key &allow-other-keys) (set-proc sc)) -(defun reset-scope (scope &rest args) +(defun reset-scope (scp &rest args) (apply #'scope - (getf args :program) (program scope) - (getf args :environ (environ scope)) - :categ (getf args :categ (categ scope)) + (getf args :program (program scp)) + (getf args :environ (environ scp)) + :categ (getf args :categ (categ scp)) args)) (defun set-proc (scope) @@ -48,28 +49,27 @@ scope) (defgeneric make-program (spec) - (:method ((fn function)) (lambda (scope) fn))) + (:method ((fn function)) (lambda (scp) fn))) +(defun create-zero (prg env &key (categ '(:csys :c00)) (name "0-0")) + (let* ((domain (car categ)) + (addr (list domain (cadr categ) name)) + (msg (message:create (list domain :create) :data (list :addr addr))) + (scope (scope prg env :categ categ))) + (create msg scope))) + ;;;; neurons (= async tasks) and synapses (= connections) (defun neuron (scope) (actor:create (process scope))) +(defun update (scope) + (actor:become (process scope))) + (defun synapse (rcvr &optional (op #'identity)) (lambda (msg) (actor:send rcvr (funcall op msg)))) -(defun update (scope) - (actor:become (process scope))) - -(defun create (prg env &key (categ '(:csys :c00)) name value) - (let* ((domain (car categ)) - (addr (when name (list domain (cadr categ) name))) - (scope (apply #'scope prg env :categ categ (when value (list :value value)))) - (msg (message:create (list domain :create) - :data (when addr (list :addr addr))))) - (do-create msg scope))) - ;;;; message handlers, proc steps (defun process (scope) @@ -81,7 +81,7 @@ (forward nmsg (syns nscope)) (update nscope))) -(defun do-create (msg scope) +(defun create (msg scope) (let ((new (neuron (apply #'reset-scope scope (shape:data msg))))) (notify-created msg new scope))) diff --git a/csys/environ.lisp b/csys/environ.lisp index 09b1ed5..f714dcd 100644 --- a/csys/environ.lisp +++ b/csys/environ.lisp @@ -6,7 +6,8 @@ (:csys :scopes/csys) (:index :scopes/util/index) (:message :scopes/core/message) - (:shape :scopes/shape)) + (:shape :scopes/shape) + (:util :scopes/util)) (:export #:create #:actions #:forward)) @@ -23,14 +24,15 @@ ;;;; action handlers, public callables (defun actions () - '(:created #'cell-created - :default #'csys:notify)) + (list :created #'cell-created + :default #'csys:no-op)) (defun cell-created (msg scope) (let* ((data (shape:data msg)) (addr (getf data :addr))) (when addr - (register-cell (cells scope) addr (getf data :new))))) + (register-cell (cells scope) addr (getf data :new))) + (list msg scope))) (defun forward-message (head scope &key data customer) (forward (message:create head :data data :customer customer) scope)) @@ -42,16 +44,17 @@ ;;;; helpers (defun register-cell (reg addr cell) - (destructuring-bind (cat key) addr - (let ((idx (getf cat reg))) + (destructuring-bind (dom cat key) addr + (let* ((dcat (list dom cat)) + (idx (gethash dcat reg))) (unless idx (setf idx (index:create)) - (setf (getf cat reg) idx)) + (setf (gethash dcat reg) idx)) (index:put idx key cell)))) (defun find-cells (reg addr) - (destructuring-bind (cat key) addr - (let ((idx (getf cat reg))) + (destructuring-bind (dom cat key) addr + (let ((idx (gethash (list dom cat) reg))) (when idx (index:query idx key))))) diff --git a/test/test-csys.lisp b/test/test-csys.lisp index c7b2c1f..3a0cd20 100644 --- a/test/test-csys.lisp +++ b/test/test-csys.lisp @@ -38,7 +38,7 @@ (let ((t:*test-suite* (csys:environ scope))) (destructuring-bind (nmsg scope) (csys:handle-action msg scope :actions (environ:actions)) - (util:lgi nmsg) + (util:lgi nmsg (tc:receiver t:*test-suite*)) (actor:send (core:mailbox (tc:receiver t:*test-suite*)) nmsg)))) (defun run () @@ -55,13 +55,11 @@ (defun setup-test-basic-0 () (setup-config) (core:setup-services) - (let* ((app (core:find-service :test-receiver)) - (env (environ:create #'proc-env app)) - (msg (message:create '(:csys :create) - :data `(:addr (:csys :c00 "0-0") - :environ ,env)))) - (setf (tc:receiver t:*test-suite*) app) + (let* ((recv (core:find-service :test-receiver)) + (env (environ:create #'proc-env t:*test-suite*))) + (setf (tc:receiver t:*test-suite*) recv) ;(csys:create-zero (test-program) env) + (csys:create-zero (csys:make-program #'csys:std-proc) env) )) (deftest test-basic-0 ()