;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Time-stamp: <2004-06-04 16:15:57>
;;;   Touched: Fri Jun 04 06:15:53 2004 +0530
;;;   Bugs-To: (enometh@net.meer)
;;;
;;; simple timer extensions for `event.lisp'
;;
(in-package "PSE")

(defconstant +default-pqueue-size+ 10)
(defconstant +default-pqueue-incr+ 5)

(defstruct timer index handler timeout)
(defvar *all-timers* (make-array (1+ +default-pqueue-size+) 
				 :fill-pointer 1 :adjustable t))

(defun up-heap (index &optional (timers *all-timers*))
  (loop with timer = (aref timers index) and p
	for i = index then p while (> i 1)
	if (>= (timer-timeout timer) 
	       (timer-timeout (aref timers (setq p (ash i -1)))))
	do (loop-finish)      ;break if we are greater than the parent
	else do (setf (timer-index (setf (aref timers i) (aref timers p))) i)
	finally	(setf (timer-index (setf (aref timers i) timer)) i)))

(defun down-heap (index &optional (timers *all-timers*))
  (loop with timer = (aref timers index)
	for i = index then j for j = (* index 2) then (* j 2)
	while (< j (fill-pointer timers))
	if (and (< j (1- (fill-pointer timers)))
		(> (timer-timeout (aref timers j))
		   (timer-timeout (aref timers (1+ j)))))
	do (incf j)	      ;j points to smaller of the two children
	if (<= (timer-timeout timer) (timer-timeout (aref timers j)))
	do (loop-finish)  ;break if we are less than the smaller child
	else do (setf (timer-index (setf (aref timers i) (aref timers j))) i)
	finally	(setf (timer-index (setf (aref timers i) timer)) i)))

(defun add-timer (timer &optional (timers *all-timers*))
  (assert (null (timer-index timer)))
  (let ((free (fill-pointer timers)))
    (assert (= (vector-push-extend timer timers +default-pqueue-incr+) free))
    (setf (timer-index timer) free)
    (up-heap free timers)) timer)

(defun remove-timer (timer &optional (timers *all-timers*) 
		     &aux (index (timer-index timer)))
  (assert (and index (eq (aref timers index) timer)))
  (setf (aref timers index) (vector-pop timers)) ;swap with last
  (when (> (fill-pointer timers) 1)	;adjust index
    (if (or (= index 1)
	    (> (timer-timeout (aref timers index))
	       (timer-timeout (aref timers (truncate index 2)))))
	(down-heap index timers)
	(up-heap index timers)))
  (setf (timer-index timer) nil) timer)

(defun pq-clear (&optional (timers *all-timers*)) 
  (setf (fill-pointer timers) 1))	;bug-gc

(defun pq-get (&optional (timers *all-timers*))
  "deque and return the next available timer event"
  (when (> (fill-pointer timers) 1)
    (let ((timer (aref timers 1)))
      (setf (aref timers 1) (vector-pop timers)) ;swap with last
      (down-heap 1 timers)
      (setf (timer-index timer) nil)  timer)))

(defun pq-peek  (&optional (timers *all-timers*))
  (and (> (fill-pointer timers) 1) (aref timers 1)))

(defmethod print-object ((timer timer) stream)
  (print-unreadable-object (timer stream :identity t :type nil)
    (call-next-method)))

#+nil
(loop
 initially (PQ-CLEAR)
 (loop for i below 10000 do (ADD-TIMER (MAKE-TIMER :timeout (random 100.0))))
 for t1 = (PQ-GET) then t2 for t2 = (PQ-GET) while t2
 do (assert (and (null (TIMER-INDEX t1)) (null (TIMER-INDEX t2))
		 (<= (TIMER-TIMEOUT t1) (TIMER-TIMEOUT t2)))))

;;;
;;;
;;;
(defun serve-all-timers ()
  (let ((timeunits (get-internal-real-time)))
    (loop for timer = (pq-peek)
	  while (and timer (<= (timer-timeout timer) timeunits)) do
	  (assert (eq timer (pq-get)))
	  (and (timer-handler timer)
	       (funcall (timer-handler timer) timer)))))

(defun serve-events ()
  "like SERVE-ALL-EVENTS, also serves timer events"
  (let ((top (pq-peek)) (timeout 0))
    (when top
      (let ((timeunits (- (timer-timeout top) (get-internal-real-time)))) 
	(when (> timeunits 0)
	  (setf timeout (/ timeunits internal-time-units-per-second)))))
    (serve-all-events timeout)
    (when top (serve-all-timers))))


;;; ----------------------------------------------------------------------
;;; Example:
;;;
(defun %make-timeout (seconds)
  (+ (get-internal-real-time)
     (* seconds internal-time-units-per-second)))

(defun make-marker (interval)
  (let ((mark (MAKE-TIMER)))
    (setf (TIMER-HANDLER mark)
	  (lambda (self)
	    (multiple-value-bind (second minute hour) (get-decoded-time)
	      (format t "~2,'0D:~2,'0D:~2,'0D"  hour minute second))
	    (format t " --- MARK ---~%")
	    (format t "~a~%" self)
	    (setf (timer-timeout self) (%make-timeout interval))
	    (ADD-TIMER self)))
    (setf (TIMER-TIMEOUT mark) (%make-timeout interval))
    (add-timer mark)))

(defun toploop (&optional(port *toy-echo-server-port*))	;see `event.lisp'
  (let ((server-socket (socket:socket-server port)))
    (ADD-SOCKET-HANDLER server-socket :INPUT #'accept-connection)
    (make-marker 20)
    (loop
     (handler-case (SERVE-EVENTS)
       (socket-error (c)
	 (format *debug-io* "caught ~a.~% removing handler ~a.~%"
		 (original-error c) (socket-handler c))
	 (REMOVE-SOCKET-HANDLER (socket-handler c))
	 (remhash (handler-socket (socket-handler c))
		  *socket-read-buffers*))))))