From 94a444cde3eb8c140e11952373f004a779ba3752 Mon Sep 17 00:00:00 2001 From: Helmut Merz Date: Wed, 23 Sep 2026 08:55:17 +0200 Subject: [PATCH] work in progress: csys:space; + minor improvements, todo comments, ... --- core/actor.lisp | 6 +++--- core/message.lisp | 3 +++ csys/csys.lisp | 8 +++++--- csys/environ.lisp | 2 ++ csys/program/basic.lisp | 1 + csys/space.lisp | 31 +++++++++++++++++++++---------- test/test-csys.lisp | 15 +++++++++------ 7 files changed, 44 insertions(+), 22 deletions(-) diff --git a/core/actor.lisp b/core/actor.lisp index ef5264f..9772ed9 100644 --- a/core/actor.lisp +++ b/core/actor.lisp @@ -6,7 +6,7 @@ (:shape :scopes/shape) (:util :scopes/util)) (:export #:start #:stop #:create #:send #:become #:*self* - #:customer-message #:message #:content #:customer #:set-content + #:customer-message #:message #:content #:customer #:update-content #:*logger* #:*root* #:echo #:inc #:lgi #:calculator #:plus #:minus #:show)) @@ -22,7 +22,7 @@ (:method (msg) nil)) (defclass customer-message () - ((customer :reader customer :initarg :customer :initform nil))) + ((customer :accessor customer :initarg :customer :initform nil))) (defclass message (customer-message) ((content :reader content :initarg :content :initform nil))) @@ -30,7 +30,7 @@ (defun message (content &optional customer) (make-instance 'message :content content :customer customer)) -(defgeneric set-content (msg fn) +(defgeneric update-content (msg fn) (:documentation "Create a new message with content returned by calling `fn` with the content of the input `msg`.") (:method (msg fn) (funcall fn msg)) diff --git a/core/message.lisp b/core/message.lisp index 83dec7a..489718e 100644 --- a/core/message.lisp +++ b/core/message.lisp @@ -29,6 +29,9 @@ (defmethod actor:content ((msg message)) (list (shape:head-plist msg) (shape:data msg))) +(defmethod actor:update-content ((msg message) fn) + (create (shape:head msg) :data (fn (shape:data msg)) :customer (actor:customer msg))) + (defun domain (msg) (car (shape:head msg))) diff --git a/csys/csys.lisp b/csys/csys.lisp index 50497d9..edf7260 100644 --- a/csys/csys.lisp +++ b/csys/csys.lisp @@ -134,6 +134,7 @@ (funcall s msg))) (defun notify (msg scope) + (setf (actor:customer msg) actor:*self*) (actor:send (environ scope) msg)) ;;;; action handlers @@ -182,6 +183,7 @@ nil))) (defun connect () + ;; TODO: target may be a list => check if already connected (lambda (msg scope) (let* ((data (shape:data msg)) (syn (synapse (getf data :target) (getf data :op)))) @@ -197,8 +199,8 @@ (values nil scope)))) (defun retire (msg scope) - #+// (environ:unregister *self*) - #+// (environ:remove-pred-syns *self*) + #+// (environ:unregister actor:*self*) + #+// (environ:remove-pred-syns actor:*self*) (setf (stage scope) :retired) (setf (syns scope) nil) (setf (proc scope) @@ -255,7 +257,7 @@ (defun notify-created (msg new scope) (let* ((head (list (message:domain msg) :created)) - (data (util:plist-merge (shape:data msg) `(:new ,new :parent ,actor:*self*))) + (data (util:plist-merge (shape:data msg) `(:new ,new))) (msg1 (message:create head :data data))) (notify msg1 scope))) diff --git a/csys/environ.lisp b/csys/environ.lisp index 15deeb6..236a535 100644 --- a/csys/environ.lisp +++ b/csys/environ.lisp @@ -97,6 +97,7 @@ nil) (defun forward-connect (msg scope) + ;; TODO: target may be nil => replace with list of candidates (let* ((data (shape:data msg)) (tgt (getf data :target))) (when (listp tgt) @@ -113,6 +114,7 @@ (send-message head `(:value ,val) :env env))) (defun send-connect (rcvr target &key (domain csys:*domain*) (env *env*) op) + ;; TODO: use msg.customer instead of :to in data (let* ((cat-loc (when (listp rcvr) rcvr)) (head (cons domain (cons :connect cat-loc))) (data (unless cat-loc (list :to rcvr)))) diff --git a/csys/program/basic.lisp b/csys/program/basic.lisp index 7fd4620..c98d35a 100644 --- a/csys/program/basic.lisp +++ b/csys/program/basic.lisp @@ -111,6 +111,7 @@ (lambda (msg scope) (let ((self actor:*self*) (environ:*env* (csys:environ scope))) + ;(environ:send-create self :cat :s02 :connect :pred) ;find loc -> csys:... (csys:send-create self :cat :s02 :loc #(1 1) :connect :pred) (csys:send-create self :cat :e02 :loc #(2 1) :connect :succ) (environ:send-connect self '(:c02 #(0 0)) :op op-inhibit) diff --git a/csys/space.lisp b/csys/space.lisp index 134832f..67acf3c 100644 --- a/csys/space.lisp +++ b/csys/space.lisp @@ -4,24 +4,35 @@ (defpackage :scopes/csys/space (:use :common-lisp) (:local-nicknames (:alx :alexandria) - (:util :scopes/util) - ) - (:export #:create #:put #:fetch #:query)) + (:util :scopes/util)) + (:export #:create #:put #:del #:fetch #:query + #:neighbors #:free-loc-at #:distance-sq)) (in-package :scopes/csys/space) (defun create () (make-hash-table :test #'equalp)) -(defun put (space key value) - (let ((current (gethash key space))) +(defun put (spc loc obj) + (let ((current (gethash loc spc))) (if current - (util:lgw "location already occupied" space key current value) - (setf (gethash key space) value)))) + ;(util:lgw "location already occupied" spc loc current obj) + (error "location already occupied! space: ~s, loc: ~s, current: ~s, new: ~s" + spc loc current obj) + (setf (gethash loc spc) obj)))) -(defun fetch (space key) - (gethash key space)) +(defun del (spc loc) + (remhash loc spc)) -(defun query (space pattern) +(defun fetch (spc loc) + (gethash loc spc)) + +(defun query (spc pattern) nil) +(defun neighbors (spc loc &key (dist 2))) + +(defun free-loc-at (spc loc &key (dist 2))) + +(defun distance-sq (spc loc1 loc2)) + diff --git a/test/test-csys.lisp b/test/test-csys.lisp index da6b189..5814fbe 100644 --- a/test/test-csys.lisp +++ b/test/test-csys.lisp @@ -78,12 +78,15 @@ ;;;; test definitions (deftest test-space () - (let ((idx (space:create))) - (space:put idx #(1 1) 42) - (space:put idx #(1 2) 46) - (space:put idx #(1 1) 43) - (== (space:fetch idx #(1 1)) 42) - (== (space:fetch idx #(1 2)) 46) + (let ((spc (space:create))) + (space:put spc #(1 1) 42) + (space:put spc #(1 2) 46) + (ignore-errors + (space:put spc #(1 1) 43)) + (== (space:fetch spc #(1 1)) 42) + (== (space:fetch spc #(1 2)) 46) + (space:del spc #(1 1)) + (== (space:fetch spc #(1 1)) nil) )) (deftest test-basic-0 ()