;;Combinatorica functions in Common Lisp
;; author: Richard Fateman with C. Ruan
;; Since there is a choice of data structures that can be used for
;; Mathematica's List  {a,b,c}  ... this could be either
;; a lisp list  (a b c)  or a lisp simple vector  #(a b c).
;; some functions are set to accept either.

;; These are not the simplest functions that can be written. Almost the same
;; deliberately naive techniques could be used as is used in Combinatorica.
;; However, one of the goals in rewriting in Lisp is to provide massively
;; faster programs. By compiling these lisp programs, orders of magnitude
;; speedup should be demonstrable.

(defun range (n &aux ans)
  "Return a list of elements from 1 to n"
  (declare (fixnum n))
  (do ((i n (1- i)))
      ((= i 0) ans)
      (declare (fixnum i))
      (setq ans (cons i ans))))


(defun vectorrange (g)
  "Return a vector of elements from 1 to n"
(declare (fixnum g))
  (let ((ans (make-array g :element-type 'fixnum)))
    (do ((i 1 (1+ i)))
	((> i g) ans)
	(declare (fixnum i))
	(setf (aref ans (1- i)) i))))


(defun permutations(bag)
  "Return a list of all the permutations of the input: vector or list"
  (if (listp bag) (permutationslist bag) 
    (mapcar #'(lambda(r)(coerce r 'vector)) 
	    (permutationslist (coerce bag 'list)))))

(defun permutationslist(bag)
  "Return a list of all the permutations of the input list."
  (if (null bag) '(())
    ;; otherwise take an element, e, out of the bag.
    ;; generate all permutations of the remaining elements.
    ;; and add e to the front of each of these.
    ;; do this for all possible e to generate all permutations.
    (mapcan #'(lambda(e)(mapcar #'(lambda(p)(cons e p))
				(permutationslist
				 (remove e bag :count 1 :test #'eq))))
	    bag)))


(defun permutationQ (x)		       ;linear time

  "Return T if x is a list or vector of the integers from 1 to 
  (length x), permuted.  Gives an error if x is not a sequence"
  
;;  If there are L numbers e[1], e[2],... e[L],  and each
;;  number can be put in one of the boxes labelled with its value
;;  1, 2, ... L, with no duplicates, then {e[i]} must be a permutation
;;  of the integers from 1 to L. (Pigeon-Hole principle)

   (let* ((len (length x)) 
	(ar (make-array (1+ len) :element-type 'bit :initial-element 0)))
     (every
      #'(lambda(e)(and(integerp e)
		      (<= 1 e len)
		      (zerop (aref ar e))
		      (incf (aref ar e))))
      x)))

;;Here's another one
;; (from Peter Norvig --)
;; This has the interesting property of not needing any intermediate
;; storage for lists of length shorter than (log most-positive-fixnum 2).
;; It is also more interesting to prove it correct.  Sketch: if x has n
;; 1 bits in its binary representation, then x + 2^i will have n+1 1 bits
;; if x had a 0 at position i, and will have at most n 1 bits otherwise.
;; So if the list were not a permutation, we couldn't get all the bits set.

#+ignore (defun permutationQ (list)
  "Is list a permutation of the integers from 1 to (length list)?"
  (= (loop for e in list sum (expt 2 (- e 1)))
     (- (expt 2 (length list)) 1)))

#+ignore (defun permutationQ(list &aux (len (length list))) ;yet another
  (= (loop 
	 for e in list 
	 do (unless (and (integerp e) (<= 1 e len))
	      (return-from perm5 nil))
	 sum (ash 1 (- e 1)))
     (- (ash 1 len) 1)))

(defun permute (l p)
  "Permute l according to the permutation p, assumes l and p have the
   same length."
;; could be done without coerce p to a list if it is a vector,
;; by using elt. But this works..
;; returns a list or a vector depending on what l is.
  (cond ((permutationQ p)
	 (if (listp l)
	     (mapcar #'(lambda (x)
			 (nth (1- x) l))
		     (coerce p 'list))
	     (coerce (mapcar #'(lambda (x)
				 (aref l (1- x)))
			     (coerce p 'list)) 'vector)))	     
	(t (error "~s is not a permutation.~%" p))))