;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10 -*-

;;;; Limitime = Tools to limit computation time. A part of Limitools.

;;;; (c) Juan Jose Garcia 2007
;;;; juanjo@eurogaran.com
;;;;
;;;; Licence
;;;; =======
;;;;
;;;; This software is provided 'as-is', without any express or implied
;;;; warranty. In no event will the author be held liable for any damages
;;;; arising from the use of this software.
;;;;
;;;; Permission is granted to anyone to use this software for any purpose,
;;;; including commercial applications, and to alter it and redistribute
;;;; it freely, subject to the following restrictions:
;;;;
;;;; 1. The origin of this software must not be misrepresented; you must
;;;;    not claim that you wrote the original software. If you use this
;;;;    software in a product, an acknowledgment in the product documentation
;;;;    would be appreciated but is not required.
;;;;
;;;; 2. Altered source versions must be plainly marked as such, and must
;;;;    not be misrepresented as being the original software.
;;;;
;;;; 3. All altered versions must include source, or make the source
;;;;    easy available on the internet or by any other means when required.
;;;;
;;;; 4. This notice may not be removed or altered from any source distribution,
;;;;    whether modified or not.
;;;;
;;;; 5. Use of the same function names in otherwise unrelated code is allowed
;;;;    and in fact encouraged, as long as function behavior is kept.
;;;;
;;;; Notes
;;;; =====
;;;;
;;;; More recent versions of this software may be available at:
;;;;   http://www.eurogaran.com/downloads/lisp/
;;;;
;;;; Comments, suggestions and bug reports to the author,
;;;; Juanjo Garcia, at:
;;;; juanjo@eurogaran.com


;;; with-max-time is a wrapper that implements a
;;; functionality essential for programs that test
;;; other programs, possibly written by them,
;;; what is known as speculative programming.
;;; Example:  (with-max-time 5 (loop)) would
;;; execute an empty loop during aprox. 5 seconds

