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

csys/program/gene, work in progress: fixes, basically OK

Browse source
This commit is contained in:
Helmut Merz 2026-10-07 15:01:38 +02:00
parent 5c02e8c19f
commit f401f9047b
3 changed files with 30 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
csys/environ.lisp
View file

@ -76,7 +76,7 @@
:default (csys:no-op :no-forward t))) :default (csys:no-op :no-forward t)))
(defun cell-created (msg scope) (defun cell-created (msg scope)
(util:lgw "debug" msg scope) ;(util:lgw "debug" msg scope)
(let* ((data (shape:data msg)) (let* ((data (shape:data msg))
(addr (getf data :addr)) (addr (getf data :addr))
(new (getf data :new))) (new (getf data :new)))
@ -86,7 +86,8 @@
(ct (find-cell scope ct-addr :no-warn t))) (ct (find-cell scope ct-addr :no-warn t)))
(when ct (csys:send-connect new ct))) (when ct (csys:send-connect new ct)))
(csys:send-message new (list (message:domain msg) :next) data) (csys:send-message new (list (message:domain msg) :next) data)
nil)) msg))
;nil))
(defun forward (msg scope) (defun forward (msg scope)
(let ((rcvr (or (actor:customer msg) (let ((rcvr (or (actor:customer msg)
@ -100,12 +101,13 @@
(head (shape:head msg)) (head (shape:head msg))
(data (shape:data msg)) (data (shape:data msg))
(dom (car head)) (dom (car head))
(cat (getf data :cat)) (cat (getf data :cat :c00))
(spc (getf (spaces scope) dom))) (spc (getf (spaces scope) dom))
loc-new)
(unless addr (unless addr
(setf addr (gethash rcvr (cells scope)))) (setf addr (gethash rcvr (cells scope))))
;(util:plist-add data :loc (car (space:free-loc-at spc (caddr addr)))) (setf loc-new (car (space:free-loc-at spc (caddr addr))))
(util:plist-add data :addr (list dom cat (car (space:free-loc-at spc (caddr addr))))) (util:plist-add data :addr (list dom cat loc-new))
(csys:send-message rcvr head data)) (csys:send-message rcvr head data))
nil) nil)

26
csys/program/gene.lisp
View file

@ -1,4 +1,4 @@
;;;; cl-scopes/csys/program/gene - generative / genetic programs ;;;; cl-scopes/csys/program/gene - generic generative (genetic) programs
(defpackage :scopes/csys/program/gene (defpackage :scopes/csys/program/gene
(:use :common-lisp) (:use :common-lisp)
@ -7,18 +7,28 @@
(:environ :scopes/csys/environ) (:environ :scopes/csys/environ)
(:message :scopes/core/message) (:message :scopes/core/message)
(:util :scopes/util)) (:util :scopes/util))
(:export #:prog-g0)) (:export #:config-g0))
(in-package :scopes/csys/program/gene) (in-package :scopes/csys/program/gene)
;;;; gene-0: zero-only network for explicit messages and interactive testing ;;;; gene-0: zero-only network for explicit messages and interactive testing
(defun prog-g0 () (defun config-g0 ()
(let ((val-action (csys:value-add))) (let* ((ops (list :inhibit (csys:multiply -1)))
(std (list :bias 0 :cat :c00 :ops ops))
(eff (list :bias 2))
(cfg (list :std std :eff eff)))
(list (prog-g0 cfg) :std std
:contacts '(:e00 (#(1 0) #(1 1))))))
(defun prog-g0 (cfg)
(let* ((std (getf cfg :std))
(eff (getf cfg :eff))
(bias-e (getf eff :bias 0))
(threshold-e (getf eff :threshold 1))
(val-action-e (csys:value-add :bias bias-e :threshold threshold-e)))
(csys:make-program (csys:make-program
(list '(:c00 :initial) (csys:std-proc :value val-action) (list '(:c00 :initial) (csys:std-proc)
'(:e00 :initial) (csys:eff-proc) '(:e00 :initial) (csys:eff-proc :value val-action-e)
':default (csys:std-proc))))) ':default (csys:std-proc)))))

6
test/test-csys.lisp
View file

@ -127,9 +127,11 @@
(teardown))) (teardown)))
(deftest test-gene-0 () (deftest test-gene-0 ()
(let ((environ:*env* (setup (list (gene:prog-g0)))) (let ((environ:*env* (setup (gene:config-g0)))
(rcvr (tc:receiver t:*test-suite*))) (rcvr (tc:receiver t:*test-suite*)))
(environ:send-create '(:csys :c00 #(0 0)) :cat :e01 :connect :succ) (environ:send-create '(:csys :c00 #(0 0)) :cat :e00 :connect :succ)
(sleep 0.01)
(environ:send-value '(:c00 #(0 0)) 2)
(sleep 0.01) (print (tc:collected rcvr)) (sleep 0.01) (print (tc:collected rcvr))
(teardown))) (teardown)))