116 lines
3.9 KiB
Common Lisp
116 lines
3.9 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* #:procs
|
|
#:init
|
|
#:send #:send-message
|
|
#:neuron #:synapse
|
|
#:make-neuron #:update-neuron
|
|
#:handle-action))
|
|
|
|
(in-package :scopes/csys)
|
|
|
|
;;;; environment: common information, with list of globally available actions
|
|
|
|
(defclass environment ()
|
|
((actions :reader actions :initarg :actions :initform (make-hash-table))
|
|
(sensors :reader sensors :initarg :sensors
|
|
:initform (make-hash-table :test #'equal))
|
|
(procs :reader procs :initarg :procs
|
|
:initform (make-hash-table :test #'equal))))
|
|
|
|
(defvar *environment* (make-instance 'environment))
|
|
|
|
(defun init ()
|
|
(setf (gethash :sensor (actions *environment*)) #'create-sensor)
|
|
(setf (gethash :default (procs *environment*)) #'std-proc)
|
|
(let* ((eff-proc (gethash '(:effect :default) (procs *environment*) #'std-proc))
|
|
(zero (make-neuron nil :proc eff-proc)))
|
|
(setf (gethash '(:init :zero) (sensors *environment*)) (list zero))))
|
|
|
|
;;;; sensors: neurons receiving messages from environment, addressable via message head
|
|
|
|
(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-sensors msg))
|
|
(actor:send sn msg))
|
|
(core:handle-message core:*root* msg)))
|
|
|
|
(defun find-sensors (msg)
|
|
(let* ((key (cddr (shape:head msg)))
|
|
(sns (gethash key (sensors *environment*))))
|
|
(util:lgi key sns)
|
|
sns))
|
|
|
|
;;;; detectors: pseudo-neurons embedded in environment, addressable via message head
|
|
|
|
(defun do-log (msg state syns env)
|
|
(util:lgi msg))
|
|
|
|
;;;; neurons (= behavior factories) and synapses (connection factories)
|
|
|
|
(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))))
|
|
|
|
(defun make-neuron (syn-target &key proc state
|
|
(syn-op #'identity) (env *environment*))
|
|
(let ((proc (or proc (gethash :default (procs env) #'std-proc)))
|
|
(syns (if syn-target (list (synapse syn-target syn-op)) nil)))
|
|
(actor:create (neuron proc state syns env))))
|
|
|
|
(defun update-neuron (proc state syns &optional (env *environment*))
|
|
(actor:become (neuron proc state syns env)))
|
|
|
|
;;;; predefined neuron processors and helper / utility funtions
|
|
|
|
(defun std-proc (msg state syns env)
|
|
;(util:lgi msg state)
|
|
(destructuring-bind (nmsg nst nsyns)
|
|
(handle-action msg state syns env :default #'remember)
|
|
(forward nmsg nsyns)
|
|
(update-neuron #'std-proc nst nsyns env)))
|
|
|
|
(defun forward (msg syns)
|
|
(dolist (s syns)
|
|
(funcall s msg)))
|
|
|
|
(defun handle-action (msg state syns env &key (default #'no-op))
|
|
(let* ((key (shape:head-value msg :action))
|
|
(act (gethash key (actions env) default)))
|
|
(funcall act msg state syns env)))
|
|
|
|
;;;; predefined neuron actions
|
|
|
|
(defun no-op (msg state syns env)
|
|
(list msg state syns))
|
|
|
|
(defun remember (msg state syns env)
|
|
(list msg (shape:data msg) syns))
|
|
|
|
(defun create-sensor (msg state syns env)
|
|
(let* ((key (shape:data msg))
|
|
(sensor (make-neuron actor:*self* :state key))
|
|
(nmsg (message:create (list :csys :created (car key) (cadr key)))))
|
|
(setf (gethash key (sensors env)) (list sensor))
|
|
(list nmsg state syns)))
|
|
|
|
(defun add (msg state syns env)
|
|
(list msg (+ (shape:data msg) state) syns))
|
|
|