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

csys, work in progress: environ:send-connect-pred

Browse source
This commit is contained in:
Helmut Merz 2026-09-26 10:24:56 +02:00
parent 5fcfaf6fd4
commit cd85171f22
2 changed files with 25 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
csys/csys.lisp
View file

@ -183,7 +183,7 @@
nil))) nil)))
(defun connect () (defun connect ()
;; TODO: target may be a list => check if already connected ;; TODO: checks: already connected? category OK? other conditions?
(lambda (msg scope) (lambda (msg scope)
(let* ((data (shape:data msg)) (let* ((data (shape:data msg))
(syn (synapse (getf data :target) (getf data :op)))) (syn (synapse (getf data :target) (getf data :op))))

36
csys/environ.lisp
View file

@ -98,13 +98,18 @@
nil) nil)
(defun forward-connect (msg scope) (defun forward-connect (msg scope)
(let* ((data (shape:data msg)) (let* ((head (shape:head msg))
(data (shape:data msg))
(tgt (getf data :target)) (tgt (getf data :target))
(cust (actor:customer msg))) (cust (actor:customer msg)))
(cond (when (listp tgt)
((null tgt) (setf (getf data :target) (find-cells-near scope cust))) (setf tgt (find-cell scope tgt))
((listp tgt) (setf (getf data :target) (find-cell scope tgt)))) (setf (getf data :target) tgt))
(forward (message:create (shape:head msg) :data data :customer cust) scope))) (if (or cust (message:addr msg))
(forward (message:create head :data data :customer cust) scope)
(let ((rcvrs (find-cells-near scope tgt)))
(dolist (rcvr rcvrs)
(actor:send rcvr (message:create head :data data)))))))
;;;; public shortcuts ;;;; public shortcuts
@ -126,12 +131,18 @@
(when op (util:plist-add data :op op)) (when op (util:plist-add data :op op))
(send-message head data :customer cust :env env))) (send-message head data :customer cust :env env)))
(defun send-connect-pred (target &key (domain csys:*domain*) (env *env*) op cat)
(let ((head (cons domain :connect))
(data (list :target target)))
(when op (util:plist-add data :op op))
(when cat (util:plist-add data :cat cat))
(send-message head data :env env)))
;;;; internal helpers ;;;; internal helpers
(defun register-cell (scope addr cell) (defun register-cell (scope addr cell)
(destructuring-bind (dom cat loc) addr (destructuring-bind (dom cat loc) addr
(let* ((reg (spaces scope)) (let ((spc (getf (spaces scope) dom)))
(spc (getf reg dom)))
(space:put spc loc cell) (space:put spc loc cell)
(setf (gethash cell (cells scope)) addr)))) (setf (gethash cell (cells scope)) addr))))
@ -145,9 +156,10 @@
cell))) cell)))
(defun find-cells-near (scope cell &key (dist 2)) (defun find-cells-near (scope cell &key (dist 2))
(destructuring-bind (&optional dom cat loc) (getf cell (cells scope)) (let ((addr (gethash cell (cells scope))))
(when (null loc) (destructuring-bind (&optional dom cat loc) addr
(error "cell not found or loc missing! scope: ~s, cell: ~s" scope cell)) (when (null loc)
(let ((space (getf dom (spaces scope)))) (error "cell not found or loc missing! cells: ~s, cell: ~s, addr: ~s"
(space:neighbors space loc :dist dist)))) (cells scope) cell addr))
(space:neighbors (getf (spaces scope) dom) loc :dist dist))))