; lexicographic permutations
(define (next-perm lt? zs)
(if (null? zs) zs
(let next ((xlist (list (car zs))) (ys (cdr zs)))
(cond ((null? ys) (reverse zs))
((not (lt? (car ys) (car xlist)))
(next (cons (car ys) xlist) (cdr ys)))
(else
(letrec ((swap
(lambda (xs)
(cond ((null? (cdr xs))
(cons (car ys) (cons (car xs) (cdr ys))))
((lt? (car ys) (cadr xs))
(cons (car xs) (swap (cdr xs))))
(else (append (cons (car ys) (cons (cadr xs) (cddr xs)))
(cons (car xs) (cdr ys))))))))
(swap xlist)))))))
(define (perms lt? xs)
(define (fact n) (if (<= n 1) 1 (* n (fact (- n 1)))))
(let loop ((n (fact (length xs))) (xs xs) (xss '()))
(if (zero? n) xss
(loop (- n 1) (next-perm lt? xs) (cons xs xss)))))
(display (perms < '())) (newline)
(display (perms < '(1))) (newline)
(display (perms < '(1 1))) (newline)
(display (perms < '(4 3 2 1))) (newline)