;;; -*- mode: Lisp; Syntax: Common-Lisp; -*-
;;;
;;; Copyright (c) 2009 by the authors.
;;;
;;; See LICENCE for details.

(in-package :hu.dwim.dises)

;;;;;;
;;; State

(deftype simulation-time ()
  '(or number timestamp))

(deftype wall-time ()
  'timestamp)

(defclass* simulator ()
  ((thread nil)
   (lock nil)
   (state :initializing :type (member :initializing :running :paused :finished))
   (simulation-time :type simulation-time)
   (scheduled-functions (make-container 'sorted-dlist-container
                                        ;; NOTE: cannot use :key here because we want to have multiple items
                                        ;; with the same simulation time in the queue and :test is based on the :key
                                        :sorter (lambda (e1 e2)
                                                  (simulation-time< (scheduled-at-of e1) (scheduled-at-of e2))))
                        :type sorted-list-container)))

(defclass* synchronized-simulator (simulator)
  ((last-run-wall-time :type wall-time)
   (last-run-simulation-time :type simulation-time)
   (simulation-time-to-wall-time-ratio :type number)))

(defclass* scheduled-function ()
  ((scheduled-at :type simulation-time)
   (function :type (or symbol function))))

(defvar *simulator*)

;;;;;;
;;; API

(defmacro with-simulator (simulator &body forms)
  `(bind ((*simulator* ,simulator))
     ,@forms))

(defmacro run-with-new-simulator (&body forms)
  `(with-simulator (make-instance 'simulator :simulation-time 0)
     ,@forms
     (run-simulator)))

(defmacro with-simulator-lock-held (&body forms)
  (bind ((lock (gensym))
         (body (gensym)))
    `(bind ((,lock (lock-of *simulator*)))
       (flet ((,body ()
                ,@forms))
         (if ,lock
             (with-recursive-lock-held (,lock)
               (,body))
             (,body))))))

(defun run-simulator (&optional (separate-thread nil))
  (flet ((body ()
           (unless (eq (state-of *simulator*) :finished)
             (catch 'pause-simulator
               (setf (state-of *simulator*) :running)
               (simulator-run-simulator *simulator*)))))
    (if separate-thread
        (progn
          (assert (not (thread-of *simulator*)))
          (setf (lock-of *simulator*) (make-lock "DIScrete Event Simulator"))
          (setf (thread-of *simulator*)
                (make-thread (lambda ()
                               (body)
                               (setf (thread-of *simulator*) nil)
                               (setf (lock-of *simulator*) nil)))))
        (body))))

(defgeneric simulator-run-simulator (simulator)
  (:method ((simulator simulator))
    (restart-bind
        ((pause-simulator (lambda ()
                            (pause-now)
                            (continue))
           :report-function (lambda (stream)
                              (format stream "Pause simulator after processing the current scheduled function"))))
      (iter (with scheduled-functions = (scheduled-functions-of simulator))
            (until (zerop (size scheduled-functions)))
            (with-simulator-lock-held
              (for scheduled-function = (element (first-item scheduled-functions)))
              (delete-item scheduled-functions scheduled-function)
              (setf (simulation-time-of simulator) (scheduled-at-of scheduled-function))
              (simulator-funcall-scheduled-function simulator scheduled-function))
            (finally (setf (state-of *simulator*) :finished)))))

  (:method :before ((simulator synchronized-simulator))
           (setf (last-run-wall-time-of simulator) (now))
           (setf (last-run-simulation-time-of simulator) (simulation-time-of simulator))))

(defgeneric simulator-funcall-scheduled-function (simulator scheduled-function)
  (:method ((simulator simulator) (scheduled-function scheduled-function))
    (funcall (function-of scheduled-function)))

  (:method :before ((simulator synchronized-simulator) scheduled-function)
           (bind ((wall-time-difference
                   (timestamp- (now) (last-run-wall-time-of simulator)))
                  (simulation-time-difference
                   (simulation-time- (simulation-time-of simulator) (last-run-simulation-time-of simulator)))
                  (ratio
                   (simulation-time-to-wall-time-ratio-of simulator))
                  (sleep-time
                   (- (/ simulation-time-difference ratio) wall-time-difference)))
             (if (> sleep-time 0)
                 (sleep sleep-time)))))

(defmacro schedule (when &body forms)
  (bind ((thunk
          `(lambda ()
             (with-call/cc
               ,@forms))))
    (cond ((and (symbolp when)
                (string= "now" (string-downcase (symbol-name when))))
           `(schedule-now ,thunk))
          ((or (numberp when)
               (typep when 'timestamp))
           `(schedule-at ,when ,thunk))
          ((and (consp when)
                (eq (car when) :delayed))
           `(schedule-delayed ,(cdr when) ,thunk))
          ((stringp when)
           `(schedule-at ,(parse-timestring when)
                         ,thunk))
          (t (error "Cannot schedule forms to ~A" when)))))

(defun schedule-now (function)
  (with-simulator-lock-held
    (simulator-schedule-at *simulator* (simulation-time-of *simulator*) function)))

(defun schedule-delayed (delay function)
  (with-simulator-lock-held
    (simulator-schedule-at *simulator* (simulation-time+ (simulation-time-of *simulator*) delay) function)))

(defun schedule-at (simulation-time function)
  (simulator-schedule-at *simulator* simulation-time function))

(defgeneric simulator-schedule-at (simulator simulation-time function)
  (:method ((simulator simulator) simulation-time function)
    (with-simulator-lock-held
      (assert (simulation-time<= (simulation-time-of simulator) simulation-time))
      (bind ((scheduled-function
              (make-instance 'scheduled-function
                             :scheduled-at simulation-time
                             :function function)))
        (insert-item (scheduled-functions-of simulator) scheduled-function)
        scheduled-function))))

(defun cancel-scheduled (scheduled-function)
  (with-simulator-lock-held
    (assert (typep scheduled-function 'scheduled-function))
    (bind ((x (size (scheduled-functions-of *simulator*))))
      (delete-item (scheduled-functions-of *simulator*) scheduled-function)
      (assert (= (1- x) (size (scheduled-functions-of *simulator*)))))))

(defun pause-now ()
  (schedule-now #'pause))

(defun pause-delayed (delay)
  (schedule-delayed delay #'pause))

(defun pause-at (simulation-time)
  (schedule-at simulation-time #'pause))

(defun pause ()
  (setf (state-of *simulator*) :paused)
  (throw 'pause-simulator nil))

(defun finish-now ()
  (schedule-now #'finish))

(defun finish-delayed (delay)
  (schedule-delayed delay #'finish))

(defun finish-at (simulation-time)
  (schedule-at simulation-time #'finish))

(defun finish ()
  (setf (state-of *simulator*) :finished)
  (throw 'pause-simulator nil))

(defun/cc wait (delay)
  (bind ((delay
          (if (functionp delay)
              (funcall delay)
              delay)))
    (unless (zerop delay)
      (let/cc k
        (schedule-delayed delay k)))))

;;;;;;
;;; Utility

(defgeneric simulation-time+ (time duration)
  (:method ((time number) (duration number))
    (+ time duration))

  (:method ((time timestamp) (duration number))
    (timestamp+ time duration)))

(defgeneric simulation-time- (time-1 time-2)
  (:method ((time-1 number) (time-2 number))
    (- time-1 time-2))

  (:method ((time-1 timestamp) (time-2 timestamp))
    (timestamp- time-1 time-2)))

(defgeneric simulation-time< (time-1 time-2)
  (:method ((time-1 number) (time-2 number))
    (< time-1 time-2))

  (:method ((time-1 timestamp) (time-2 timestamp))
    (timestamp< time-1 time-2)))

(defgeneric simulation-time<= (time-1 time-2)
  (:method ((time-1 number) (time-2 number))
    (<= time-1 time-2))

  (:method ((time-1 timestamp) (time-2 timestamp))
    (timestamp<= time-1 time-2)))