;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: CCL; Base: 10 -*-
;;
;; call-at.lisp
;; Scheduled and delayed execution.
;;
;; Copyright (C) 2002 Terje Norderhaug and Media Design in*Progress.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Library General Public
;; License version 2 as published by the Free Software Foundation.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Library General Public License version 2 for details.
;; 
;; The GNU Library General Public License is available on the web
;; from <http://www.gnu.org/copyleft/lgpl.html> or by writing to the
;; Free Software Foundation, Inc., 59 temple Place - Suite 330,
;; Boston, MA 02111-1307, USA. 
;;
;; Note that this is a different license from the more restrictive GNU GPL license.
;; If this license by any reason doesn't suit your needs, contact
;; the copyright holder of this library by sending an email to Terje Norderhaug 
;; at <terje@in-progress.com>. Please submit modifications of
;; the library to the same address. Any submitted modifications will 
;; automatically fall under the terms of this license unless otherwise specified.

(in-package :ccl)

(eval-when (:execute :compile-toplevel :load-toplevel)
  (export '(call-at
            call-later
            cancel-atjob
            reset-atjob
            process-interrupt-at
            process-interrupt-later
            )))

#+mcl ; candidate for adding to MCL together with cheap-cons et al.
(defun delete-and-free (item list)
  "Delete an item from a list, freeing the cons for reuse"
  (if (eq item (car list))
    (prog1
      (cdr list)
      (ccl::free-cons list))
    (let* ((splice (member item list :key #'cdr))
           (cons (cdr splice)))
      (when splice
        (rplacd splice (cddr splice))
        (ccl::free-cons cons)
        list))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ORDERED LIST OF JOBS

(defstruct atjobs
  waiting)

(defun make-atjob (time function &rest args)
  (declare (dynamic-extent args))
  (apply #+mcl #'ccl::cheap-list #-mcl #'list time function args))

(defun free-atjob (job)
  #+mcl (ccl::cheap-free-list job))

(defun remove-atjob (job jobs)
  (without-interrupts 
   (setf (atjobs-waiting jobs)
         (#-mcl delete #+mcl delete-and-free job (atjobs-waiting jobs)))))

(defun deq-atjob (jobs)
  (without-interrupts
     #+mcl (let ((waiting (atjobs-waiting jobs)))
             (prog1 
               (ccl::pop-and-free waiting)
               (setf (atjobs-waiting jobs) waiting)))
     #-mcl (pop (atjobs-waiting jobs))))

(defun enq-atjob (job jobs)
  (without-interrupts
   (setf (atjobs-waiting jobs)
         (merge 'list
                (atjobs-waiting jobs) 
                (#+mcl ccl::cheap-cons #-mcl cons job NIL) #'< :key #'car))))

(defun next-atjob (jobs)
  (car (atjobs-waiting jobs)))

(defun atjobs-scheduled-time (jobs)
  "The time when the first atjob is scheduled to run"
  (car (next-atjob jobs)))

(defun execute-atjob (job)
  (when job
    (prog1
      (apply (cadr job) (cddr job))
      (free-atjob job))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *atjobs* (make-atjobs))

(defparameter *atjob-timer* NIL)

(defun update-atjob-timer ()
  "Call to update the timer whenever the first waiting atjob changes"
  (process-unblock *atjob-timer*))

(defun call-at (universal-time function &rest args)
  "Applies the function to the arguments at a specified universal time, returning a job descriptor"
  #+mcl (declare (dynamic-extent args))
  (flet ((timer ()
             (unwind-protect
               (loop
                 for job =
                 (without-interrupts
                  (if (atjobs-waiting *atjobs*)
                    (process-block-with-timeout *current-process* 
                                                (max 0 (* 60 (- (atjobs-scheduled-time *atjobs*)
                                                                (get-universal-time))))
                                                "countdown")
                    (process-block *current-process* "stopped"))
                  (when (and (atjobs-waiting *atjobs*)
                             (<= (atjobs-scheduled-time *atjobs*) 
                                 (get-universal-time)))
                    (deq-atjob *atjobs*)))
                 do (execute-atjob job))
               (setf *atjob-timer* NIL))))
    (let ((job (apply #'make-atjob universal-time function args)))
      (without-interrupts
       (enq-atjob job *atjobs*)
       (if *atjob-timer*
         (when (eq job (next-atjob *atjobs*))
           (update-atjob-timer))
         (setf *atjob-timer*
               (process-run-function "At Jobs" #'timer))))
      job)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ALTERNATIVE IMPLEMENTATION WHEN TIMERS.LISP FROM THE MCL EXAMPLES IS LOADED: 

(eval-when (:compile-toplevel :execute :load-toplevel)
  (when (ccl::module-loaded-p "timers")  ; (require :timers)

(defun update-atjob-timer ()
  (without-interrupts
   (if (atjobs-waiting *atjobs*)
     (reset-timer-absolute *atjob-timer* (atjobs-scheduled-time *atjobs*))
     (clear-timer *atjob-timer*))))

(defun call-at (universal-time function &rest args)
  (let ((job (apply #'make-atjob universal-time function args)))
    (without-interrupts
     (enq-atjob job *atjobs*))
    (without-interrupts
     (unless *atjob-timer*
       (setf *atjob-timer*
             (create-timer-call
              (lambda (&rest rest)
                (declare (ignore rest))
                (execute-atjob (deq-atjob *atjobs*))
                (update-atjob-timer)) 
              NIL
              :name "At Jobs"))))
    (update-atjob-timer)
    job))

)) ; end eval-when

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; USEFUL FUNCTIONS

(defun cancel-atjob (job)
  "Cancels a job by removing it from being scheduled"
 (without-interrupts 
  (let ((first? (eq job (next-atjob *atjobs*))))
    (remove-atjob job *atjobs*)
    (free-atjob job)
    (when first?
      (update-atjob-timer)))))

(defun reset-atjob (job universal-time)
  "Reschedules the job to be executed at a new time"
 (without-interrupts 
  (let ((first? (eq job (next-atjob *atjobs*))))
    (remove-atjob job *atjobs*)
    (setf (car job) universal-time)
    (enq-atjob job *atjobs*)
    (when (or first? 
              (eq job (next-atjob *atjobs*))) ; job moved to front!
      (update-atjob-timer)))))

(defun call-later (seconds function &rest args)
  (declare (dynamic-extent args))
  (apply #'call-at (+ (get-universal-time) seconds) function args))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; INTERRUPT PROCESS

;; These methods can be implemented without requiring their own process by 
;; for example piggybacking on the process scheduler.

(defun process-interrupt-at (process universal-time function &rest args)
  (declare (dynamic-extent args))
  (apply #'call-at universal-time
         #'process-interrupt process 
         function args))

(defun process-interrupt-later (process seconds function &rest args)
  (declare (dynamic-extent args))
  (apply #'process-interrupt-at process (+ (get-universal-time) seconds) function args))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#| EXAMPLE

(defmacro with-timeout ((seconds &body timeout-forms) &body body
                        &aux (job (gensym))(exit (gensym "EXIT")) (ret (gensym "RET")))
  `(block ,ret
     (flet ((,exit ()
              (return-from ,ret
                (progn ,@timeout-forms))))
       (declare (dynamic-extent ,exit))
       (multiple-value-bind (,job)
        (process-interrupt-later *current-process* ,seconds #',exit)
         (return-from ,ret
           (unwind-protect
             (progn ,@body)
             (cancel-atjob ,job)))))))
|#

#| TESTING

(call-later 15 #'beep)
(time (call-later 3 #'beep))

*at-jobs*

(defparameter counter 0)

(defun test ()
  (setf counter 0)
  (with-timeout (5 counter)  
    (loop (incf counter))))

(time (test))
|#