163 lines
5 KiB
Common Lisp
163 lines
5 KiB
Common Lisp
;;;; cl-scopes/csys - concurrent cybernetic communication systems
|
|
|
|
(defpackage :scopes/csys
|
|
(:use :common-lisp)
|
|
(:local-nicknames (:actor :scopes/core/actor)
|
|
(:config :scopes/config)
|
|
(:message :scopes/core/message)
|
|
(:shape :scopes/shape)
|
|
(:util :scopes/util)
|
|
(:alx :alexandria))
|
|
(:export #:scope #:environ
|
|
#:make-program
|
|
#:neuron #:std-proc #:eff-proc #:create-zero
|
|
#:handle-action
|
|
#:notify
|
|
#:basic-actions #:no-op #:value-add #:create))
|
|
|
|
(in-package :scopes/csys)
|
|
|
|
;;;; scope: information a neuron has access to
|
|
|
|
(defclass scope ()
|
|
((value :accessor value :initarg :value :initform 0)
|
|
(categ :accessor categ :initarg :categ :initform '(:csys :c00))
|
|
(stage :accessor stage :initarg :stage :initform :initial)
|
|
(proc :accessor proc)
|
|
(program :reader program :initarg :program)
|
|
(syns :accessor syns :initform nil)
|
|
(environ :reader environ :initarg :environ)))
|
|
|
|
(defun scope (prg env &rest args &key (cls 'scope) &allow-other-keys)
|
|
(setf args (alx:remove-from-plist args :cls :environ :program))
|
|
(apply #'make-instance cls :program prg :environ env args))
|
|
|
|
(defmethod initialize-instance :after ((sc scope) &key &allow-other-keys)
|
|
(set-proc sc))
|
|
|
|
(defun reset-scope (scp &rest args)
|
|
(apply #'scope
|
|
(getf args :program (program scp))
|
|
(getf args :environ (environ scp))
|
|
:categ (getf args :categ (categ scp))
|
|
args))
|
|
|
|
(defun set-proc (scope)
|
|
(setf (proc scope) (funcall (program scope) scope))
|
|
scope)
|
|
|
|
(defgeneric make-program (spec)
|
|
(:method ((proc function)) (lambda (scp) proc))
|
|
(:method ((spec hash-table))
|
|
(lambda (scp)
|
|
(let* ((cat (cadr (categ scp)))
|
|
(stg (stage scp))
|
|
(proc (gethash (list cat stg) spec
|
|
(gethash (list cat :default) spec
|
|
(gethash (list :default stg) spec
|
|
(gethash :default spec))))))
|
|
(unless proc
|
|
(util:lgw "proc not found" cat stg spec))
|
|
proc))))
|
|
|
|
(defun create-zero (prg env &key (categ '(:csys :c00)) (name "0-0"))
|
|
(let* ((domain (car categ))
|
|
(addr (list domain (cadr categ) name))
|
|
(msg (message:create (list domain :create) :data (list :addr addr)))
|
|
(scope (scope prg env :categ categ))
|
|
(zero (neuron scope)))
|
|
(notify-created msg zero scope)))
|
|
|
|
;;;; neurons (= async tasks) and synapses (= connections)
|
|
|
|
(defun neuron (scope)
|
|
(actor:create (process scope)))
|
|
|
|
(defun update (scope)
|
|
(actor:become (process scope)))
|
|
|
|
(defun synapse (rcvr &optional (op #'identity))
|
|
(lambda (msg)
|
|
(actor:send rcvr (funcall op msg))))
|
|
|
|
;;;; message handlers, proc steps
|
|
|
|
(defun process (scope)
|
|
(lambda (msg)
|
|
(funcall (proc scope) msg scope)))
|
|
|
|
(defun std-proc (&key (default (remember)) actions)
|
|
(lambda (msg scope)
|
|
(util:mv-bind (nmsg (nscope scope))
|
|
(handle-action msg scope :default default :actions actions)
|
|
(when nmsg (forward nmsg (syns nscope)))
|
|
(update nscope))))
|
|
|
|
(defun eff-proc (&key actions)
|
|
(lambda (msg scope)
|
|
(util:mv-bind (nmsg (nscope scope))
|
|
(handle-action msg scope :default (no-op) :actions actions)
|
|
(when nmsg
|
|
(setf (nth 1 (shape:head nmsg)) :effect)
|
|
(notify nmsg nscope))
|
|
(update nscope))))
|
|
|
|
(defun handle-action (msg scope &key (default (no-op)) actions)
|
|
(let* ((key (message:action msg))
|
|
(act (getf actions key (getf actions :default default))))
|
|
(funcall act msg scope)))
|
|
|
|
(defun forward (msg syns)
|
|
(dolist (s syns)
|
|
(funcall s msg)))
|
|
|
|
(defun notify (msg scope)
|
|
(actor:send (environ scope) msg))
|
|
|
|
(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*)))
|
|
(msg1 (message:create head :data data)))
|
|
(notify msg1 scope)))
|
|
|
|
;;;; action handlers
|
|
|
|
(defun basic-actions ()
|
|
(list :value (value-add)
|
|
:create (create)
|
|
:next (no-op :no-forward t)))
|
|
|
|
(defun no-op (&key no-forward)
|
|
(lambda (msg scope)
|
|
(unless no-forward msg)))
|
|
|
|
(defun remember ()
|
|
(lambda (msg scope)
|
|
(setf (value scope) (shape:data-value msg :value))
|
|
(values msg scope)))
|
|
|
|
(defun value-add (&key (bias 0) (threshold 0))
|
|
(lambda (msg scope)
|
|
(let* ((val (getf (shape:data msg) :value))
|
|
(newval (+ val (value scope))))
|
|
(if (>= newval threshold)
|
|
(let* ((head (new-msg-head msg scope))
|
|
(msg (message:create head :data (list :value newval))))
|
|
(setf (value scope) bias)
|
|
(values msg scope))
|
|
(progn
|
|
(setf (value scope) newval)
|
|
(values nil scope))))))
|
|
|
|
(defun create ()
|
|
(lambda (msg scope)
|
|
(let ((new (neuron (apply #'reset-scope scope (shape:data msg)))))
|
|
(notify-created msg new scope)
|
|
nil)))
|
|
|
|
;;;; synapse ops
|
|
|
|
;;;; helpers
|
|
|
|
(defun new-msg-head (msg scope)
|
|
(list (message:domain msg) (message:action msg) (cadr (categ scope))))
|