ucombov2.pas

Delphi for fun library v12, latest. This is the library for manuplating list, combination-permutati

unit UcomboV2;

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

  Revisions:
  Copyright (C)  2005 Charles Doumar

 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
 }

{ Combo unit contains an object which provides an array of combinations
  or permutations of 'r' of 'n' numbers.

  Permutations are all subsets selecting r of n, combinations are the
  unique subsets.

  To use the Comboset object, call Combos.Setup(r,n,Combotype) where

    r is subset size;

    n is the size of the set to select from (current max is 100),

    Ctype is a variable specifying combinations or permutations.
       Combinations ==> return combinations (unique subsets)
       Permutations ==> return all subsets (permutations)

   Other procedures are:

     GetNext - gets next combination or permutation based on Ctype.
        Subsets are in 'Selected' array. GetNext returns false when
        no more subsets are available.

        Note: GetNextCombo and GetNextPermute may be called directly
              for efficiency.  But do not mix calls to these two routines.

     GetCount - return number of subsets that will be returned.

  }

interface

const
  MaxEntries = 100;

type
  ByteArray  = array[0..MaxEntries + 1] of integer;
  TCombotype = (Combinations,  {Lexicographical order up}
    Permutations,              {Lexicographical order up}
    CombinationsDown,          {Lexicographical order down}
    PermutationsDown,          {Lexicographical order down}
    CombinationsCoLex,         {Co-Lexicographical order up}
    CombinationsCoLexDown,     {Co-Lexicographical order down}
    PermutationsRepeat,        {Lexicographical order up}
    PermutationsWithRep,
    PermutationsRepeatDown,    {Lexicographical order down}
    CombinationsWithrep,
    CombinationsRepeat,        {Lexicographical order up}
    CombinationsRepeatDown);   {Lexicographical order down}

  TComboSet = class(TObject)
  private
    N: word;
    R: word;
    NumberOfSubsets: int64;
    Ctype: TComboType; {Generate Combinations or permutations}
    Loops: bytearray;  {for efficiency, truncate search at loops for
                             each position, e.g. if n=10, then leftmost
                             has 10 of 10, for each of these, next position
                             has 9, next 8, etc. }
    {NEW PRIVATE FUNCTIONS ADDED BY CHARLES DOUMAR}
    procedure ClearArrays;
    {******************** Setup First Procedures ********************}
    {Sets first combinatorial sequence}
    procedure SetupFirstCoLexRCombo;
    procedure SetupFirstLexRCombo;
    procedure SetupFirstLexRepRCombo;
    procedure SetupFirstLexRPermute;
    procedure SetupFirstLexRepRPermute;
    {******************** Setup Last Procedures ********************}
    {Sets last combinatorial sequence}
    procedure SetupLastCoLexRCombo;
    procedure SetupLastLexRCombo;
    procedure SetupLastLexRepRCombo;
    procedure SetupLastLexRPermute;
    procedure SetupLastLexRepRPermute;
    {******************** Setup Next Procedures ********************}
    procedure SetupNextCoLexRCombo;
    procedure SetupNextLexRCombo;
    procedure SetupNextLexRepRCombo;
    procedure SetupNextLexRPermute;
    procedure SetupNextLexRepRPermute;
    {******************** Setup Prev Procedures ********************}
    procedure SetupPrevCoLexRCombo;
    procedure SetupPrevLexRCombo;
    procedure SetupPrevLexRepRCombo;
    procedure SetupPrevLexRPermute;
    procedure SetupPrevLexRepRPermute;
    {******************** Valid Function *********************}
    function IsValidRN(const RPick,Number:integer;const ACtype:TComboType):boolean;
    function IsValidRNRank(const RPick,Number,Rank:integer;const ACtype:TComboType):boolean;
  public
    Selected: bytearray;

    {Setup to retrieve R of N objects}

    procedure Setup(newR, newN: word; NewCtype: TComboType); {Replaced by SetupR}

    function Getnext: boolean;  {Replaced by GetNextPrevR, NextR, PrevR}
    function GetNextCombo: boolean; {Replaced by NextLexRCombo}
    function GetNextPermute: boolean; {Replaced by NextLexRPermute}
    Function GetNextComboWithRep:Boolean;
    Function GetNextPermuteWithRep:Boolean;
    function GetCount: int64;
    function GetR: integer;

    {NEW PUBLIC FUNCTIONS ADDED BY CHARLES DOUMAR}
    function GetN: integer;
    function GetCtype: TCombotype;


    {******************** Misc Calculator Functions ********************}
    {Returns number of unique sequences for a particular TComboType}
    function GetNumberSubsets(const RPick, Number : word; const ACtype : TComboType):int64;
    {Returns binomial value}
    function Binomial(const RPick, Number: integer): int64;
    {Returns factorial value}
    function Factorial(const Number: integer): int64;
    {Returns number of r-combinations}
    function GetRCombo(const RPick, Number: integer): int64;
    {Returns number of r-combinations with repetition}
    function GetRepRCombo(const RPick, Number: integer): int64;
    {Returns number of r-permutations}
    function GetRPermute(const RPick, Number: integer): int64;
    {Returns number of r-permutations with repetition}
    function GetRepRPermute(const RPick, Number: integer): int64;

    {******************** Main Setup Procedures ********************}
    {Replaces Setup and set Array to position before first/last position}
    procedure SetupR(NewR, NewN: word; NewCtype: TComboType);
    {Replaces Setup but set Array to first/last valid position}
    procedure SetupRFirstLast(NewR, NewN: word; NewCType: TComboType);

    {****************** Checking Functions ********************}
    {Returns True if combinatorial sequence is valid}
    function IsValidRSequence: boolean;

    {******************** DIRECTIONAL PROCEDURES ********************}
    {Change iterative direction}
    function ChangeRDirection: boolean;
    {Replaces GetNext}
    function GetNextPrevR: boolean;

    {******************** Next Functions ********************}
    {Returns next combinatorial position (if any) and returns boolean result}
    function NextR: boolean;
    function NextLexRPermute: boolean;  {replaces GetNextPermute}
    function NextLexRepRPermute: boolean;
    function NextLexRCombo: boolean;    {replaces GetNextCombo}
    function NextLexRepRCombo: boolean;
    function NextCoLexRCombo: boolean;

    {******************** Prev Functions ********************}
    {Returns previous combinatorial position (if any) and returns boolean result}
    function PrevR: boolean;
    function PrevCoLexRCombo: boolean;
    function PrevLexRepRPermute: boolean;
    function PrevLexRPermute: boolean;
    function PrevLexRCombo: boolean;
    function PrevLexRepRCombo: boolean;

    {******************** Rank Functions ********************}
    {Returns rank of particular combinatorial sequence}
    function RankR: int64;
    function RankCoLexRCombo: int64;
    function RankLexRCombo: int64;
    function RankLexRepRCombo: int64;
    function RankLexRPermute: int64;
    function RankLexRepRPermute: int64;

    {******************** Unrank Functions ********************}
    {Returns combinatorial sequence from a particular rank}
    function UnRankR(const Rank: int64):boolean;
    function UnRankCoLexRCombo(const Rank: int64):boolean;
    function UnRankLexRCombo(const Rank: int64):boolean;
    function UnRankLexRepRCombo(const Rank: int64):boolean;
    function UnRankLexRPermute(const Rank: int64):boolean;
    function UnRankLexRepRPermute(const Rank: int64):boolean;

    {******************** Random Functions ********************}
    {Returns random combinatorial sequence }
    function RandomR(const RPick, Number: integer; const NewCtype: TComboType):Boolean;
    function RandomCoLexRCombo(const RPick, Number: integer):Boolean;
    function RandomLexRCombo(const RPick, Number: integer):Boolean;
    function RandomLexRepRCombo(const RPick, Number: integer):Boolean;
    function RandomLexRPermute(const RPick, Number: integer):Boolean;
    function RandomLexRepRPermute(const RPick, Number: integer):Boolean;
  end;

