unit U_Permutes1;

{Copyright 2002, Gary Darby, Intellitech Systems Inc., www.DelphiForFun.org

 This program may be used or modified for any non-commercial purpose
 so long as this original notice remains in place.
 All other rights are reserved
 }

{Investigations in generating permutations of N objects}

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, StdCtrls, ExtCtrls;

type
TForm1 = class(TForm)
    ListBox1: TListBox;
    Edit1: TEdit;
    NCount: TUpDown;
    SedgewickBtn: TButton;
    Label1: TLabel;
    Label2: TLabel;
    DarbyBtn: TButton;
    Label3: TLabel;
    SawadaPermuteBtn: TButton;
    DisplayGrp: TRadioGroup;
    SepaBtn: TButton;
    Label4: TLabel;
procedure SedgewickBtnClick(Sender: TObject);
procedure DarbyBtnClick(Sender: TObject);
procedure SawadaPermuteBtnClick(Sender: TObject);
procedure SepaBtnClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
n:integer; {nbr of numbers in each permutation}
count:integer; {calulated number of permutations (N!)}
permutecount:integer;
    start,stop,freq:int64; {values for timing calculations}
x:array of byte; {dynamic array of outputs}
Procedure AddListEntry; {Add x entry to list}
procedure setup;  {all the setup stuff for any method}
procedure showresult; {display final stats}
end;

var
Form1: TForm1;

implementation

{$R *.DFM}
Uses UMakeCaption;

{***************** Setup **************}
Procedure TForm1.setup;
{Initialization stuff}
var
i:integer;
Begin
listbox1.clear;
  N:=nCount.position; {size}
count:=1;
  permutecount:=0;
for i:=1 to N do count:=count*(i); {This is N!, the number of permutations}
setlength(x,n); {set length of dynamic array}
for i:=0 to n-1 do x[i]:=i+1; {initialize output permutations}
addlistentry;  {add first entry}
screen.cursor:=crHourglass;
  queryperformancefrequency(freq);
  queryperformancecounter(start);
end;

{******************* AddListEntry *********}
Procedure TForm1.addlistentry;
{count and conditionally add a permutation to the list}
var
i:integer;
    s,w:string;
begin
if (displaygrp.itemindex=0) and (listbox1.items.count<1000)
then
begin
s:='';
For i:= 0 to length(x)-1 do
begin
if x[i]<10 then w:=inttostr(x[i])
else w:=','+inttostr(x[i])+','; {need to separate 2 digit numbers}
s:=s+w;
end;
if s[length(s)]=',' then delete(s,length(s),1);
      listbox1.items.add(s);
end;
    inc(permutecount);
end;

{************** ShowResult *************}
procedure TForm1.ShowResult;
begin
queryperformancecounter(stop);
  screen.cursor:=crDefault;
  label3.caption:='Permutation count: '+inttostr(permutecount)
                  +#13+inttostr(1000*(stop-start) div freq)+' milliseconds' ;
end;


procedure TForm1.SedgewickBtnClick(Sender: TObject);
{Algorithm from "Algorithms", Robert Sedgewick, Addison-Wesley, 1984}
{Recursive - short code, but not easy to understand}
var now:integer;  { variable used by procedure "permute"}
Procedure Permute(k:integer);
var
i:integer;
Begin
inc(now);
     x[k-1]:=now;
If now=N then addlistentry;
for i:= 1 to n do
If x[i-1]=0 then permute(i);
     dec(now);
     x[k-1]:=0;
end;

var i:integer;
begin
setup;
{setup added 1st entry, but Sedgewick generates it, so we need to undo a few things}
listbox1.clear;
for i:= 0 to n-1 do x[i]:=0;
  permutecount:=0;

  now:=-1;  {parameter used by "permute" procedure}
permute(1); {generate all permutations}
showresult;
end;

procedure TForm1.DarbyBtnClick(Sender: TObject);
{Longer and slower, but works the way most humans would generate
 permutations in lexicographic order}

Function CanInc(p:integer; var newval:integer):boolean;
{Tests to see if we can increment the integer at p}
{If there is an integer greater than x[p] that doesn't appear
      to the left, then we can increment x[p] to that
      integer.  Set result to true if newval is a usable value,
      false otherwise}
var
i:integer;
Begin
if x[p]>=n then result:=false
else
Begin
result:=false;
         newval:=x[p];
{try all values > x[p] until we find an unused one,
          or run out of numbers}
while (result=false) and (newval<n) do
Begin
inc(newval);
           result:=true;
for i:= 0 to p-1 do
if x[i]=newval then Begin result:=false;  break; end;
end;
end;
end;
var
i,j,incpos:integer;
  OK:Boolean;
  newval:integer;


begin  {DarbyBtnClick}
setup;
for i:= 2 to count do
Begin
{find the position to increment starting with rightmost}
incpos:=n-1;
    ok:=false;

