(import srfi-69 matchable)

(define trace-enabled #t)

;;;
;;; Actor creation
;;;

(define actor-table (make-hash-table))

(define (make-actor-with-address address behaviour)
  (hash-table-set! actor-table address behaviour)
  address)

(define next-actor-address 1)

(define (make-actor behaviour)
  (make-actor-with-address next-actor-address behaviour)
  (let ((address next-actor-address))
    (set! next-actor-address (+ next-actor-address 1))
    address))

;;;
;;; Message dispatch
;;;

(define (dispatch-message address message)
  (if trace-enabled
      (print "Dispatching message " message " to " address))
  (let ((behaviour (hash-table-ref/default actor-table address '())))
    (if (null? behaviour)
        (print "Warning: discarded message " message " to unknown actor " address)
        (let ((value (apply behaviour (cons address message))))
          (match value
            ('done (hash-table-delete! actor-table address))
            ('sleep 'do-nothing)
            (else
             hash-table-set! actor-table address value))))))

;;;
;;; FIFO queue implementation
;;;

(define (make-fifo)
  (define (cell val prev next)
    (list val prev next))
  (define cell-val car)
  (define cell-prev cadr)
  (define cell-next caddr)
  (define (set-cell-prev! cell prev-cell)
    (set-car! (cdr cell) prev-cell))
  (define (set-cell-next! cell next-cell)
    (set-car! (cddr cell) next-cell))

  (let ((head '())
        (tail '()))
    (lambda (cmd . args)
      (case cmd
        ((empty?) (null? head))
        ((push) (if (not (= (length args) 1))
                    (error "Wrong number of arguments to push.")
                    (if (not (null? head))
                        (let ((old-head head))
                          (set! head (cell (car args) '() old-head))
                          (set-cell-prev! old-head head))
                        (begin
                          ;; Initialize list
                          (set! head (cell (car args) '() '()))
                          (set! tail head)))))
        ((pop) (if (not (= (length args) 0))
                   (error "Wrong number of arguments to pop.")
                   (if (null? head)
                       (error "FIFO empty.")
                       (let ((old-tail tail))
                         (set! tail (cell-prev old-tail))
                         (if (null? tail)
                             (set! head '())
                             (set-cell-next! tail '()))
                         (cell-val old-tail)))))))))

(define (fifo-push fifo x)
  (fifo 'push x))

(define (fifo-pop fifo)
  (fifo 'pop))

(define (fifo-empty? fifo)
  (fifo 'empty?))


;;;
;;; Message queue
;;;

(define message-queue (make-fifo))

(define (next-addressed-msg)
  (if (fifo-empty? message-queue)
      '()
      (fifo-pop message-queue)))

(define (send-message actor . message)
  (if trace-enabled
      (print "Queued message " message " to " actor))
  (fifo-push message-queue (cons actor message)))

(define (process-next-message)
  (let ((addressed-msg (next-addressed-msg)))
    (if (null? addressed-msg)
        '()
        (let ((address (car addressed-msg))
              (message (cdr addressed-msg)))
          (dispatch-message address message)))))

(define (run)
  (unless (null? (process-next-message))
    (run)))

(define (send-and-run actor . message)
  (apply send-message (cons actor message))
  (run))

;;;
;;; Testing
;;;

(define factorial
  (make-actor-with-address 'factorial
   (lambda (self customer . message)
     (match message
       ((n) (send-message self customer n 1) 'sleep)
       ((0 acc) (send-message customer acc) 'done)
       ((n acc) (send-message self customer (- n 1) (* acc n)) 'sleep)))))

(define println
  (make-actor-with-address 'println
   (lambda (self . message)
     (apply print message)
     'sleep)))

(send-message factorial println 5)
(send-message factorial println 7)
(run)