; 5*O(n)
(defun next-lex (a)
(let* ((r (reverse a))
(pivot (first-down r)))
(multiple-value-bind
(less-pivot greater-pivot before-pivot) (partition-upto pivot r)
(nreverse (append (cdr greater-pivot) (list pivot) less-pivot
(list (car greater-pivot)) before-pivot)))))
; O(n)
(defun first-down (a)
(if (numberp (cadr a))
(if (> (car a) (cadr a))
(cadr a)
(first-down (cdr a)))
nil))
; O(n)
(defun partition-upto (pivot a)
(labels ((partition-sub (pivot a less more)
(cond
((eql (car a) pivot)
(values less (nreverse more) (cdr a)))
((> (car a) pivot)
(partition-sub pivot (cdr a) less (cons (car a) more)))
((< (car a) pivot)
(partition-sub pivot (cdr a) (cons (car a) less) more)))))
(partition-sub pivot a () ())))
;; > (next-lex '(1 3 5))
;; (1 5 3)
Refactorings
No refactoring yet !
niv
October 9, 2007, October 09, 2007 00:26, permalink
1 rating.
Login to rate!
for starters
(defun partition-upto (pivot a &optional less more)
(cond
((eql (car a) pivot)
(values less (nreverse more) (cdr a)))
((> (car a) pivot)
(partition-upto pivot (cdr a) less (cons (car a) more)))
((< (car a) pivot)
(partition-upto pivot (cdr a) (cons (car a) less) more))))
niv
October 9, 2007, October 09, 2007 00:29, permalink
1 rating.
Login to rate!
if you don't care about efficience
(defun partition-upto (pivot a)
(values (remove-if (lambda (x) (> x pivot)))
(remove-if (lambda (x) (< x pivot)))))
niv
October 9, 2007, October 09, 2007 00:39, permalink
1 rating.
Login to rate!
if you like (loop), also now I see I misread partition-upto
(defun first-down (a)
(loop for fst in a
for scd in (cdr a)
when (> fst scd) return scd))
(defun partition-upto (pivot a)
(loop for e in a
for r in a
when (> e pivot) collect e into more
when (< e pivot) collect e into less
when (eql e pivot) return (values (cdr r) (nreverse less) more)))
niv
October 9, 2007, October 09, 2007 00:41, permalink
1 rating.
Login to rate!
sorry, it's actually for r on a
(defun partition-upto (pivot a)
(loop for e in a
for r on a
when (> e pivot) collect e into more
when (< e pivot) collect e into less
when (eql e pivot) return (values (cdr r) (nreverse less) more)))
niv
October 9, 2007, October 09, 2007 00:45, permalink
1 rating.
Login to rate!
rewritten with the "with" macro, the bastard son of loop. I don't know if you like the style, but I think it's nice when you have let* and multiple value bind and some other stuff
(defun next-lex (a)
(with var r = (reverse a)
var pivor = (first-down r)
vars (less-pivot greater-pivot before-pivot) = (partition-upto pivot r)
in
(nreverse (append (cdr greater-pivot) (list pivot) less-pivot
(list (car greater-pivot)) before-pivot))))
Kartik Agaram
October 9, 2007, October 09, 2007 01:43, permalink
No rating.
Login to rate!
Nice!
1. How is the 'on' loop keyword different from 'in'?
2. I didn't know about the with macro, and ended up writing bind instead at some point: http://akkartik.name/lisp.html#bind
Sunnan
October 15, 2007, October 15, 2007 11:32, permalink
No rating.
Login to rate!
Tried changing the algo to a simpler(?) version. This is Scheme + srfi-1 + srfi-26 + anaphoric (paul graham style) if, should be rewriteable to CL pretty easily.
(require-extension miscmacros srfi-1)
(define (next-lex nums)
(if (apply >= nums)
#f ; already highest
(if* (next-lex (cdr nums))
(cons (car nums) it)
(let ((n (next-highest (car nums) (cdr nums))))
(cons n (sort (remove-one n nums) <))))))
(define (remove-one a list)
(let ((nl (remove (cut eqv? a <>) list)))
(append! nl (make-list (- (length list) (length nl) 1) a))))
(define (next-highest a list)
(apply min (filter (cut > <> a) list)))
Sunnan
October 15, 2007, October 15, 2007 11:51, permalink
No rating.
Login to rate!
p.s. your Bind macro is available as srfi-11 'let-values' in Scheme.
M Tyson
June 29, 2008, June 29, 2008 09:49, permalink
No rating.
Login to rate!
The initial example code has bugs.
Bug 1:
(next-lex '(1 4 3 2)) = (2 1 4 3)
I believe it should be (2 1 3 4)
Bug 2:
(next-lex '(4 3 2 1)) generates an error
Bug 3 (or specification error):
(next-lex '(1 2 3 3 2)) = (1 2 3 3 NIL 2)
The code below seems to work and is about O(4n). I didn't look for a published source for the original algorithm, so it is possible I have some bugs too.
;;; LIS is a list of (possibly repeated) elements
;;; COMPARE is a boolean function of two elements, such as > (which is the default)
;;; This returns the next lexicographically larger (via COMPARE) list of those same elements
;;; As an example, if lis = (1 5 10 10 12 12 11 11 10 9 9 8)
;;; the result is (1 5 10 11 8 9 9 10 10 11 12 12)
;;; It is O(4n) more or less.
;;; If lis were a vector, it seems we could save O(2n), but to convert a list to a vector and back will cost O(2n).
;;; Note that the order of "equal" elements is not guaranteed.
;;; (next-lex '("a" "e" "j" "j" "l" "l" "k" "k" "J" "j" "i" "i" "h") :compare #'string-greaterp)
;;; could return
;;; ("a" "e" "j" "k" "h" "i" "i" "j" "j" "J" "k" "l" "l") Note the the upper and lower cases of J.
;;; or ("a" "e" "j" "k" "h" "i" "i" "J" "j" "j" "k" "l" "l")
;;; or ("a" "e" "j" "k" "h" "i" "i" "j" "J" "j" "k" "l" "l")
(defun next-lex (lis &key (compare '>))
(let ((revlis (reverse lis))) ;revlis = ( 8 9 9 10 11 11 12 12 10 10 5 1) ;O(n)
(loop with post-pivot = nil
for (n1 pivot . rev-pre-pivot) on revlis ; O(0.5n)
while pivot
do (push n1 post-pivot)
(when (funcall compare n1 pivot)
;;(format t "n1 = ~d, pivot = ~d, post-pivot = ~d, rev-pre-pivot = ~d~%" n1 pivot post-pivot rev-pre-pivot) ; Debug
;; at this point, n1 = 12, pivot = 10, post-pivot = (12 12 11 11 10 9 9 8), rev-pre-pivot = (10 5 1)
(return (append
;; First is the part before the pivot that doesn't change.
(reverse rev-pre-pivot) ; O(0.5n)
;; We know the numbers in post-pivot are monotonically decreasing
;; In the post-pivot set, we will pick out the numbers that are bigger than the pivot, those equal to it, and the ones less than it.
;; We move the smallest of the greater set to where the pivot was,
;; Then put all those less than the pivot (in monotonically increasing order),
;; Then the pivot and all those equal to it
;; Then the rest of those greater than the pivot (in monotonically increasing order)
(loop for (pp . pprest) on post-pivot ; O(0.5n)
;; Remember, post-pivot is monotonically decreasing
with greater = nil
with equal = nil
do ;;(when (funcall compare pivot pp) (format t "pp = ~d, pprest = ~d, equal = ~d, greater = ~d~%" pp pprest equal greater)) ; Debug
(if (funcall compare pivot pp)
;; At this point, pp = 9, pprest = (9 8), equal = (10), greater = (11 11 12 12)
;; We can now finish up the resulte
(return (cons (first greater) ;The smallest of the greater set
(append
(reverse (cons pp pprest)) ; The lesser set, reversed to be increasing ;O(2x0.25n) One for reverse, one for append
(cons pivot
(append equal ; O[1]
(rest greater))))))
(if (funcall compare pp pivot)
;; If pp is greater than pivot, remember it
(push pp greater) ; greater is monotonically increasing
;; Note that we don't assume EQL or EQUAL for a comparison, but we use the COMPARE function in both directions.
(push pp equal)))
finally
;; If we haven't found something less than pivot, then we wind up here
;;(prog2 (format t "No post-pivot < pivot. equal = ~d, greater = ~d~%" equal greater) ;Debug
(return (cons (first greater) ; The smallest of the greater set
(cons pivot
(append equal ; O[1]
(rest greater)))))
;;) ;Debug
)))))))
Harleqin
February 3, 2009, February 03, 2009 06:47, permalink
No rating.
Login to rate!
I think that this is somewhat similar to the previous algorithm, but in a simpler loop (I think). It is open for further refactoring.
(defun next-lex (number-list &optional (rev-tail-list ()))
"Returns the next lexicographic permutation of number-list."
(cond ((null rev-tail-list) ; initial call
(let ((rev (reverse number-list)))
(next-lex (cdr rev)
(list (car rev)))))
((null number-list) ; highest permutation already reached
nil)
((< (car number-list) (car rev-tail-list)) ; found the pivoting place
(let* ((pivot-element (find-if (lambda (n) (> n (car number-list)))
rev-tail-list
:from-end t))
(rev-tail (remove pivot-element rev-tail-list)))
(reverse (append (merge 'list
(list (car number-list))
rev-tail
#'>)
(list pivot-element)
(cdr number-list)))))
(t ; recurse
(next-lex (cdr number-list)
(merge 'list (list (car number-list)) rev-tail-list #'>)))))
Harleqin
February 3, 2009, February 03, 2009 06:56, permalink
No rating.
Login to rate!
Sorry, that one has a bug too, it doesn't work with repeated elements.
Harleqin
February 3, 2009, February 03, 2009 08:25, permalink
No rating.
Login to rate!
Here comes the fixed version; I forgot to give a count to remove.
(defun next-lex (number-list &optional (rev-tail-list ()))
"Returns the next lexicographic permutation of number-list."
(cond ((null rev-tail-list) ; initial call
(let ((rev (reverse number-list)))
(next-lex (cdr rev)
(list (car rev)))))
((null number-list) ; highest permutation already reached
nil)
((< (car number-list) (car rev-tail-list)) ; found the pivoting place
(let* ((pivot-element (find-if (lambda (n) (> n (car number-list)))
rev-tail-list
:from-end t))
(rev-tail (remove pivot-element rev-tail-list :count 1)))
(reverse (append (merge 'list
(list (car number-list))
rev-tail
#'>)
(list pivot-element)
(cdr number-list)))))
(t ; recurse
(next-lex (cdr number-list)
(merge 'list (list (car number-list)) rev-tail-list #'>)))))
Given a list of numbers, generate their alphabetically next permutation.
Can this be shorter?