;;;; cl-scopes/csys/environ - communication system environment

(defpackage :scopes/csys/environ
  (:use :common-lisp)
  (:local-nicknames (:actor :scopes/core/actor)
                    (:csys :scopes/csys)
                    (:index :scopes/util/index)
                    (:message :scopes/core/message)
                    (:shape :scopes/shape)
                    (:util :scopes/util))
  (:export #:create #:simple-proc
           #:actions
           #:send-value #:send-connect))

(in-package :scopes/csys/environ)

(defclass scope (csys:scope)
  ((cells :reader cells :initform (make-hash-table :test #'equal))))

(defun create (proc meta-env &key eff-contacts)  ; meta-env example: (csys:printer)
  (let* ((prg (csys:make-program proc))
         (scope (csys:scope prg meta-env :cls 'scope :categ '(:env :c00)))
         (env (csys:neuron scope)))
    (create-contact-cells eff-contacts env (cells scope))
    env))

(defun simple-proc (msg scope)
  (util:mv-bind (nmsg (scope scope)) 
      (csys:handle-action msg scope :actions (actions))
    (util:lgi msg nmsg)
    (when nmsg
      (actor:send (env scope) nmsg))))

;;;; eff contact cells

(defclass contact-scope (csys:scope)
  ((loc :reader loc :initarg :loc)))

(defun create-contact-cells (eff-contacts env cells)
  (util:loop-plist eff-contacts cat locs do
    (dolist (loc locs)
      (let ((ct (csys:neuron 
                  (csys:scope (csys:make-program #'proc-contact) env 
                              :cls 'contact-scope
                              :categ (list :env cat) :loc loc))))
        ;(util:lgi cells cat loc)
        (register-cell cells (list :env cat loc) ct)))))

(defun proc-contact (msg scope)
  (setf (nth 3 (shape:head msg)) (loc scope))
  (actor:send (csys:environ scope) msg))

;;;; action handlers

(defun actions () 
  (list :created #'cell-created
        :notify (csys:no-op)
        :effect (csys:no-op)
        :value #'forward
        :connect #'forward-connect
        :default (csys:no-op :no-forward t)))

(defun cell-created (msg scope)
  (let* ((data (shape:data msg))
         (addr (getf data :addr (getf data :categ)))
         (new (getf data :new)))
    (when addr
      (register-cell (cells scope) addr new))
      (let* ((ct-addr (cons :env (cdr addr)))
             (ct (find-cell (cells scope) ct-addr)))
        (when ct (csys:send-connect new ct)))
    ;(csys:send-message new (list (message:domain msg) :next) :data data)
    (actor:send new 
      (message:create (list (message:domain msg) :next) :data data))
    nil))

(defun forward (msg scope)
  (let ((addr (message:addr msg))) 
    (if addr 
      (dolist (cell (find-cells (cells scope) (message:addr msg))) 
        (actor:send cell msg))
      (let ((rcvr (getf (shape:data msg) :to)))
        (if rcvr
          (actor:send rcvr msg)
          (util:lgw "no addr and no :to field in message" msg scope)))))
  nil)

(defun forward-connect (msg scope)
  (let* ((data (shape:data msg))
         (tgt (car (find-cells (cells scope) (getf data :target)))))
    (setf (getf data :target) tgt)
    (forward (message:create (shape:head msg) :data data) scope)))

;;;; public shortcuts

(defun send-value (env val &key (domain :csys) (cat :c00) (loc ""))
  (let ((head (list domain :value cat loc)))
   (actor:send env (message:create head :data `(:value ,val)))))

(defun send-connect (env &rest args &key (domain :csys) addr to target op)
  (let ((head (list domain :connect))) 
    (actor:send env (message:create head :data args))))
 
;;;; internal helpers

(defun register-cell (reg addr cell)
  (destructuring-bind (dom cat &optional (key "")) addr
    (let* ((categ (list dom cat))
           (idx (gethash categ reg)))
      (unless idx
        (setf idx (index:create))
        (setf (gethash categ reg) idx))
      (index:put idx key cell))))

(defun find-cells (reg addr)
  (destructuring-bind (dom cat &optional (key "")) addr
    (let* ((idx (gethash (list dom cat) reg))
           (cells (when idx (index:query idx key))))
      (unless cells
        (util:lgw "not found" addr reg idx))
      cells)))
 
(defun find-cell (reg addr)
  (let ((cells (find-cells reg addr)))
    (when (> (length cells) 1)
      (util:lgw "more than one cell found" addr reg cells))
    (car cells)))