utils.lisp

;; This software is Copyright (c) Jeronimo Pellegrini, 2008.
;; You have the rights to distribute
;; and use this software as governed by the terms
;; of the Lisp Lesser GNU Public License
;; (http://opensource.franz.com/preamble.html),
;; known as the LLGPL.

(in-package :jp-utils)

(defmacro with-gensyms ((&rest names) &body body)
  "Expands into code that binds all names to symbols generated by (gensym)."
  `(let ,(loop for n in names collect `(,n (gensym (format nil "~a-" ',n))))
     ,@body))

(declaim (inline nonrec-binary-search))

;; This binary serch function is supposed to be as general as possible,
;; but also as fast as possible.
(defun binary-search (the-element vector &key
                      (test= #'eql)
                      (test< #'<)
                      (get-element #'aref)
                      (start 0)
                      (end (1- (length vector)))
                      (not-found nil))
  "Performs a binary search for an element el on a (sorted) array vec.
Return values:
   - The index where the element was found
   - Either t (if el was found) or nil (if el was not found) You can ask
     the function to return something else on failure.
Named parameters:
   - get-element is the function used to retrieve an element of the vector.
     The default is aref. This should be a FUNCTION, and not a symbol!
   - start and end are the start and end indices within the array. If
     they are not supplied, 0 and the last index will be used.
   - test= and test-before are the tests to be used for equality and for
     determining precedence between elements. These should be FUNCTIONS,
     and not symbols!
   - not-found is the element to be returned when the element is not found.
     If not-found is set to 't', then, in case of failure, the function will
     return (i NIL), where i is the index where the element *should* be (or
     where it could be inserted).
     So, by default you can test the return inside an (if (binary-search) ...),
     since it returns either NIL or the position."
  (declare (optimize (speed 3) (safety 0) (debug 0)) 
           (type fixnum start end)
	   (function test= test< get-element)
           (type vector vector) ;; FIXME: what about simple-vector?
	   (dynamic-extent the-element vector start end not-found))
  (labels ((inside-binary-search (el vec start end)
             (declare (fixnum start end)
                      (vector vec))
             (if (< end start)
                 (if (eq not-found 't) 
                     (values start nil) ; where it *should* be
                     (values not-found nil))
                 (let* ((middle (floor (the fixnum (+ start end)) 2)) 
                        (middle-element (funcall get-element vec middle)))
                   (declare (fixnum middle))
                   (cond ((funcall test= el middle-element) ; found it!
                          (values middle t))
                         ((funcall test< el middle-element) ; to the left...
                          (inside-binary-search el vec start (1- middle)))
                         (t                                 ; to the right...
                          (inside-binary-search el vec (1+ middle) end)))))))
    (assert (and (functionp test=)
                 (functionp test<)
                 (functionp get-element)))
    (inside-binary-search the-element vector start end)))

;; This binary serch function is supposed to be as general as possible,
;; but also as fast as possible.
(defun nonrec-binary-search (the-element vector &key
			     (test= #'eql)
			     (test< #'<)
			     (get-element #'aref)
			     (start 0)
			     (end (1- (length vector)))
			     (not-found nil))
  "Performs a binary search for an element el on a (sorted) array vec.
Return values:
   - The index where the element was found
   - Either t (if el was found) or nil (if el was not found) You can ask
     the function to return something else on failure.
Named parameters:
   - get-element is the function used to retrieve an element of the vector.
     The default is aref. This should be a FUNCTION, and not a symbol!
   - start and end are the start and end indices within the array. If
     they are not supplied, 0 and the last index will be used.
   - test= and test-before are the tests to be used for equality and for
     determining precedence between elements. These should be FUNCTIONS,
     and not symbols!
   - not-found is the element to be returned when the element is not found.
     If not-found is set to 't', then, in case of failure, the function will
     return (i NIL), where i is the index where the element *should* be (or
     where it could be inserted).
     So, by default you can test the return inside an (if (binary-search) ...),
     since it returns either NIL or the position."
  (declare (optimize (speed 3) (safety 0) (debug 0)) 
           (type fixnum start end)
	   (function test= test< get-element)
           (type vector vector)) ;; FIXME: what about simple-vector?
  
  (assert (and (functionp test=)
	       (functionp test<)
	       (functionp get-element)))
  (let* ((middle (the fixnum 0))
	 (middle-element (funcall get-element vector middle)))
    (declare (type fixnum middle))
    (loop while (>= end start) do
      (setf middle (floor (the fixnum (+ start end)) 2))
      (setf middle-element (funcall get-element vector middle))
      (cond ((funcall test= the-element middle-element) ; found it!
	     (return-from nonrec-binary-search (values middle t)))
	    ((funcall test< the-element middle-element) ; to the left...
	     (setf end (1- middle)))
	    (t                                 ; to the right...
	     (setf start (1+ middle))))))
  (if (eq not-found 't) 
      (values start nil) ; where it *should* be
      (values not-found nil)))





(defmacro get-binary-search  (&key
			      (element-type t)
			      (test= 'eql)
			      (test< '<)
			      (get-element 'aref)
			      (not-found 'nil))
  "This function returns a function (with type declarations) that will perform binary search."
  (jp-utils::with-gensyms (external-binary-search
			   inside-binary-search
			   el
			   vec
			   istart
			   iend
			   middle
			   middle-element)
    `(labels ((,inside-binary-search (,el ,vec ,istart ,iend)
		(declare
		 (optimize (debug 3) (safety 0))
		 (type fixnum ,istart ,iend)
		 (type (simple-array ,element-type (*)) ,vec)
		 (type ,element-type ,el))
		(when (eql -1 ,iend)
		  (setq ,iend (the fixnum (1- (length ,vec)))))
		(if (< ,iend ,istart)
		    ,(if (eq not-found 't) 
			`(values ,istart nil) ; where it *should* be
			`(values ,not-found nil))
		    (let* ((,middle (floor (the fixnum (+ ,istart ,iend)) 2)) 
			   (,middle-element (,get-element ,vec ,middle)))
		      (declare (type fixnum ,middle))
		      (cond ((,test= ,el ,middle-element) ; found it!
			     (values ,middle t))
			    ((,test< ,el ,middle-element) ; to the left...
			     (,inside-binary-search ,el ,vec ,istart (1- ,middle)))
			    (t                          ; to the right...
			     (,inside-binary-search ,el ,vec (1+ ,middle) ,iend)))))))
       (flet ((,external-binary-search (,el ,vec &key (start 0) (end -1))
		(,inside-binary-search ,el ,vec start end)))
	 #',external-binary-search))))




(defmacro def-nonrec-binary-search (name &key
				    (element-type t)
				    (test= 'eql)
				    (test< '<)
				    (get-element 'aref)
				    (not-found 'nil))
  (jp-utils::with-gensyms (the-element
			   vector
			   start
			   end
			   middle
			   middle-element)
    `(defun ,name  (,the-element
		    ,vector
		    ,start
		    ,end)
       (declare	(optimize (speed 3) (safety 0) (debug 0))
		;(dynamic-extent ,the-element ,start ,end)
		(type ,element-type ,the-element)
		(type fixnum ,start ,end)
		(type (simple-array ,element-type (*)) ,vector))
       
       (let* ((,middle (the fixnum 0))
	      (,middle-element (,get-element ,vector ,middle)))
	 (declare (type fixnum ,middle)
		  (type ,element-type ,middle-element))
	 (loop while (>= ,end ,start) do
	   (setf ,middle (floor (the fixnum (+ ,start ,end)) 2))
	   (setf ,middle-element (the ,element-type
				   (,get-element ,vector ,middle)))
	   (cond ((,test= ,the-element ,middle-element) ; found it!
		  (return-from ,name (values ,middle t)))
		 ((,test< ,the-element ,middle-element) ; to the left...
		  (setf ,end (1- ,middle)))
		 (t                                 ; to the right...
		  (setf ,start (1+ ,middle))))))
       (if (eq ,not-found 't) 
	   (values ,start nil) ; where it *should* be
	   (values ,not-found nil)))))



(defun hash-table-keys (hash)
  "Returns a list with the keys of a hash table."
  (let ((the-keys))
    (loop
       for key being each hash-key in hash do
         (push key the-keys))
    the-keys))

(defun hash-table-keys-as-array (hash)
  "returns an array with the keys of a hash table."
  (let ((the-keys (make-array (hash-table-count hash) :element-type 'fixnum)))
    (loop
     for key being each hash-key in hash
     for pos fixnum below (hash-table-count hash) do
     (setf (aref the-keys pos) key))
    the-keys))

(defun generate-random-array (size range-start range-end)
  "Generates an array of random fixnums of size n, ranging from 0 to k"
  (declare (type fixnum size range-start range-end)
	   (optimize (speed 3) (safety 0)))
  (let ((a (make-array size :element-type 'fixnum))
	(k (the fixnum (- range-end range-start))))
    (declare (type fixnum k))
    (dotimes (i size)
      (setf (aref a i) (+ (the fixnum (random k)) range-start)))
    a))

(defmacro do-sequence ((idx seq) &rest body)
  "Runs across a sequence (syntatic sugar)."
  `(map nil #'(lambda (,idx) ,@body) ,seq))

(defun sequence-first (seq)
  "Returns the first element of a sequence."
  (declare (optimize (speed 3) (safety 0)))
  (typecase seq
    (list (car seq))
    (array (aref seq 0)) ; not svref, since it won't work for strings
    (t (error "sequence-first called with something that is neither vector nor array"))))

;;;--- SORT START ---;;;

(defun sortedp (seq &key (test #'<))
  "Determines if a sequence is sorted. Will return (t size)
 on success (where size is the size of the sequence) or
nil size), where size is the size of the largest sorted subsequence,
from the beginning to the right.
For example:
 (sortedp '(10 20 30 40 1 100)) ==> (NIL, 4)
 (sortedp #(10 20 30 40 50 100)) ==> (T, 6)
See that the size of the sorted sequence is always at least one, except
for empty sequences, which are always sorted:
 (sortedp ()) ==> (T, 0)
"
  (declare (optimize (speed 3) (safety 0))
	   (function test))
  (let ((previous (sequence-first seq))
        (idx 0))
    (declare (type fixnum idx))
    (do-sequence (el seq)
      (if (funcall test el previous)
          (return-from sortedp (values nil idx))
          (setf previous el))
      (incf idx))
    (values t idx)))


(defun counting-sort (data k &key (start 0) (end -1))
  "Counting sort. Only works for arrays of fixnums.
data is the array. The elements in the array must range from
zero to k. Optional parameters start and end can be used to specify
a subrange of the array to be sorted, but then the new array will
have zeroes in all other places (this will be fixed later).

This function returns the new array and the counting array, which
tells where each each key starts in the new array."
  (declare (type fixnum k start end)
	   (type (simple-array fixnum (*)) data)
	   (optimize (speed 3) (safety 0) (debug 0)))
  (when (= -1 end)
    (setf end (- (1- (the fixnum (length data))) start)))
  (let ((count-array (make-array k
				 :element-type 'fixnum
				 :initial-element 0))
	(new-array   (make-array (+ 1 (- end start))
				 :element-type 'fixnum)))
    (loop
       for i fixnum from start to end do
	 (incf (aref count-array (aref data i))))
    (loop
       for i fixnum from 1 to (1- k) do
	 (incf (aref count-array i) (aref count-array (1- i))))
    (loop
       for i fixnum from end downto start do
	 (setf (aref new-array (1- (aref count-array (aref data i))))
	       (aref data i))
	 (setf     (aref count-array (aref data i))
	       (1- (aref count-array (aref data i)))))
    (values new-array count-array)))


;;; TODO: counting-sort-g requires keys to be fixnums, when they could
;;; actually be integers...
(defun counting-sort-g (data
			sorted-data
			k
			start
			end
			&key
			(key #'aref)
			(copy-element #'(lambda (new new-i old old-i)
					  (declare (type (simple-array fixnum (*)) old new)
						   (type fixnum old-i new-i))
					  (setf (aref new new-i)
						(aref old old-i))))
			)
  "Generalized counting sort: it will sort data structures, provided that there
is a way to identify elements with fixnum keys.

Parameters:
===========
- data is the structure to be sorted.
- sorted-data is the new sorted structure, that needs to be previously allocated
  (and be similar to data)
- k is the maximum key value. CAUTION: this function will allocate an array
  of size k, so if it is too large, it may not work.
- start and end define the slice of the keys that will be sorted.
- The key function identifies array elements given a fixnum. By default
  tihs is aref;
- The copy-element wihch will be used to copy elements among different posisions
  needs to have four arguments:
  +  new:   the new data structure
  +  new-i: the index in the new data structure
  +  old:   the old data structure
  +  old-i: the index in the old data structure
  So, given those, this function should copy an element from position old-i on
  structure old to position new-i on structure new.

Return value and result:
========================

This function will return the counting array, which shows where in the new structure
each key begins:

 (let ((new-data (make-array 12 :element-type 'fixnum)))
   (counting-sort-g #(0 2 4 6 0 2 4 6 1 3 5 7) new-data 8 0 11))
  => #(0 2 3 5 6 8 9 11)

new-data      #(0 0 1 2 2 3 4 4 5 6 6 7)
count vector: #(0 2 3 5 6 8 9 11)

Looking at the count vector, we see that the elements with key '0' start
at position '0' in the new structure; the elements with key '1' start
at position '2'; elements with key '2' start at '3', etc, and elements
with key '7' start at the last position, '11'.

Example:
========
 ;;; A structure contains two arrays:
 (defstruct (two-arrays (conc-name ta))
   array-one
   array-two)

 ;;; Now we sort it, using the first array as the key array, and the second as
 ;;; the data array.
 (counting-sort-g two-arrays
                  two-arrays-new
                  100
                  10
                  110
                  :key          #'(lambda (data i) (aref (ta-array-one data) i))
                  :copy-element #'(lambda (new new-i old old-i)
                                   (setf (aref (ta-array-one new) new-i) (aref (ta-array-one old) old-i)
                                         (aref (ta-array-two new) new-i) (aref (ta-array-two old) old-i))

Efficiency:
===========

If k is not large, this is much faster than Lisp's built-in sort function, because it
does not rely on element comparison. cl:sort takes O(n lg n) time, counting-sort-g takes
O(n + k) time. On the other hand, it requires O(n + k) additional memory: besides the
argument sorted-data, which is provided by you, this function will also allocate an array
of size k.

For details, see:

- Cormen, Leiserson, Rivest and Stein: 'Introduction to algorithms'
- Berman and Paul, 'Algorithms: sequential, parallel, and distributed'
- Wikipedia:
  + http://en.wikipedia.org/wiki/Sorting_algorithm
  + http://en.wikipedia.org/wiki/Counting_sort

Because it is generic and works on any data structure, this function can be ten times
slower than the counting-sort function in this package, which works on arrays of fixnums
only."
  (declare ;(fixnum k start end)
	   ;(function key)
	   ;(function copy-element)
	   (optimize (speed 3) (safety 0) (debug 0)))
  (when (eq key #'aref)
    ;; aref only works for arrays, and this algorithm needs the key
    ;; to be a fixnum, so...
    (check-type data (array fixnum (*)))
    (check-type sorted-data (array fixnum (*))))
  ;; we check types only once per call to this function (if we just declared,
  ;; we'd be checking inside loops!)
  (check-type start fixnum )
  (check-type end fixnum)
  (check-type k fixnum)
  (check-type key function)
  (check-type copy-element function)
  (let ((count-array (make-array k
				 :element-type 'fixnum
				 :initial-element 0)))
    ;; Count occurrences of each element:
    (loop
       for i fixnum from start to end do
	 (incf (aref count-array (funcall key data i))))
    ;; Accumulate:
    (loop
       for i fixnum from 1 to (1- k) do
	 (incf (aref count-array i) (aref count-array (1- i))))
    ;; Copy elements to their positions in the new structure:
    (loop
       for i fixnum from end downto start do
	 (funcall copy-element sorted-data (the fixnum (+ start (1- (aref count-array (funcall key data i)))))
		  data i)
	 (setf     (aref count-array (funcall key data i))
		   (1- (aref count-array (funcall key data i)))))
    count-array))

;;;--- SORT END ---;;;

(defun subst-all (subst-list tree)
  "Performs several substitutions on a tree (similar to what subst does).
subst-list is a list of substitutions. For example:
 (subst-all '((a 1) (b 2) (c 3))
            '(x y a (z b (u v c))))
  => (X Y 1 (Z 2 (U V 3)))"
  (if (null subst-list)
      tree
      (subst-all (cdr subst-list)
		 (subst (second (car subst-list)) (car (car subst-list)) tree))))

(defun format-symbol (string &rest args)
  "Creates a symbol and interns it. This function can be used like FORMAT:
  (format-symbol \"my-symbol-version-~a.~a\" 2 3)
   ==> MY-SYMBOL-VERSION-2.3"
  (intern (string-upcase (apply #'format `(nil ,string ,@args)))))

(defun format-uninterned-symbol (string &rest args)
  "Creates a symbol from a string but does not intern it (useful when creating code that
will not necessarily be in the current package). This function can be used like FORMAT:
  (format-uninterned-symbol \"my-symbol-version-~a.~a\" 2 3)
   ==> #:MY-SYMBOL-VERSION-2.3"
  (make-symbol (string-upcase (apply #'format `(nil ,string ,@args)))))

(defun robust-adjust-array (array size &key (element-type nil))
  "Adjusts the size of an array, setting it to the new one. Also works around
an issue with Allegro Common Lisp: in ACL, when you call adjust-array on a non-adjustable
array, the resulting array is not necessarily of the same type. It is not a SIMPLE-ARRAY
anymore.  Dependig on how you try to fix it, you may end up with an array whose
element-type is T. So, this is a method for resizing an array and keeping the same array
type.

Yes, we want SIMPLE-ARRAYs because access is faster. But we also want to adjust them, even
if adjusting is slow."
  (let ((type (if (null element-type)
		  (array-element-type array)
		  element-type)))
    (setf array
	  #-allegro (adjust-array array size :element-type type)
	  #+allegro (coerce (adjust-array array size :element-type type :adjustable nil)
			    `(simple-array ,type *)))
    array))


;;;--- CLOCK ---;;;

(deftype internal-time-type ()
  (type-of (get-internal-run-time)))

(defstruct (clock (:type vector))
  (start-time   0   :type internal-time-type)
  (elapsed-time 0   :type internal-time-type)
  (running      NIL :type boolean))

;; Type declaration for some fast functions:
(declaim (ftype (function (simple-vector) (values))
		reset-clock
		start-clock
		stop-clock))

;; TODO: For CMUCL we should block-compile

(defun reset-clock (clock)
  "Completely resets the stopwatch."
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (setf (clock-elapsed-time clock) 0
	(clock-start-time clock) (get-internal-run-time)
	(clock-running clock)    T)
  (values))

(defun start-clock (clock)
  "Sets the start time of the stopwatch to 'now',
but does NOT reset the elapsed time."
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (setf (clock-start-time clock) (get-internal-run-time)
	(clock-running clock)    T)
  (values))

(defun stop-clock (clock)
  "Pauses the stopwatch and updates the elapsed-time."
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (incf (clock-elapsed-time clock)
	(the internal-time-type
	  (- (the internal-time-type (get-internal-run-time))
	     (clock-start-time clock))))
  (setf (clock-running clock) nil)
  (values))

(defun elapsed-time (clock &key (as 'single-float))
  "Returns the time elapsed since the stopwatch started,
while it was running (pauses are excluded).
If the clock was currently running, the time until now
is computed. Otherwise, time until the most recenr stop
is computed."
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (coerce
   (if (clock-running clock)
       (/ (+ (clock-elapsed-time clock)
	     (- (the internal-time-type (get-internal-run-time))
		(clock-start-time clock)))
	  internal-time-units-per-second)
       (/ (clock-elapsed-time clock)
	  internal-time-units-per-second)) as))