var
  Combos: TComboSet;  {created at initialization time}

implementation

uses math;

var
  Count: int64;  {count of entries}

procedure TComboset.Setup(newR, newN: word; NewCtype: TComboType);
begin
  setupr(newR, newN, NewCtype);
end;


function TComboset.GetNextPermute: boolean;
{Retained for compatibility - replaced by NextLexRPermute}
begin
  result:=nextLexRPermute;
end;



function Tcomboset.getNextcombo: boolean;
{Retained for compatibility - replaced by NextLexRCombo}
begin
  result:=nextlexRCombo;
end;


function Tcomboset.getnext;
{for compatibility - replaced by NextR}
begin
  result:=GetnextPrevR;
end;



function TComboset.Getcount: int64;
begin
  Result := NumberOfSubsets;
end;

function TComboset.GetR: integer;
begin
  Result := r;
end;

{NEW FUNCTIONS ADDED BY CHARLES DOUMAR}
function TComboset.GetN: integer;
begin
  Result := n;
end;

function TComboset.GetCType: TComboType;
begin
  Result := Ctype;
end;


 {******************** PRIVATE FUNCTION ********************}
procedure TComboSet.ClearArrays;
begin
  FillChar(Selected, SizeOf(Selected), 0); {quick clear array}
  FillChar(Loops, SizeOf(Loops), 0);
