Actor model in Scheme

actor.scm

(use-modules (ice-9 match))
;; An actor is a computational entity that, in response to a message
;; it receives, can concurrently:

;; send a finite number of messages to other actors;
;; create a finite number of new actors;
;; designate the behavior to be used for the next message it receives.

;; So it's a dispatch of sorts.

;; And this happens only through messages.

;; Since we need to simulate multiple concurrent events, we need to
;; have some sort of global queue of them.  Once the queue is empty
;; then we stop.

;; For efficiency, when we implement queues we should have pointers to
;; the end and beginning of the queue, pointing to the first and last
;; elements of the queue.

;; When an actor sends a message it adds it to the end of the queue.

(define *gensym-count* 0)
(define (gensym)
  (let ((res (string->symbol (format #f "g~a" *gensym-count*))))
    (set! *gensym-count* (1+ *gensym-count*))
    res))

(define (front-ptr queue) (car queue))

(define (rear-ptr queue) (cdr queue))

(define (set-front-ptr! queue item)
  (set-car! queue item))

(define (set-rear-ptr! queue item)
  (set-cdr! queue item))

(define (empty-queue? queue)
  (null? (front-ptr queue)))

(define (make-queue) (cons '() '()))


(define (front-queue queue)
  (if (empty-queue? queue)
      (error "FRONT called with an empty queue" queue)
      (car (front-ptr queue))))

;; Insert an element at the end of the queue.
(define (insert-queue! queue item)
  (let ((new-pair (cons item '())))
    (cond ((empty-queue? queue)
           (set-front-ptr! queue new-pair)
           (set-rear-ptr! queue new-pair)
           queue)
          (else
           (set-cdr! (rear-ptr queue) new-pair)
           (set-rear-ptr! queue new-pair)
           queue))))

;; This deletes the front element of the queue.
(define (delete-queue! queue)
  (cond ((empty-queue? queue)
         (error "DELETE! called with an empty queue" queue))
        (else (set-front-ptr! queue (cdr (front-ptr queue)))
              queue)))

;; The alist of actors.
(define *actors* '())
;; The state of the system is just the queue of messages to be sent.
(define *mailbox* (make-queue))

;; What are actors?  They can run arbitrary procedures that do not
;; depend on external state and also set a new action to perform on
;; the next message.  The handler is assumed to be a one-argument
;; procedure that also holds the internal state.

(define (add-nameless-actor! actor-name handler)
  (set! *actors* `((,actor-name . ,handler) . ,*actors*)))

(define-syntax spawn!
  (syntax-rules ()
    ((_ name creator)
     (add-nameless-actor! name (creator name)))
    ((_ name creator . args)
     (add-nameless-actor! name (creator name . args)))))

;; Send a message to an actor.  This is done immediately by adding an
;; entry to the queue.  We also require the from address, this is
;; easily spoofed, although in a real system one could imagine that
;; the messages are signed.
(define (send-msg! from to msg)
  (insert-queue! *mailbox* `(,from ,to . ,msg)))

(define (msg-from msg) (car msg))
(define (msg-to msg) (cadr msg))
(define (msg-content msg) (cddr msg))

(define debug? #f)
;; Run a single tick.
(define (tick!)
  (if (empty-queue? *mailbox*)
      (format #t "No more messages.\n")
      (let* ((msg (front-queue *mailbox*))
             (from (msg-from msg))
             (to (msg-to msg))
             (content (cons from (msg-content msg)))
             (dest (assq to *actors*)))
        (if (null? dest)
            (error (format #f "SEND-MSG: no actor ~a found!" to))
            (begin
              (if debug? (format #t "~a\n" msg))
              ((cdr dest) content)
              (delete-queue! *mailbox*))))))

;; Tick until no messages are left.
(define (tick-all!)
  (if (empty-queue? *mailbox*)
      (format #t "No more messages.\n")
      (begin (tick!)
             (tick-all!))))

(define (reset-actors!) (set! *actors* '()))
(define (reset-mailbox!) (set! *mailbox* (cons '() '())))
(define (reset-all!)
  (format #t "Resetting actors and mailbox...\n")
  (reset-actors!)
  (reset-mailbox!))

;; An actor that's a counter.
(define (make-counter my-name)
  (let ((state 0))
    (lambda (m)
      (match (cdr m) ;; we don't care who sent it.
        ('inc (set! state (1+ state)))
        ('report (format #t "~a\n" state))))))

;; We can make a circuit!

;; We propagate signals forward.  So an AND gate will send a 1 if and
;; only if it currently knows that both of its inputs are 1.

;; Since we're using a queue, we automatically are able to interleave
;; updates almost as if we were running in parallel.

;; We make connections between gates explicit, because a single wire
;; may send messages to several components.

;; After our state is updated, we immediately send messages to all
;; connected components to do the same as well.
(define (make-wire my-name)
  (let ((my-signal #f) (connected-components '()))
    (lambda (m)
      (match m
        (`(,sender set-my-signal! ,(? boolean? x))
         (begin
           (set! my-signal x)
           (for-each (lambda (component)
                       (send-msg! my-name
                                  component
                                  `(set-my-signal! ,my-signal)))
                     connected-components)))
        (`(,sender connect! ,(? symbol? component))
         (begin
           (set! connected-components `(,component . ,connected-components))
           (send-msg! my-name component `(set-my-signal! ,my-signal))))
        ;; Report the current signal to an actor.  This is really
        ;; valuable.  Say we have an AND gate called Z that has two
        ;; input gates called X and Y.

        ;; What Z can do is send a message to X and Y, telling it to
        ;; report the signal back to Z. 
        (`(,sender . report-signal)
         (send-msg! my-name sender my-signal))
        (_
         (error (format #f "MAKE-WIRE: malformed message: ~a" m)))))))

(define (connect! from wire connectee)
  (send-msg! from wire `(connect! ,connectee)))

(define (set-my-signal! from wire signal)
  (send-msg! from wire `(set-my-signal! ,signal)))

(define (report-signal from wire)
  (send-msg! from wire `report-signal))

(define (make-displayer my-name)
  (lambda (m)
    (let ((from (car m)) (msg (cdr m)))
      (format #t "Message from ~a: ~a\n" from msg))))


(define (and-gate my-name in1 in2 out)
  (connect! my-name in1 my-name)
  (connect! my-name in2 my-name)
  (let ((in-signals `((,in1 . #f) (,in2 . #f)))
        (my-signal #f))
    (lambda (m)
      (match m
        (`(,sender set-my-signal! ,(? boolean? x))
         (begin
           (assv-set! in-signals sender x)
           (set! my-signal (and-map cdr in-signals))
           (send-msg! my-name out `(set-my-signal! ,my-signal))))
        (`(,sender connect! ,(? symbol? component))
         (connect! my-name out component))

        (`(,sender . report-signal)
         (send-msg! my-name sender my-signal))
        (_
         (error (format #f "AND-GATE: malformed message: ~a" m)))))))


(define (or-gate my-name in1 in2 out)
  (connect! my-name in1 my-name)
  (connect! my-name in2 my-name)
  (let ((in-signals `((,in1 . #f) (,in2 . #f)))
        (my-signal #f))
    (lambda (m)
      (match m
        (`(,sender set-my-signal! ,(? boolean? x))
         (begin
           (assv-set! in-signals sender x)
           (set! my-signal (or-map cdr in-signals))
           (send-msg! my-name out `(set-my-signal! ,my-signal))))
        (`(,sender connect! ,(? symbol? component))
         (connect! my-name out component))

        (`(,sender . report-signal)
         (send-msg! my-name sender my-signal))
        (_
         (error (format #f "OR-GATE: malformed message: ~a" m)))))))

(define (inverter my-name in out)
  (connect! my-name in my-name)
  (let ((my-signal #f))
    (lambda (m)
      (match m
        (`(,sender set-my-signal! ,(? boolean? x))
         (if (eqv? sender in)
             (begin
               (set! my-signal (not x))
               (send-msg! my-name out `(set-my-signal! ,my-signal)))
             (error
              (format #f
                      "INVERTER: ~a tried to set signal ~a"
                      sender x))))
        (`(,sender connect! ,(? symbol? component))
         (connect! my-name out component))

        (`(,sender . report-signal)
         (send-msg! my-name sender my-signal))
        (_
         (error (format #f "INVERTER: malformed message: ~a" m)))))))


(define (half-adder my-name a b s c)
  (let ((d (gensym)) (e (gensym))
        (g0 (gensym)) (g1 (gensym)) (g2 (gensym)) (g3 (gensym)))
    (spawn! d make-wire)
    (spawn! e make-wire)
    (spawn! g0 or-gate a b d)
    (spawn! g1 and-gate a b c)
    (spawn! g2 inverter c e)
    (spawn! g3 and-gate d e s)
    (lambda (m) m)))

(define (full-adder my-name a b c-in sum c-out)
  (let ((s (gensym)) (c1 (gensym)) (c2 (gensym))
        (g0 (gensym)) (g1 (gensym)) (g2 (gensym)))
    (spawn! s make-wire)
    (spawn! c1 make-wire)
    (spawn! c2 make-wire)
    (spawn! g0 half-adder b c-in s c1)
    (spawn! g1 half-adder a s sum c2)
    (spawn! g2 or-gate c1 c2 c-out)
    (lambda (m) m)))


(define (make-timer my-name)
  (let ((state 0) (stopped? #f))
    (define (do-tick)
      (set! state (1+ state))
      (send-msg! my-name my-name 'tick))
    (define (do-report sender)
      (send-msg! my-name sender state)
      (set! stopped? #t))

    (lambda (m)
      (if stopped?
          m
          (match m
            (`(,sender . tick)  (do-tick))
            (`(,sender . report) (do-report sender)))))))

(define (signal-demo)
  (reset-all!)
  (spawn! 'root make-displayer)
  (send-msg! 'root 'root "Start of signal demo...")
  (spawn! 'a make-wire)
  (spawn! 'b make-wire)
  (connect! 'root 'a 'b)
  (set-my-signal! 'root 'a #t)
  ;; Now that we set up the circuit, we can propagate the signal.
  (tick-all!)

  ;; Let's check the value of b.
  (report-signal 'root 'b)

  (tick-all!)
  
  )

(define (and-demo)
  (reset-all!)
  (spawn! 'root make-displayer)
  (send-msg! 'root 'root "Start of AND demo...")
  (spawn! 'a make-wire)
  (spawn! 'b make-wire)
  (spawn! 'd make-wire)
  (spawn! 'c and-gate 'a 'b 'd)

  (set-my-signal! 'root 'a #t)
  (set-my-signal! 'root 'b #t)
  (tick-all!)
  
  (report-signal 'root 'a)
  (report-signal 'root 'b)
  (report-signal 'root 'c)
  (report-signal 'root 'd)
  (tick-all!)
  )


(define (or-demo)
  (reset-all!)
  (spawn! 'root make-displayer)
  (send-msg! 'root 'root "Start of OR demo...")
  (spawn! 'a make-wire)
  (spawn! 'b make-wire)
  (spawn! 'd make-wire)
  (spawn! 'c or-gate 'a 'b 'd)

  (set-my-signal! 'root 'a #t)
  (set-my-signal! 'root 'b #t)
  (tick-all!)
  
  (report-signal 'root 'a)
  (report-signal 'root 'b)
  (report-signal 'root 'c)
  (report-signal 'root 'd)
  (tick-all!)
  )



(define (inverter-demo)
  (reset-all!)
  (spawn! 'root make-displayer)
  (send-msg! 'root 'root "Start of inverter demo...")
  (spawn! 'a make-wire)
  (spawn! 'c make-wire)
  (spawn! 'b inverter 'a 'c)

  (set-my-signal! 'root 'a #t)
  (tick-all!)
  
  (report-signal 'root 'a)
  (report-signal 'root 'b)
  (report-signal 'root 'c)
  (tick-all!)
  )

(define (adder-demo)
  (reset-all!)
  (spawn! 'root make-displayer)
  (spawn! 'timer make-timer)
  (send-msg! 'root 'timer 'tick)
  (tick!)
  (send-msg! 'root 'root "Start of adder demo...")
  (tick!)
  (spawn! 'a make-wire)
  (spawn! 'b make-wire)
  (spawn! 'c make-wire)
  (spawn! 'd make-wire)
  (spawn! 'e make-wire)

  (spawn! 'adder full-adder 'a 'b 'c 'd 'e)
  (tick!)
  (set-my-signal! 'root 'a #t)
  (tick!)
  (send-msg! 'root 'timer 'report)
  (tick-all!)
  (report-signal 'root 'a)
  (report-signal 'root 'b)
  (report-signal 'root 'c)
  (report-signal 'root 'd)
  (report-signal 'root 'e)


  (tick-all!)
  )

(define (report-signals-now root l)
  (tick-all!)
  (for-each (lambda (x) (report-signal root x)) l)
  (tick-all!))