while (incpos>=0) and (not OK) do
{If we can increment this position, do it}
if CanInc(incpos,newval) then Begin x[incpos]:=newval; ok:=true; end
else dec(incpos);  {otherwise, back-up to previous position}

{now reset the remainder to the smallest values possible}
for j:= incpos+1 to n-1 do
Begin
x[j]:=0;
if CanInc(j,newval) then x[j]:=newval
else showmessage('System error');
end;
    addlistentry;
end;
  showresult;
end;


{********************* SawadaBtnClick ******************}
procedure TForm1.SawadaPermuteBtnClick(Sender: TObject);
{Derived from a program by Joe Sawada, 1997. }
{
{===================================================================}
{ Pascal program for distribution from the Combinatorial Object     }
{ Server. Generate permutations in lexicographic order. This is     }
{ the same version used in the book "Combinatorial Generation."     }
{ The program can be modified, translated to other languages, etc., }
{ so long as proper acknowledgement is given (author and source).   }
{ Programmer: Joe Sawada, 1997.                                     }
{ The latest version of this program may be found at the site       }
{ http://sue.uvic.ca/~cos/inf/perm/PermInfo.html                    }
{===================================================================}
{Same algorithm as Sepa Algorithm below - just not as well documented}
{But fairly fast and concise}


procedure swap(i:integer; j:integer);
{swap x[i] and x[j]}
var temp : byte;
begin temp := x[i];x[i] := x[j]; x[j] := temp;  end;

{************** Nextpermute ***************}
function NextPermute(var x:array of byte): Boolean;
{X, permutation result array,  is a 0 based array,
       so index value of k refers to (k-1)th entry}
var k,j,r,s : integer;
begin
k := n-2;
while x[k] > x[k+1] do k:=k-1;
if k<0 then result:=false
else
begin
j := n-1;
while x[k] > x[j] do j:=j-1;
          swap(j,k);
          r:=n-1;
          s:=k+1;
while r>s do
begin
swap(r,s);
            r:=r-1;
            s:=s+1;
end;
          result:=true;
end;
end;


begin {SawadaBtnClick}
setup;
while nextpermute(x) do addlistentry;
  showresult;
end;

{******************** SEPABtnClick ***************}
procedure TForm1.SepaBtnClick(Sender: TObject);
{
   SEPA: A Simple, Efficient Permutation Algorithm
   Jeffrey A. Johnson, Brigham Young University-Hawaii Campus
   http://www.cs.byuh.edu/~johnsonj/permute/soda_submit.html
  }
{My new favorite - short, fast,  understandable  and requires no data
  structures or intialization, each output is generated as the
  next permutation after the permutation passed!}

function nextpermute(var a:array of byte):boolean;
var
i,j,key,temp,rightmost:integer;
begin
{1. Find Key, the leftmost byte of rightmost in-sequence pair
        If none found, we are done}

{  Characters to the right of key are the "tail"}
{  Example 1432 -
       Step 1:  check pair 3,2 - not in sequence
               check pair 4,3 - not in sequence
               check pair 1,4 - in sequence ==> key is a[0]=1, tail is 432

    }
rightmost:=high(a);
    i:=rightmost-1; {Start at right end -1}
while (i>=0) and (a[i]>=a[i+1]) do dec(i); {Find in-sequence pair}
if i>=0 then  {Found it, so there is another permutation}
begin
result:=true;
      key:=a[i];

{2A. Find rightmost in tail that is > key}
j:=rightmost;
while (j>i) and (a[j]<a[i]) do dec(j);
{2B. and swap them} a[i]:=a[j]; a[j]:=key;
{Example - 1432  1=key 432=tail
       Step 2:  check 1 vs 2,  2 > 1 so swap them producing 2431}

{3. Sort tail characters in ascending order}
{   By definition, the tail is in descending order now,
          so we can do a swap sort by exchanging first with last,
          second with next-to-last, etc.}
{Example - 2431  431=tail
        Step 3:
                 compare 4 vs 1 - 4 is greater so swap producing 2134
                 tail sort is done.

                final array = 2134
     }
inc(i); j:=rightmost; {point i to tail start, j to tail end}
while j>i do
begin
if a[i]>a[j] then
begin {swap}
temp:=a[i]; a[i]:=a[j]; a[j]:=temp;
end;
        inc(i); dec(j);
end;
end
else result:=false; {else please don't call me any more!}
end;

begin {SepaBtnClick}
setup;
{replaces the passed permutation with the next, in lexicographic order}
while nextpermute(x) do addlistentry;
  showresult;
end;

{*************** FormCreate ***************}
procedure TForm1.FormCreate(Sender: TObject);
begin
makecaption('Permutes1',#169+' 2002, G. Darby, delphiforfun.org', self);
end;

end.