;;;; cl-scopes/core/actor - basic actor definitions

(defpackage :scopes/core/actor
  (:use :common-lisp)
  (:local-nicknames (:async :scopes/util/async) 
                    (:shape :scopes/shape)
                    (:util :scopes/util))
  (:export #:start #:stop #:create #:send
           #:message #:content #:customer #:set-content
           #:*logger* #:*root*
           #:echo #:inc #:lgi
           #:calculator #:plus #:minus #:show))

(in-package :scopes/core/actor)

;;;; basic message implementation

(defgeneric content (msg)
  (:method (msg) msg))

(defgeneric customer (msg)
  (:method (msg) nil))

(defclass message ()
  ((content :reader content :initarg :content :initform nil)
   (customer :reader customer :initarg :customer :initform nil)))

(defun message (content &optional customer)
  (make-instance 'message :content content :customer customer))

(defgeneric set-content (msg fn)
  (:method (msg fn) (funcall fn msg))
  (:method ((msg message) fn) 
    (message (funcall fn (content msg)) (customer msg))))

;;;; actor loop (listener)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (when (not (boundp '+quit-message+)) 
    (defconstant +quit-message+ (gensym "QUIT"))))

(defun start (mb bhv &key foreground (listener #'ac-loop))
  (if foreground
    (ac-loop mb bhv)
    (async:submit-task mb listener mb bhv)))

(defun stop (mb)
  (send mb +quit-message+))

(defun ac-loop (mb bhv)
  (let ((msg (async:rcv mb)))
    (unless (eq (content msg) +quit-message+)
      (ac-loop mb (or (funcall bhv msg) bhv)))))

(defun ac-vloop (mb bhv)
  (multiple-value-bind (msg ok) (async:try-rcv mb)
    (if ok
      (if (eq (content msg) +quit-message+)
        nil
        (ac-vloop mb (or (funcall bhv msg) bhv)))
      bhv)))

;;;; the core (classical, i.e. Hewitt) actor API
;;;  there is no `become` operation: the behavior just returns the new behavior

(defun create (bhv)
  (let ((mb (async:make-mb))) 
    (start mb bhv)
    (start mb bhv :listener #'ac-vloop)
    mb))

(defun send (mb msg)
  ;(util:lgi msg)
  (async:snd mb msg)
  (multiple-value-bind (bhv done) (async:try-receive-result mb)
    (util:lgi done)
    (if (and done bhv)
      (async:submit-task mb (lambda () (ac-vloop mb bhv))))))

;;;; predefined behaviors

(defun no-op (msg))

(defun lgi (msg)
  (util:lgi (content msg)))

(defun echo (msg)
  (send (customer msg) msg))

;;;; example behavior: calculator

(defun calculator (&optional (val 0))
  (lambda (msg)
    ;(format t "calc ~a ~a~%" val (content msg))
    (destructuring-bind (fn &optional param) (content msg)
      (funcall fn msg val param))))

(defun plus (msg val param)
  (calculator (+ val param))) 
(defun minus (msg val param)
  (calculator (- val param))) 
(defun show (msg val param)
  (send (customer msg ) (message val)))