------------------------------------------------- permut.fs -----------------------
( F O R T H )
\ To run (for example with gforth): 
\ gforth permut.fs 4

2 value num
0 value index
1 value countie
0 value start
0 value old
0 value minfree

0 value f
0 value c

: aget cells + @ ;
: aset cells + ! ;

: prind
   num 0 do
      c i aget .
   loop
   ." | "
   . 
   cr
;

: freespot
   dup
   0> over 0= or
   if
      dup
      1 swap f swap
      aset
      dup
      minfree <
      if to minfree
      else drop then
   else drop then
;

: takespot
   dup
   0> over 0= or
   if
      dup
      0 swap f swap aset
      minfree =
      if
         minfree 1 + num <
         if
            num minfree 1 + do
               f i aget
               1 =
               if 
                  i to minfree 
                  leave
               then
            loop
         then
      then
   then
;

: perm
   2 to num
   dup
   num >
   if to num
   else drop then

   0 to index
   1 to countie
   0 to start
   0 to old
   0 to minfree

   align
   here to f
   num cells allot
   
   align
   here to c
   num cells allot

   num 0 do
      -1 c i aset
      1 f i aset
   loop

   begin
      index 0 > index 0 = or
      while
         c index aget   1 +    to start
         start 0 =
         if minfree to start then
         start num <
         if
            num start do
               f i aget 1 =
               if
                  c index aget
                  freespot
                  i takespot
                  i c index aset
                  index num 1 - <
                  if index 1 + to index
                  else
                     i freespot
                     countie prind
                     countie 1 + to countie
                  then
                  leave
               then
            loop
         then
         index old =
         if
            c index aget freespot
            -1 c index aset
            index 1 - to index
         then
         index to old
   repeat
;
: run
    0 0 next-arg 2dup
    0= swap 0= and
    if 2 perm bye
    else >number drop drop drop perm bye then
;
run