(defmacro with-max-time (seconds &body body)
; Comment on the comment :
; The opening curly bracket inside this documentation string is misteriously
; necessary for Allegro to compile and for Emacs to colorize right.
"Abandon processing when not finished at the specified time limit.
Package:  CL-USER     Type:  [macro]
Arg 1:  SECONDS [non-negative real or some expression that evaluates to that]
Execution time is guaranteed not to be greater, though it could be less.
Rest :  The forms to be processed.
Results:  The results of processing, or no values if abandoned.
Side effects:  Does not have any itself. Beware if the forms to be processed
work by side effects; then program behavior could be unpredictable.
Note :  A result of NIL will be indistinguishable from no results when using
constructs like  (if (with-max-time... This ambiguity is both deliberate and useful.
To determine whether evaluation really completed, use instead a construct like
{multiple-value-list (with-max-time...
that produces in each case either (NIL) or NIL, which are different in Lisp :
NIL is false, whereas (NIL) is (not NIL) = true."

  #+allegro
  (let ((valsecs (gensym))
        (results (gensym))
        (computs (gensym))
        (mintime 0.01)) ; minimum period of time measurable = precision
    (declare (type float mintime))

    `(require :process)
    `(let* ((,valsecs (- (eval ,seconds) ,mintime))
            ,results
            (,computs (mp:process-run-function
                       `(:name "with-max-time-active-process"
                         :initial-bindings
                         ((*readtable* . ',*readtable*)
                          ,@*default-cg-bindings*
                          ,@excl:*cl-default-special-bindings*))
                       #'(lambda (*standard-input* *terminal-io* *query-io*)
                           (setq ,results (multiple-value-list
                                           (progn ,@body))))
                       *standard-input* *terminal-io* *query-io*)))
      (declare (type list ,results) (type real ,valsecs)
       (type mp:process ,computs))

      (when (minusp ,valsecs)
        (setq ,valsecs 0)
        (warn " Time arg. negative or inferior to minim. Assuming 0."))

      (unwind-protect
           (progn (mp:process-wait-with-timeout
                   "with-max-time-waiting-process"
                   ,valsecs
                   #'(lambda () (not (mp:process-active-p ,computs))))
                  (values-list ,results))
        (if (mp:process-active-p ,computs)
          (mp:process-kill ,computs :wait nil)))))

  #+cormanlisp
  (let ((valsecs (gensym))
        (results (gensym))
        (computs (gensym))
        (complet (gensym))
        (fintime (gensym))
        (mintime 0.02)) ; poll every granularity seconds precision
    (declare (type float mintime))

    `(require 'THREADS)
    `(let* ((,valsecs (truncate (* (- (eval ,seconds) ,mintime)
                                   internal-time-units-per-second))))
      (declare (type integer ,valsecs))

      (when (minusp ,valsecs)
        (setq ,valsecs 0)
        (warn " Time arg. negative or inferior to minim. Assuming 0."))

      (let* (,results
             ,complet
             (,fintime (+ ,valsecs (get-internal-real-time)))
             (,computs (th:create-thread
                        #'(lambda () (setq ,results (multiple-value-list
                                                     (progn ,@body))
                                           ,complet t))
                        :report-when-finished nil)))
        (declare (type list ,results) (type integer ,fintime)
                 (type boolean ,complet))

        (unwind-protect
             (progn (loop while (and (not ,complet)
                                     (< (get-internal-real-time) ,fintime))
                          do (sleep ,mintime))
                    (values-list ,results))
          (if (not ,complet)
            (ignore-errors (th:terminate-thread ,computs)))))))

  #+genera
  (let ((valsecs (gensym))
        (results (gensym))
        (complet (gensym))
        (computs (gensym)))
    `(let* ((,valsecs (eval ,seconds))
            ,results
            ,complet
            (,computs (process:process-run-function
                       "with-max-time-active-process"
                       #'(lambda (*standard-input* *terminal-io* *query-io*)
                           (setq ,results (multiple-value-list
                                           (progn ,@body))
                                 ,complet t))
                       *standard-input* *terminal-io* *query-io*)))
      (declare (type list ,results) (type boolean ,complet) (type real ,valsecs)
	   (type process ,computs))

      (when (minusp ,valsecs)
        (setq ,valsecs 0)
        (warn " Time arg. negative or inferior to minim. Assuming 0."))

      (unwind-protect
           (progn (process:process-wait-with-timeout
                   "with-max-time-waiting-process"
                   ,valsecs
                   #'(lambda () ,complet))
                  (values-list ,results))
        (process:process-kill ,computs))))

  #+lispworks
  (let ((valsecs (gensym))
        (results (gensym))
        (complet (gensym))
        (computs (gensym))
        (mintime 0.09))
    (declare (type float mintime))

    `(let* ((,valsecs (- (eval ,seconds) ,mintime))
            ,results
            ,complet
            (,computs (mp:process-run-function
                       "with-max-time-active-process"
                       '()
                       #'(lambda (*standard-input* *terminal-io* *query-io*)
                           (setq ,results (multiple-value-list
                                           (progn ,@body))
                                 ,complet t))
                       *standard-input* *terminal-io* *query-io*)))
      (declare (type list ,results) (type boolean ,complet) (type real ,valsecs)
       (type mp:process ,computs))

      (when (minusp ,valsecs)
        (setq ,valsecs 0)
        (warn " Time arg. negative or inferior to minim. Assuming 0."))

      (unwind-protect
           (progn (mp:process-wait-with-timeout
                   "with-max-time-waiting-process"
                   ,valsecs
                   #'(lambda () ,complet))
                  (values-list ,results))
        (mp:process-kill ,computs))))

  #+openmcl
  (let ((valsecs (gensym))
        (results (gensym))
        (complet (gensym))
        (computs (gensym))
        (mintime 0.02))
    (declare (type float mintime))

    `(let* ((,valsecs (truncate (* *TICKS-PER-SECOND*
                                   (- (eval ,seconds) ,mintime))))
            ,results
            ,complet
            (,computs (ccl:process-run-function
                       "with-max-time-active-process"
                       #'(lambda (*standard-input* *terminal-io* *query-io*)
                           (setq ,results (multiple-value-list
                                           (progn ,@body))
                                 ,complet t))
                       *standard-input* *terminal-io* *query-io*)))
      (declare (type list ,results) (type boolean ,complet) (type integer ,valsecs)
       (type ccl:process ,computs))

      (when (minusp ,valsecs)
        (setq ,valsecs 0)
        (warn " Time arg. negative or inferior to minim. Assuming 0."))

      (unwind-protect
           (progn (ccl:process-wait-with-timeout
                   "with-max-time-waiting-process"
                   ,valsecs
                   #'(lambda () ,complet))
                  (values-list ,results))
        (ccl:process-kill ,computs))))

  #+sbcl
  (let ((valsecs (gensym))
        (results (gensym))
        (computs (gensym))
        (fintime (gensym))
        (mintime 0.02)) ; poll every granularity seconds precision
    (declare (type float mintime))

    `(let ((,valsecs (truncate (* (- (eval ,seconds) ,mintime)
                                   internal-time-units-per-second))))
      (declare (type integer ,valsecs))
      (when (minusp ,valsecs)
        (setq ,valsecs 0)
        (warn " Time arg. negative or inferior to minim. Assuming 0."))
      (let* (,results
             (,fintime (+ ,valsecs (get-internal-real-time)))
             (,computs (sb-thread:make-thread
                        #'(lambda () (setq ,results (multiple-value-list
                                                     (progn ,@body)))))))
        (declare (type list ,results) (type integer ,fintime)
                 (sb-ext:muffle-conditions sb-ext:compiler-note))

        (unwind-protect
             (progn (loop while (and (sb-thread:thread-alive-p ,computs)
                                     (< (get-internal-real-time) ,fintime))
                          do (sleep ,mintime))
                    (values-list ,results))
          (if (sb-thread:thread-alive-p ,computs)
            (sb-thread:terminate-thread ,computs))))))

  ;; IMPORTANT: Aborting computation is not safe in Scieneer CL. Consult doc.
  #+scl
  (let ((valsecs (gensym))
        (results (gensym))
        (computs (gensym))
        (complet (gensym))
        (fintime (gensym))
        (mintime 0.005)) ; poll every granularity seconds precision
    (declare (type float mintime))

    `(let ((,valsecs (truncate (* (- (eval ,seconds) ,mintime)
                                   internal-time-units-per-second))))
      (declare (type integer ,valsecs))
      (when (minusp ,valsecs)
        (setq ,valsecs 0)
        (warn " Time arg. negative or inferior to minim. Assuming 0."))
      (let* (,results
             ,complet
             (,fintime (+ ,valsecs (get-internal-real-time)))
             (,computs (thread:thread-create
                        #'(lambda () (setq ,results (multiple-value-list
                                                     (progn ,@body))
                                           ,complet t))
                        :name "with-max-time-active-process"
                        :background-streams-p nil)))
        (declare (type list ,results) (type boolean ,complet)
                 (type integer ,fintime) (type thread:thread ,computs))

        (unwind-protect
             (progn (loop while (and (not ,complet)
                                     (< (get-internal-real-time) ,fintime))
                          do (sleep ,mintime))
                    (values-list ,results))
          (if (not ,complet)
            (ignore-errors (thread:destroy-thread ,computs)))))))


  #-(or allegro cormanlisp genera lispworks openmcl sbcl scl)
  (error "WITH-MAX-TIME not implemented for this Lisp.
It possibly lacks threads."))


;;;  This is the obvious companion to with-max-time.
;;;  May seem stupid, but beware an adequate use of
;;;  with-min-time in caller threads or functions and
;;;  with-max-time in the callees avoids race-conditions.
;;;  (Not recommended - synchronize better using locks, semaphores...)

(defmacro with-min-time (seconds &body body)
  "Delays delivery of results until at least the specified number of seconds.
Package:  CL-USER     Type:  [macro]
Arg 1:  SECONDS [non-negative real or some expression that evaluates to that]
Execution time is guaranteed not to be any shorter, but it could be greater.
Rest :  Forms to compute.
Results:  The results of computing the forms.
Side effects:  Should not leave any; just wasted time."

  (let ((valsecs (gensym))
        (elapsed (gensym))
        (results (gensym)))
    `(let* ((,valsecs (eval ,seconds))
            (,elapsed (get-internal-real-time))
            (,results (multiple-value-list (progn ,@body))))
      (declare (type real ,valsecs ,elapsed) (type list ,results))

      (when (minusp ,valsecs)
        (setq ,valsecs 0)
        (warn " Time arg. negative or inferior to minim. Assuming 0."))

      (setq ,elapsed (/
                      (- (get-internal-real-time) ,elapsed)
                      internal-time-units-per-second))
      (if (< ,elapsed ,valsecs)
        (sleep (- ,valsecs ,elapsed)))

      (values-list ,results))))


;;; with-timeout is a lisp machine legacy with a badly designed interface.
;;; Provided here as an exercise, and for compatibility:
;;; DO NOT USE IN NEW CODE !
#|| Example extracted from the MIT lispm manual:
  (with-timeout (300 (format *query-io* "...Yes") t) (y-or-n-p "Really do it? (Yes after five seconds) "))
  is a convenient way to ask a question and assume an answer if the user
  does not respond promptly. This is a good thing to do for queries
  likely to occur when the user has walked away from the terminal
  and expects an operation to finish without his attention.
||#
(unless (or (functionp 'with-timeout)
            (macro-function 'with-timeout))
  ; that is, if not already defined inside the current package by the implementation:
  (defmacro with-timeout (timeout-and-else-forms &body body)
; This documentation string copied from the TI Explorer lispm:
"Execute BODY with a timeout set for DURATION 60'ths of a second from time of entry.
If the timeout elapses while BODY is still in progress,
the TIMEOUT-FORMS are executed and their values returned, and
whatever is left of BODY is not done, except for its UNWIND-PROTECTs.
If BODY returns, its values are returned and the timeout is cancelled."
; The Explorer documentation string continues:
;"The timeout is also cancelled if BODY throws out of the WITH-TIMEOUT."
; ... which I think is not possible in a threaded implementation like this.
    (let ((seconds (/ (eval (car timeout-and-else-forms)) 60.))
          (else-forms (cdr timeout-and-else-forms))
          (results (gensym)))
      `(let ((,results (multiple-value-list (with-max-time ,seconds ,@body))))
        (if ,results
          (values-list ,results)
          (progn ,@else-forms))))))

;-------------------------------------------------------------------------------