cco/cl-scopes
3
0
Fork 0
Code Issues 1 Pull requests Releases Wiki Activity Actions

csys:value-add as first real action handler (with parameters)

Browse source
This commit is contained in:
Helmut Merz 2026-07-25 07:51:13 +02:00
parent 42195f0cef
commit c31421cee9
2 changed files with 43 additions and 18 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

53
csys/csys.lisp
View file

@ -12,8 +12,8 @@
#:make-program
#:neuron #:std-proc #:eff-proc #:create-zero
#:handle-action
#:no-op
#:notify))
#:notify
#:no-op #:value-add))
(in-package :scopes/csys)
@ -74,23 +74,25 @@
(defun process (scope)
(lambda (msg) (funcall (proc scope) msg scope)))
(defun std-proc (msg scope &key (default (remember)) actions params)
(util:mv-bind (nmsg (nscope scope))
(handle-action msg scope :default default :actions actions :params params)
(when nmsg (forward nmsg (syns nscope)))
(update nscope)))
(defun std-proc (&key (default (remember)) actions)
(lambda (msg scope)
(util:mv-bind (nmsg (nscope scope))
(handle-action msg scope :default default :actions actions)
(when nmsg (forward nmsg (syns nscope)))
(update nscope))))
(defun eff-proc (msg scope &key params actions)
(util:mv-bind (nmsg (nscope scope))
(handle-action msg scope :default (no-op) :actions actions :params params)
(setf (nth 1 (shape:head nmsg)) :effect)
(when nmsg (notify nmsg nscope))
(update nscope)))
(defun eff-proc (&key actions)
(lambda (msg scope)
(util:mv-bind (nmsg (nscope scope))
(handle-action msg scope :default (no-op) :actions actions)
(setf (nth 1 (shape:head nmsg)) :effect)
(when nmsg (notify nmsg nscope))
(update nscope))))
(defun handle-action (msg scope &key (default (no-op)) actions params)
(defun handle-action (msg scope &key (default (no-op)) actions)
(let* ((key (message:action msg))
(act (getf actions key (getf actions :default default))))
(apply act msg scope params)))
(funcall act msg scope)))
(defun forward (msg syns)
(dolist (s syns)
@ -116,7 +118,26 @@
(setf (value scope) (shape:data-value msg :value))
(values msg scope)))
(defun value-add (&key (bias 0) (threshold 0))
(lambda (msg scope)
(let* ((val (getf (shape:data msg) :value))
(newval (+ val (value scope))))
(if (>= newval threshold)
(let* ((head (new-msg-head msg scope))
(msg (message:create head :data (list :value newval))))
(setf (value scope) bias)
(values msg scope))
(progn
(setf (value scope) newval)
(values nil scope))))))
(defun create ()
(lambda (msg scope)
(let ((new (neuron (apply #'reset-scope scope (shape:data msg)))))
(notify-created msg new scope))))
(notify-created msg new scope)
nil)))
;;;; helpers
(defun new-msg-head (msg scope)
(list (message:domain msg) (message:action msg) (cadr (categ scope))))

8
test/test-csys.lisp
View file

@ -41,6 +41,9 @@
(when nmsg
(actor:send (core:mailbox (tc:receiver t:*test-suite*)) nmsg)))))
(defun actions ()
(list :value (csys:value-add)))
(defun run ()
(let ((t:*test-suite* (make-instance 'tc:test-suite :name "csys")))
(load (t:test-path "config-csys" "etc"))
@ -63,11 +66,12 @@
env))
(deftest test-basic-0 ()
(let ((env (setup-test (csys:make-program #'csys:eff-proc)))
(let ((env (setup-test (csys:make-program (csys:eff-proc :actions (actions)))))
;(env (setup-test (csys:make-program (csys:eff-proc))))
;(env (setup-test (test-program))
(rcvr (tc:receiver t:*test-suite*)))
(sleep 0.1)
(tc:expect rcvr (message:create '(:csys :effect :c00 "0-0") :data '(:value 1)))
(tc:expect rcvr (message:create '(:csys :effect :c00) :data '(:value 1)))
(actor:send env (message:create '(:csys :value :c00 "0-0") :data '(:value 1)))
(sleep 0.1)
(core:shutdown)))