;;;; 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 #:*domain*
           #:scope #:environ
           #:make-program #:create-zero
           #:neuron #:std-proc #:eff-proc
           #:handle-action #:basic-actions #:forward #:notify
           #:no-op #:printer #:value-add #:create #:connect
           #:modify-value #:multiply #:divide
           #:send-message #:send-create #:send-connect #:send-switch))

(in-package :scopes/csys)

(defvar *domain* :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)

;;;; system initialization

(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)) (loc #(0 0)) (value 0))
  (let* ((domain (car categ))
         (addr (list domain (cadr categ) loc))
         (msg (message:create (list domain :create) :data (list :addr addr)))
         (scope (scope prg env :categ categ :value value))
         (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 process (scope)
  (lambda (msg) 
    (funcall (proc scope) msg scope)))
  
(defun synapse (rcvr &optional op)
  (lambda (msg)
    ;(if (eql (message:domain msg) :_meta) (setf op (handle-syn-meta msg rcvr op)) (...))
    (let ((nmsg (if op (funcall op msg) msg)))
      (when nmsg
        (actor:send rcvr nmsg)))))

;;;; message handlers, proc steps

(defun merge-actions (&optional act+ (base (basic-actions)))
  (util:plist-merge base act+))
  
(defun std-proc (&rest args &key actions &allow-other-keys)
  (let ((actions (or actions (merge-actions args))))
    (lambda (msg scope) 
      (util:mv-bind (nmsg (nscope scope)) 
          (handle-action msg scope :actions actions)
        (when nmsg (forward nmsg (syns nscope)))
        (update nscope)))))

(defun eff-proc (&rest args &key actions &allow-other-keys)
  (let ((actions (or actions (merge-actions args))))
    (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)
          (forward nmsg (syns nscope))
          (unless (syns nscope) (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))

;;;; action handlers

(defun basic-actions ()
  (list :value (value-add)
        :create (create)
        :connect (connect)
        :switch (switch)
        :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 1) (limits '(0 15)))
  (lambda (msg scope)
    (let* ((val (getf (shape:data msg) :value))
           (newval (+ val (value scope)))
           (limit2 (cadr limits)))
      ;(util:lgi newval (length (syns scope)))
      (when limit2 (setf newval (min newval limit2)))
      (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))
        (let ((limit1 (car limits)))
          (when limit1 (setf newval (max newval limit1)))
          (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-msg actor:*self* new msg))
        (:pred (send-connect-msg new actor:*self* msg)))
      nil)))

(defun connect ()
  (lambda (msg scope)
    (let* ((data (shape:data msg))
           (syn (synapse (getf data :target) (getf data :op))))
      (push syn (syns scope))
      (values nil scope))))

(defun switch (&key (default :active))
  (lambda (msg scope)
    (let ((data (shape:data msg)))
      (setf (stage scope) (getf data :stage default))
      (set-proc scope)
      ;(util:lgi (stage scope) (proc scope) (syns scope))
      (values nil scope))))

(defun retire (msg scope)
  #+// (environ:unregister *self*)
  #+// (environ:remove-pred-syns *self*)
  (setf (stage scope) :retired)
  (setf (syns scope) nil)
  (setf (proc scope)
    (lambda (msg scope) 
      (util:lgw "message for retired cell" msg scope)
      ;(notify ...)
      nil))
  (values nil scope))

;;;; synapse ops

(defun modify-value (fn &rest args)
  (lambda (msg)
    (let ((data (copy-list (shape:data msg))))
      (setf (getf data :value) (apply fn (getf data :value 0) args))
      (message:create (shape:head msg) :data data))))

(defun multiply (n)
  (modify-value #'* n))

(defun divide (n)
  (modify-value #'floor n))

;;;; public shortcuts

(defun send-message (cell head data)
  (actor:send cell (message:create head :data data)))

(defun send-create (cell &rest args &key (domain *domain*) 
                         (cat :c00) loc connect op &allow-other-keys)
  (let ((args+ (if loc 
                 `(:addr ,(list domain cat loc))
                 `(:categ ,(list domain cat)))))
    (setf args (alx:remove-from-plist args :domain :cat :loc))
    (send-message cell (list domain :create) (append args+ args))))

(defun send-connect (cell target &key op (domain *domain*))
  (send-message cell (list domain :connect) (list :target target :op op)))

(defun send-switch (cell stage &key (domain *domain*))
  (send-message cell (list domain :switch) (list :stage stage)))

;;;; some predefined special behaviours

(defun printer ()
  (actor:create 
    (lambda (msg) 
      (format t "~&~s~%" msg))))
 
;;;; internal helpers
 
(defun new-msg-head (msg scope)
  (list (message:domain msg) (message:action msg) (cadr (categ scope))))
  
(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)))

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