109 lines
3.1 KiB
Common Lisp
109 lines
3.1 KiB
Common Lisp
;;;; cl-scopes/core/actor - basic actor definitions
|
|
|
|
(defpackage :scopes/core/actor
|
|
(:use :common-lisp)
|
|
(:local-nicknames (:async :scopes/util/async)
|
|
(:util :scopes/util))
|
|
(:export #:actor #:bg-actor #:fg-actor #:make-actor #:start #:stop
|
|
#:become #:create #:send
|
|
#:message #:content #:customer
|
|
#:*logger* #:*root*
|
|
#:echo #:inc #:lgi
|
|
#:calculator #:plus #:minus #:show #:send-value))
|
|
|
|
(in-package :scopes/core/actor)
|
|
|
|
;;;; basic message and actor implementations
|
|
|
|
(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))
|
|
|
|
(defclass actor ()
|
|
((behavior :accessor behavior :initarg :behavior :initform #'no-op)))
|
|
|
|
(defclass bg-actor (actor)
|
|
((task :accessor task :initform nil)))
|
|
|
|
(defclass fg-actor (bg-actor) ())
|
|
|
|
(defgeneric start (ac)
|
|
(:method ((ac actor)))
|
|
(:method ((ac bg-actor))
|
|
(setf (task ac) (make-task ac))
|
|
(async:start (task ac)))
|
|
(:method ((ac fg-actor))
|
|
(setf (task ac) (make-task ac 'async:fg-task))
|
|
(async:start (task ac))))
|
|
|
|
(defgeneric stop (ac)
|
|
(:method ((ac actor)))
|
|
(:method ((ac bg-actor))
|
|
(async:stop (task ac))))
|
|
|
|
(defun make-actor (bhv &optional (cls 'actor) &rest args &key &allow-other-keys)
|
|
(apply #'make-instance cls :behavior bhv args))
|
|
|
|
(defun make-task (ac &optional (cls 'async:bg-task))
|
|
(async:make-task :cls cls
|
|
:handle-message
|
|
#'(lambda (ax msg) (funcall (behavior ac) ac msg))))
|
|
|
|
;;;; the core (classical, i.e. Hewitt) actor API
|
|
|
|
(defun become (ac bhv)
|
|
(setf (behavior ac) bhv))
|
|
|
|
(defun create (bhv &optional (cls 'actor) &rest args &key &allow-other-keys)
|
|
(let ((ac (apply #'make-actor bhv cls args)))
|
|
(start ac)
|
|
ac))
|
|
|
|
(defgeneric send (addr content &key &allow-other-keys)
|
|
(:method ((addr t) (content t) &key customer &allow-other-keys)
|
|
(let ((ac addr) (msg (message content customer)))
|
|
(send ac msg)))
|
|
(:method ((ac actor) (msg message) &key &allow-other-keys)
|
|
(funcall (behavior ac) ac msg))
|
|
(:method ((ac bg-actor) (msg message) &key &allow-other-keys)
|
|
(async:send (task ac) msg)))
|
|
|
|
;;;; predefined behaviors
|
|
|
|
(defun no-op (ac msg))
|
|
|
|
(defun lgi (ac msg)
|
|
(util:lgi (content msg)))
|
|
|
|
(defun echo (ac msg)
|
|
(send (customer msg) msg))
|
|
|
|
;;;; predefined global actors
|
|
|
|
(defvar *logger* (create #'lgi))
|
|
|
|
(defclass root (actor) ())
|
|
|
|
(defun root-bhv (ac msg)
|
|
(send *logger* msg))
|
|
|
|
(defvar *root* (create #'root-bhv 'root))
|
|
|
|
;;;; example behavior: calculator
|
|
|
|
(defun calculator (&optional (val 0))
|
|
#'(lambda (ac msg)
|
|
(destructuring-bind (fn &optional param) (content msg)
|
|
(funcall fn ac msg val param))))
|
|
|
|
(defun plus (ac msg val param)
|
|
(become ac (calculator (+ val param))))
|
|
(defun minus (ac msg val param)
|
|
(become ac (calculator (- val param))))
|
|
(defun show (ac msg val param)
|
|
(send (or (customer msg) *logger*) val))
|
|
(defun send-value (ac msg val param)
|
|
(send (customer msg) val))
|