;;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))))