84 lines
2.7 KiB
Common Lisp
84 lines
2.7 KiB
Common Lisp
;;;; cl-scopes/csys - concurrent cybernetic communication systems
|
|
|
|
(defpackage :scopes/csys
|
|
(:use :common-lisp)
|
|
(:local-nicknames (:actor :scopes/core/actor)
|
|
(:async :scopes/util/async)
|
|
(:config :scopes/config)
|
|
(:core :scopes/core)
|
|
(:message :scopes/core/message)
|
|
(:shape :scopes/shape)
|
|
(:util :scopes/util)
|
|
(:alx :alexandria))
|
|
(:export #:environment #:*environment* #:actions #:set-action
|
|
#:send #:send-message #:*sensors*
|
|
#:neuron #:synapse
|
|
#:logger))
|
|
|
|
(in-package :scopes/csys)
|
|
|
|
;;;; environment: common information, with list of generally available actions
|
|
|
|
(defclass environment ()
|
|
((actions :reader actions :initarg :actions :initform (make-hash-table))))
|
|
|
|
(defvar *environment* (make-instance 'environment))
|
|
|
|
(defun action (env key)
|
|
(gethash key (actions env)))
|
|
|
|
(defun set-action (env key act)
|
|
(setf (gethash key (actions env)) act))
|
|
|
|
;;;; sensors: automatically created actors (neuron), addressable via message head
|
|
|
|
(defvar *sensors* (make-hash-table :test #'equal))
|
|
|
|
(defun send-message (head data &key customer)
|
|
(send (message:create head :data data :customer customer)))
|
|
|
|
(defun send (msg)
|
|
(if (eq (shape:head-value msg :domain) :csys)
|
|
(dolist (sn (find-create-sensors msg))
|
|
(actor:send sn msg))
|
|
(core:handle-message core:*root* msg)))
|
|
|
|
(defun find-create-sensors (msg)
|
|
(let* ((key (cddr (shape:head msg)))
|
|
(sns (gethash key *sensors*)))
|
|
(format t "~&~a ~a" key sns)
|
|
(or sns
|
|
(let* ((mx (message:create
|
|
(list :csys :sensor (shape:head-value msg :class))))
|
|
(hdlrs (core:select mx (core:actions core:*root*))))
|
|
(if hdlrs
|
|
(let ((tsks (mapcar #'actor:create hdlrs)))
|
|
(setf (gethash key *sensors*) tsks))
|
|
(util:lgw "no action selected" msg))))))
|
|
|
|
;;;; neurons (= behavior generators) and synapses (connection generators)
|
|
|
|
(defun neuron (proc &optional state syns (env *environment*))
|
|
(lambda (msg)
|
|
(funcall proc msg state syns env)))
|
|
|
|
(defun synapse (rcvr &optional (op #'identity))
|
|
(lambda (msg)
|
|
(actor:send rcvr (funcall op msg))))
|
|
|
|
;;;; predefined neuron processors and helper / utility funtions
|
|
|
|
(defun logger (msg state syns env)
|
|
(util:lgi msg state)
|
|
(destructuring-bind (msg state syns) (handle-action msg state syns env)
|
|
(forward msg syns)
|
|
(actor:become (neuron #'logger (shape:data msg) syns env))))
|
|
|
|
(defun forward (msg syns)
|
|
(dolist (s syns)
|
|
(funcall s msg)))
|
|
|
|
(defun handle-action (msg state syns env)
|
|
(let ((act (action env (shape:head-value msg :action))))
|
|
(or (and act (funcall act msg state syns env))
|
|
(list msg state syns))))
|