cl-scopes/csys/csys.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)
  (let* ((addr (getf args :addr))
         (categ (if addr 
                  (list (car addr) (cadr addr)) 
                  (getf args :categ (categ scp)))))
    (setf args (alx:remove-from-plist args :categ :addr))
    (apply #'scope 
           (getf args :program (program scp))
           (getf args :environ (environ scp))
           :categ categ
           args)))

(defun set-proc (scope)
  (setf (proc scope) (funcall (program scope) scope))
  scope)

(defgeneric make-program (spec)
  (:method ((proc function)) (lambda (scope) proc))
  (:method ((spec list))
    (make-program (alx:plist-hash-table spec :test #'equal)))
  (:method ((spec hash-table))
    (lambda (scope)
      (let* ((cat (cadr (categ scope)))
             (stg (stage scope))
             (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)
  (lambda (msg)
    (let ((nmsg (if op (funcall op msg) msg)))
      (when nmsg
        (actor:send rcvr nmsg)))))

;;;; 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)
        :connect (connect)
        :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* ((data (shape:data msg))
           (new (neuron (apply #'reset-scope scope data))))
      (notify-created msg new scope)
      (case (getf data :connect)
        (:succ (send-connect actor:*self* new msg))
        (:pred (send-connect new actor:*self* msg)))
      nil)))

(defun connect ()
  (lambda (msg scope)
    (let ((data (shape:data msg)))
      (setf (syns scope) 
            (cons (synapse (getf data :target) (getf data :op)) (syns scope)))
      (values nil scope))))

;;;; synapse ops

(defun multiply (n)
  (lambda (msg)
    (let* ((data (shape:data (copy-list msg))))
      (setf (getf data :value) (* (getf data :value 0) n))
      (message:create (shape:head msg) :data data))))

;;;; helpers

(defun new-msg-head (msg scope)
  (list (message:domain msg) (message:action msg) (cadr (categ scope))))

(defun send-connect (rcvr target msg)
  (let ((data (shape:data msg)))
    (actor:send rcvr 
      (message:create (list (message:domain msg) :connect) 
                      :data (list :target target 
                                  :op (getf data :op))))))