Paste: permutation

! Copyright (C) 2009 Jon Harper.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences sorting ;
IN: permutations

! Begining from the end, find the smallest subsequence that's not increasing monotonic.
! Call a the first element of this sequence.
! swap a and the smallest number greater than a in the rest of the sequence.
! Natural sort the rest of the sequence.
! Append this new sequence to the begining sequence 

<PRIVATE

: deep-1+ ( x obj obj -- x+1 obj obj )
[ [ 1 + ] dip ] dip ;
: remove-one ( seq elt -- newseq )
dupd [ = ] curry find [ swap remove-nth ] [ drop ] if ;

: (index-of-not-ascending) ( index seq previous -- i )
over empty? 
[ 3drop f ]
[ [ unclip-last dup ] dip >= 
  [ 
    deep-1+ (index-of-not-ascending) 
  ] [ 
    2drop
  ] if
] if ;

: index-of-not-ascending ( seq -- i )
dup empty?
[ 
    drop f
] [ 
    [ 1 ] dip 
    dup last (index-of-not-ascending)
] if ;

: get-non-monotonic-endsequence ( seq -- beginseq endseq )
dup index-of-not-ascending dup 
[ cut* ] [ 2drop f f ] if ;

: get-smallest-greater-than ( seq i -- seq )
[ > ] curry filter infimum ;

: handle-endseq ( endseq -- newendseq )
dup unclip get-smallest-greater-than
[ remove-one natural-sort ] keep prefix ;
PRIVATE>

: next ( seq -- seq )
   get-non-monotonic-endsequence dup [ handle-endseq append ] [ drop ] if ;

Annotation: another way to do it?

: depermutation ( seq -- n seq ) dup natural-sort [ [ index ] curry map >factoradic factoradic>integer ] keep ;
: factoradic>integer ( factoradic -- n ) <reversed> [ factorial * ] map-index sum ;
: >factoradic ( permutation -- factoradic ) dup [ unclip [ '[ _ over < [ 1 - ] when ] map ] keep ] replicate nip ;

usage:

( scratchpad ) "abcd" depermutation [ 1 + ] dip permutation >string .
"abdc"

Annotation: for non-canonic strings (ulgy)

USE: math.combinatorics
: invert ( perm -- perm' ) <enum> >alist sort-values keys ;
: factoradic>integer ( factoradic -- n ) <reversed> [ factorial * ] map-index sum ;
: >factoradic ( permutation -- factoradic ) dup [ unclip [ '[ _ over < [ 1 - ] when ] map ] keep ] replicate nip ;
: depermutation ( seq -- n seq ) [ 2array ] map-index sort-keys unzip invert >factoradic factoradic>integer swap ;
: next-permutation ( seq -- seq ) dup depermutation [ 3dup permutation <=> +lt+ = not ] [ [ 1 + ] dip ] while permutation nip ;

New Annotation