(module actors
  (make-actor
   make-actor-with-address
   send-message
   run
   send-and-run
   restart
   enable-trace
   disable-trace
   save-actors
   save-actors-to
   load-actors
   load-actors-from)

  (import scheme
          (chicken base)
          srfi-69
          matchable
          s11n)

  (define trace-enabled #f) ;used for debugging

  (define (enable-trace)
    (set! trace-enabled #t))

  (define (disable-trace)
    (set! trace-enabled #f))


;;;
;;; Actor creation
;;;

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

  (define (make-actor-with-address address behaviour)
    (if trace-enabled
        (print "Making actor with address " address))
    (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))))
            (case value
              ((sleep) 'do-nothing)
              ((done)
               (if trace-enabled
                   (print "Deleting actor " address))
               (hash-table-delete! actor-table address))
              (else
               (if trace-enabled
                   (print "Updating behaviour of " address))
               (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))

  (define (restart)
    (set! message-queue (make-fifo))
    (set! actor-table (make-hash-table)))

;;;
;;; Serialization
;;;

  (define (save-actors-to filename)
    (with-output-to-file filename
      (lambda ()
        (serialize (hash-table->alist actor-table)))))

  (define (save-actors)
    (save-actors-to "image"))

  (define (load-actors-from filename)
    (set! actor-table
      (alist->hash-table (with-input-from-file filename deserialize))))

  (define (load-actors)
    load-actors-from "image"))