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

csys, work in progress: fully configurable programs

Browse source
This commit is contained in:
Helmut Merz 2026-09-09 16:08:27 +02:00
parent d4b032f156
commit 434bee0777
2 changed files with 53 additions and 34 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

80
csys/program/basic.lisp
View file

@ -14,7 +14,7 @@
;;;; basic-0: minimal recursive system - "self-inhibit" ;;;; basic-0: minimal recursive system - "self-inhibit"
(defun prog-b0 () (defun prog-b0 ()
(let ((val-action (csys:value-add :limits '(0)))) (let ((val-action (csys:value-add)))
(csys:make-program (csys:make-program
(list '(:c00 :initial) (csys:std-proc :value val-action :next (b0-next-zero)) (list '(:c00 :initial) (csys:std-proc :value val-action :next (b0-next-zero))
'(:e00 :initial) (csys:eff-proc) '(:e00 :initial) (csys:eff-proc)
@ -32,52 +32,68 @@
;;;; basic-1: minimal cross-linked system - "distinction" ;;;; basic-1: minimal cross-linked system - "distinction"
(defun config-b1 () (defun config-b1 ()
(list (prog-b1) :zero-cat :s01 (let* ((ops (list :inhibit (csys:divide -1)))
:eff-contacts '(:e01 (#(1 0) #(1 1))))) (std (list :bias 0 :cat :s01 :ops ops))
(eff (list :bias 2))
(cfg (list :std std :eff eff)))
(list (prog-b1 cfg) :std std
:eff-contacts '(:e01 (#(1 0) #(1 1))))))
(defun prog-b1 () (defun prog-b1 (cfg)
(let ((val-action (csys:value-add :bias 2 :limits '(0)))) (let* ((std (getf cfg :std))
(eff (getf cfg :eff))
(bias (getf eff :bias 0))
(val-action (csys:value-add :bias bias)))
(csys:make-program (csys:make-program
(list '(:s01 :initial) (csys:std-proc :next (b1-next-zero)) (list '(:s01 :initial) (csys:std-proc :next (b1-next-zero std eff))
'(:s01 :basic) (csys:std-proc :next (b1-next-one)) '(:s01 :basic) (csys:std-proc :next (b1-next-one std))
'(:e01 :default) (csys:eff-proc :value val-action) '(:e01 :default) (csys:eff-proc :value val-action)
':default (csys:std-proc))))) ':default (csys:std-proc)))))
(defun b1-next-zero () (defun b1-next-zero (std eff)
(lambda (msg scope) (let ((bias (getf eff :bias 0))
(let ((self actor:*self*)) (op-inhibit (getf (getf std :ops) :inhibit)))
(csys:send-create self :cat :e01 :loc #(1 0) :value 2 :connect :succ) (lambda (msg scope)
(csys:send-create self :cat :e01 :loc #(1 1) :value 2 (let ((self actor:*self*))
:connect :succ :op (csys:multiply -1)) (csys:send-create self :cat :e01 :loc #(1 0) :value bias :connect :succ)
(csys:send-create self :cat :s01 :loc #(0 1) :stage :basic) (csys:send-create self :cat :e01 :loc #(1 1) :value bias
(csys:send-switch self :active) :connect :succ :op op-inhibit)
nil))) (csys:send-create self :cat :s01 :loc #(0 1) :stage :basic)
(csys:send-switch self :active)
nil))))
(defun b1-next-one () (defun b1-next-one (std)
(lambda (msg scope) (let ((op-inhibit (getf (getf std :ops) :inhibit)))
(let ((self actor:*self*) (lambda (msg scope)
(environ:*env* (csys:environ scope))) (let ((self actor:*self*)
(environ:send-connect self '(:e01 #(1 0)) :op (csys:multiply -1)) (environ:*env* (csys:environ scope)))
(environ:send-connect self '(:e01 #(1 1))) (environ:send-connect self '(:e01 #(1 0)) :op op-inhibit)
(csys:send-switch self :active) (environ:send-connect self '(:e01 #(1 1)))
nil))) (csys:send-switch self :active)
nil))))
;;;; basic-2: three-layer recursive system - "delayed distinction" ;;;; basic-2: three-layer recursive system - "delayed distinction"
(defun config-b2 () (defun config-b2 ()
(list (prog-b2) :zero-cat :c02 :zero-val 2 (let* ((ops (list :inhibit (csys:divide -1)))
:eff-contacts '(:e02 (#(2 0) #(2 1))))) (std (list :bias 2 :cat :c02 :ops ops))
(cfg (list :std std)))
(list (prog-b2 cfg) :std std
:eff-contacts '(:e02 (#(2 0) #(2 1))))))
(defun prog-b2 () (defun prog-b2 (cfg)
(let ((val-action (csys:value-add :bias 2 :limits '(0)))) (let* ((std (getf cfg :std))
(val-action (csys:value-add :bias 2)))
(csys:make-program (csys:make-program
(list '(:c02 :initial) (csys:std-proc :value val-action :next (b2-next-zero)) (list '(:c02 :initial)
'(:c02 :basic) (csys:std-proc :value val-action :next (b2-next-one)) (csys:std-proc :value val-action :next (b2-next-zero cfg))
'(:c02 :basic)
(csys:std-proc :value val-action :next (b2-next-one cfg))
'(:c02 :default) (csys:std-proc :value val-action) '(:c02 :default) (csys:std-proc :value val-action)
'(:e02 :default) (csys:eff-proc) '(:e02 :default) (csys:eff-proc)
':default (csys:std-proc))))) ':default (csys:std-proc)))))
(defun b2-next-zero () (defun b2-next-zero (cfg)
(lambda (msg scope) (lambda (msg scope)
(let ((self actor:*self*)) (let ((self actor:*self*))
(csys:send-create self :cat :c02 :loc #(0 1) :value 2 :stage :basic) (csys:send-create self :cat :c02 :loc #(0 1) :value 2 :stage :basic)
@ -86,7 +102,7 @@
(csys:send-switch self :active) (csys:send-switch self :active)
nil))) nil)))
(defun b2-next-one () (defun b2-next-one (cfg)
(lambda (msg scope) (lambda (msg scope)
(let ((self actor:*self*) (let ((self actor:*self*)
(environ:*env* (csys:environ scope))) (environ:*env* (csys:environ scope)))

7
test/test-csys.lisp
View file

@ -59,9 +59,11 @@
(defun setup (cfg &key (delay 0.02)) (defun setup (cfg &key (delay 0.02))
(setup-config) (setup-config)
(core:setup-services) (core:setup-services)
(destructuring-bind (prg &key (zero-cat :c00) (zero-val 0) eff-contacts) cfg (destructuring-bind (prg &key std eff-contacts) cfg
(let ((rcvr (core:find-service :test-receiver)) (let ((rcvr (core:find-service :test-receiver))
(env (environ:create #'proc-env t:*test-suite* :eff-contacts eff-contacts))) (env (environ:create #'proc-env t:*test-suite* :eff-contacts eff-contacts))
(zero-val (getf std :bias 0))
(zero-cat (getf std :cat :c00)))
(setf (tc:receiver t:*test-suite*) rcvr) (setf (tc:receiver t:*test-suite*) rcvr)
(csys:create-zero prg env :categ (list :csys zero-cat) :value zero-val) (csys:create-zero prg env :categ (list :csys zero-cat) :value zero-val)
(sleep delay) (sleep delay)
@ -85,6 +87,7 @@
(let ((environ:*env* (setup (basic:config-b1)))) (let ((environ:*env* (setup (basic:config-b1))))
(environ:send-value '(:s01 #(0 0)) 1) (environ:send-value '(:s01 #(0 0)) 1)
(environ:send-value '(:s01 #(0 1)) 2) (environ:send-value '(:s01 #(0 1)) 2)
;(environ:send-value '(:s01 #(0 0)) 1)
(teardown))) (teardown)))
(deftest test-basic-2 () (deftest test-basic-2 ()