end;

 {******************** Setup (Private) Procedures ********************}
 {******************** Setup First Procedures ********************}
 {Function to set first value position in Selected and Loops array}
procedure TComboSet.SetupFirstCoLexRCombo;
begin
  SetupFirstLexRCombo;   {no reason to write it twice}
end;

procedure TComboSet.SetupFirstLexRCombo;
var
  i: integer;
begin
  for i := 1 to r do
  begin
    Selected[i] := i
  end;    {set to 1,2,3...}
end;

procedure TComboSet.SetupFirstLexRPermute;
var
  i: integer;
begin
  for i := 1 to r do
  begin
    Selected[i] := i;    {set to 1,2,3 ...}
    Loops[i]    := 1;    {set Loops array to 1,1,1...}
  end;
end;

procedure TComboSet.SetupFirstLexRepRCombo;
begin
  SetupFirstLexRepRPermute;
end;


procedure TComboSet.SetupFirstLexRepRPermute;
var
  i: integer;
begin
  for i := 1 to r do
  begin
    Selected[i] := 1
  end;   {set to 1,1,1 ...}
end;

 {******************** Setup Last Procedures ********************}
 {Functions to set last value position in Selected and Loops array}
procedure TComboSet.SetupLastCoLexRCombo;
begin
  SetupLastLexRCombo;
end;

procedure TComboSet.SetupLastLexRCombo;
var
  i: integer;
begin
  for i := 1 to r do
  begin
    Selected[i] := n - r + i
  end;    {setup in decreasing order}
end;

procedure TComboSet.SetupLastLexRPermute;
var
  i: integer;
begin
  for i := 1 to r do
  begin
    Selected[i]      := n - i + 1;
    Loops[n - i + 1] := 1;
  end;
end;

procedure TComboSet.SetupLastLexRepRCombo;
begin
  SetupLastLexRepRPermute;
end;

procedure TComboSet.SetupLastLexRepRPermute;
var
  i, k: integer;
begin
  k := n;
  for i := 1 to r do
    Selected[i] := k
end;

 {******************** Setup Next Procedures ********************}
 {Setup function to initialize Selected and Loops Array}
procedure TComboSet.SetupNextCoLexRCombo;
var
  i: integer;
begin
  for i := 1 to r do
    Selected[i] := i - 1
end;

procedure TComboSet.SetupNextLexRCombo;
var
  i: integer;
begin
  for i := 1 to r - 1 do
    Selected[i] := i;
  Selected[r] := r - 1;
end;

procedure TComboSet.SetupNextLexRepRCombo;
var
  i: integer;
begin
  for i := 1 to r - 1 do
    Selected[i] := 1;
  Selected[r] := 0;
end;

procedure TComboSet.SetupNextLexRepRPermute;
var
  i: integer;
begin
  for i := 1 to r - 1 do
    Selected[i] := 1;
  Selected[r] := 0;
end;

procedure TComboSet.SetupNextLexRPermute;
var
  i: integer;
begin
  Selected[1] := 0;
  Loops[0]    := 1;
  for i := 2 to r do
  begin
    Selected[i] := n - i + 2;
    Loops[Selected[i]] := 1;
  end;
end;

 {******************** Setup Perv Procedures ********************}
 {Setup function to initialize Selected and Loops Array}

procedure TComboSet.SetupPrevCoLexRCombo;
var
  i: integer;
begin
  for i := 1 to r - 1 do
    Selected[i] := i;
  Selected[r] := n + 1;
end;

procedure TComboSet.SetupPrevLexRCombo;
var
  i: integer;
begin
  for i := 1 to r do
    Selected[i] := i + n - r;
  Inc(Selected[r]);
end;

procedure TComboSet.SetupPrevLexRepRCombo;
begin
  SetupPrevLexRepRPermute;
end;

procedure TComboSet.SetupPrevLexRepRPermute;
var
  i: integer;
begin
  for i := 1 to r - 1 do
    Selected[i] := n;
  Selected[r] := n + 1;
end;

procedure TComboSet.SetupPrevLexRPermute;
var
  i: integer;
begin
  for i := 1 to r do
  begin
    Selected[i] := n - i + 1;
    Loops[Selected[i]] := 1;
  end;
  Loops[Selected[r]] := 0;
  Selected[r] := n + 1;
end;

{***********  Valid Functions *********}
function TComboSet.IsValidRN(const RPick,Number:integer;const ACtype:TComboType):boolean;

begin
  Result := false;
  if (RPick < 1) or (Number < 1) or
     ((RPick > Number) and (not(aCtype in [PermutationsRepeat,