csys:create-zero basically working

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,27 +49,26 @@
   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 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)))
+(defun synapse (rcvr &optional (op #'identity))
+  (lambda (msg)
+    (actor:send rcvr (funcall op msg))))
 
 ;;;; message handlers, proc steps
 
@@ -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)))
 

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)))))
  

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 ()