Someone in #lisp asked about permutations the other day, I hadn’t come across them before so after looking up what they where I decided it sounded like a good programming exercise to try and find all the permutations for a given string.

Anyway it took me a little while to figure out how to do it but once I did it wasn’t so hard, here’s the code:

(defun transpose (string position)
  "Return string with the characters at position transposed"
  (let ((before (when (> position 0) 
                  (subseq string 0 position)))
        (after (when (< (+ 1 position) (length string))
                 (subseq string (+ 2 position)))))
    (concatenate 'string before 
                 (subseq string (+ position 1) (+ position 2))
                 (subseq string position (+ position 1))
                 after)))

(defun permutations-helper (permutations position)
  "Does the hard work for the permutations function."
  (cond ((not permutations) nil)
        ((eql (length (car permutations)) (+ position 1)) permutations)
        (t (permutations-helper 
            (append permutations (mapcar (lambda (x) (transpose x position)) permutations))
            (+ 1 position)))))

(defun permutations (string)
  "Take a string and return a list of it's permutations"
  (remove-duplicates (permutations-helper (list string) 0) :test #'equal))

(permutations "population")

Any feedback would be great, feel free to use the code.

Cheers, Dave.

Edit: Before I re-wrote my blog there was a great comment from Kelsar that corrected the above code. I've included it below so anyone reading this has a working example to peek at and to help show how the above example is broken.

There is something wrong in your program; for example: (member “trebor” (permutations “robert”)) -> NIL

You probably need something like “rotation” of string. This is my version (on lists, not strings, but this is the same):

;utility function
(defun mappend (fn lst)
(apply #’append (mapcar fn lst)))

;rotation
(defun rot (lst) `(,@(cdr lst) ,(car lst)))

(defun full-rot (lst)
(let ((bf (list lst)))
(do ((x (rot lst) (rot x))) ((equal x lst))
(push x bf)) bf))

;;permutations
(defun permutation (lst)
(if (null lst) ‘(())
(mappend #’(lambda (x) (full-rot (cons (car lst) x))) (permutation (cdr lst)))))

(permutation ‘(1 2 3 4))

greetings, kelsar