Delphi - Get combinations from multiple sets - delphi

Using: Delphi 10.2 Tokyo
Please link me to an algorithm or code to get all possible combinations of values from multiple sets, with one value per set. The number of sets is not known in advance, nor the number of values in each set.
Example:
1. (1, 2, 3) (A, B)
Desired result:
1 A
1 B
2 A
2 B
3 A
3 B
2. (1, 2, 3, 4) (A, B) (X, Y, Z)
Desired result:
1 A X
1 A Y
1 A Z
2 A X
2 A Y
2 A Z
3 A X
3 A Y
3 A Z
4 A X
4 A Y
4 A Z
1 B X
1 B Y
1 B Z
2 B X
2 B Y
2 B Z
3 B X
3 B Y
3 B Z
4 B X
4 B Y
4 B Z
Thanks in advance!

Recursive and iterative generation (with storage and without storage) of cartesian product of 2d array A elements
var
A: array of array of Integer;
B: array of array of Integer;
i, j: Integer;
s: string;
NN: Integer;
procedure CartesianRec(From: Integer; cs: string);
var
j: integer;
begin
if From = Length(A) then
Memo1.Lines.Add(cs)
else
for j := 0 to High(A[From]) do
CartesianRec(From + 1, cs + IntToStr(A[From, j]) + ' ');
end;
procedure CartesianIter;
var
i, j, k, l, c, N, M: Integer;
begin
NN := 1;
for k := 0 to High(A) do
NN := NN * Length(A[k]);
SetLength(B, NN, Length(A));
N := NN;
M := 1;
for k := 0 to High(A) do begin
N := N div Length(A[k]);
c := 0;
for l := 0 to M - 1 do
for i := 0 to High(A[k]) do
for j := 0 to N - 1 do begin
B[c, k] := A[k, i];
Inc(c);
end;
M := M * Length(A[k]);
end;
end;
procedure CartesianOnline;
var
i, j, k, l, c, N, M, dimA: Integer;
s: string;
begin
NN := 1;
dimA := Length(A);
//SetLength(CartProduct, dimA);
for k := 0 to dimA - 1 do
NN := NN * Length(A[k]);
for i := 0 to NN - 1 do begin
j := i;
s := '';
for k := dimA - 1 downto 0 do begin
l := j mod Length(A[k]);
s := IntToStr(A[k][l]) + ' ' + s;
//we can also put CartProduct[k] := A[k][l];
j := j div Length(A[k]);
end;
Memo1.Lines.Add(s);
//or use CartProduct
end;
end;
begin
nn := 1;
SetLength(A, 3);
for i := 0 to High(A) do begin
SetLength(A[i], 5 - i);
s := '';
for j := 0 to High(A[i]) do begin
A[i, j] := nn;
Inc(nn);
s := s + IntToStr(A[i, j]) + ' ';
end;
Memo1.Lines.Add(s);
end;
Memo1.Lines.Add('------');
CartesianRec(0, '');
Memo1.Lines.Add('------');
CartesianIter;
for i := 0 to NN - 1 do begin
s := '';
for j := 0 to High(A) do
s := s + IntToStr(B[i, j]) + ' ';
Memo1.Lines.Add(s);
end;
Memo1.Lines.Add('------');
CartesianOnline;
A:
1 2 3 4 5
6 7 8 9
10 11 12
Result:
1 6 10
1 6 11
1 6 12
1 7 10
1 7 11
1 7 12
1 8 10
1 8 11
1 8 12
1 9 10
1 9 11
1 9 12
2 6 10
2 6 11
...
5 8 12
5 9 10
5 9 11
5 9 12

I used TLists and Integer arrays and managed to solve the problem. Here is my code:
uses Classes, SysUtils, Generics.Collections;
type
TIntArray = array of integer;
TIntArrayList = TList<TIntArray>;
TCartesianProduct = class
private
FSetList: TIntArrayList;
public
constructor Create;
destructor Destroy; override;
procedure AddSet(ASet: TIntArray);
procedure GetCombinations(var AIntArrayList: TIntArrayList);
end;
implementation
{ TCartesianProduct }
constructor TCartesianProduct.Create;
begin
FSetList := TIntArrayList.Create;
end;
destructor TCartesianProduct.Destroy;
begin
FSetList.Free;
end;
procedure TCartesianProduct.AddSet(ASet: TIntArray);
begin
FSetList.Add(ASet);
end;
procedure TCartesianProduct.GetCombinations(var AIntArrayList: TIntArrayList);
var
WorkList, OuputList: TIntArrayList;
r: TIntArray;
n, c, l: integer;
f: Boolean;
begin
WorkList := TIntArrayList.Create; // Length of each set array, and current iteration index
OuputList := TIntArrayList.Create;
try
n := FSetList.Count;
for c := 0 to n - 1 do
WorkList.Add([Length(FSetList[c]), 0]);
while ((WorkList[0][1] < WorkList[0][0])) do
begin
SetLength(r, n); // result array length is the number of sets
for c := 0 to FSetList.Count - 1 do
begin
r[c] := FSetList[c][WorkList[c][1]];
end;
Inc(WorkList[n - 1][1]); // last work list item (set)
if (WorkList[n - 1][1] = WorkList[n - 1][0]) and (n - 1 <> 0) then // if it equal the length of the set
begin
WorkList[n - 1][1] := 0; // then reset it back to zero
l := n - 1; // make pointer point to previous item up
f := false;
repeat
Dec(l);
if (l >= 0) then
begin
Inc(WorkList[l][1]); // increase index in previous item
if (l <> 0) and (WorkList[l][1] = WorkList[l][0]) then
begin
WorkList[l][1] := 0; // If that items pointer points to the last item, reset it to zero
end
else
f := true;
end
else
f := true;
until f;
end;
OuputList.Add(r);
end;
AIntArrayList.Clear;
for c := 0 to OuputList.Count - 1 do
AIntArrayList.Add(OuputList[c]);
finally
OuputList.Free;
WorkList.Free;
end;
end;
Test it with this code:
procedure TfmMain.btTestClick(Sender: TObject);
var
intset1, intset2, intset3: TIntArray;
outsetlist: TIntArrayList;
CP: TCartesianProduct;
c, d: Integer;
l: string;
begin
SetLength(intset2, 4);
SetLength(intset3, 4);
intset2[0] := 105;
intset2[1] := 106;
intset2[2] := 107;
intset2[3] := 108;
intset3[0] := 109;
intset3[1] := 110;
intset3[2] := 111;
intset3[3] := 112;
outsetlist := TIntArrayList.Create;
CP := TCartesianProduct.Create;
try
CP.AddSet(intset2);
CP.AddSet(intset3);
CP.GetCombinations(outsetlist);
ListBox1.Clear;
for c := 0 to outsetlist.Count - 1 do
begin
l := '';
for d := 0 to high(outsetlist[c]) do
l := l + Format('%d ', [outsetlist[c][d]]);
ListBox1.Items.Add(l);
end;
finally
CP.Free;
outsetlist.Free;
end;
end;

Related

Combination and Permutation with merging function

I have a n number of strings which I need to merge into n number of strings in multiple combinations/permutations. the string cannot repeat itself and combination in single merge doesnt matter ( S1, S2 ) = ( S2, S1 )...
This is used when building a tree model and it decided which combination of characteristics is the best to merge...
This code is what I've wrote for permutations. List contains characteristic attributes, Splits is the number of splits I want to make , SplitList return which attributes need to be merge together... for binary tree I input "2" for Splits and for non-binary tree I run a cycle to return the best value for each of the splits .
I.E.
I have "A", "B", "C", "D", "E", "F".
If i Need to merge into 2 string
2. "A,B,C" and "D,E,F" or "A,C,E" and "B,D,F" or "A,E,F" and "B,C,D"
3. "A,B, and "C,D" and "E,F" or "A,D" and "C,B" and "E,F"
Also minimum number in a string is 1, maximum n-1.
I.E
2. "A" and "B,C,D,E,F" or "C" and "A,B,D,E,F" is a valid merging
function TSplitEngine.doTest(List: TList; Splits: Integer; var SplitList : TArray<Integer>): Double;
var
i, j, SplitNo, Pointer : Integer;
tmpNode : TDTreeNode;
CurRes, CurOut : Double;
TestArr : RTestArr;
ResArr: TArray<double>;
SplitStr : String;
DoSplit, FindSplit : Boolean;
TestList : TArray<Integer>;
begin
Result := DefaultVal;
SetLength( TestList, Splits );
for i := 0 to Length( TestList ) - 1 do
TestList[ i ] := i + 1;
TestArr.Size := Splits + 1;
DoSplit := True;
while DoSplit do
begin
Inc(Iteration);
TestArr.Clear;
for i := 0 to List.Count - 1 do
begin
tmpNode := TDTreeNode( List[ i ] );
j := 0;
FindSplit := True;
While ( j < Length( TestList ) ) and ( FindSplit ) do
begin
if i < TestList[ j ] then
begin
Combine Characteristics
FindSplit := False;
end
else if ( i >= TestList[ Length( TestList ) - 1 ] ) then
begin
Combine last split characteristics
FindSplit := False;
end;
inc( j );
end;
TestArr.AllTotal := TestArr.AllTotal + ( tmpNode.Goods + tmpNode.Bads );
end;
//CalcNode returns the result of this particular splits
CurRes := CalcNode( TestArr );
SetLength( ResArr, 2 );
ResArr[ 1 ] := CurRes;
if IsBetter( CurRes, Result ) then
begin
Result := CurRes;
SplitList := Copy( TestList, 0, Length( TestList ) );
end;
SplitNo := 1;
FindSplit := True;
//Move the split like a pointer...
i := Length( TestList ) - 1;
while ( i >= 0 ) and FindSplit do
begin
if ( TestList[ i ] < ( List.Count - SplitNo ) ) then
begin
Pointer := TestList[ i ] + 1;
for j := i to Length( TestList ) - 1 do
begin
TestList[ j ] := Pointer;
inc( Pointer );
end;
FindSplit := False;
end
else if ( i = 0 ) then
DoSplit := False;
inc ( SplitNo );
Dec( i );
end;
end;
end;
the permutation code seems to be working and the only thing to do would be to tidy it up.
I've tried a few times to convert this code to do combinations but never seemed to work.
I have old code for generation of set partitions with set size <= 10 (due to set comparison implemented through strings). Note that number of partitions for n=10 is 115975 (Bell number).
Procedure generates non-repeating partitions of set into KP parts, so you have to go through all KP values.
Part of output including some two-parts and some three-parts partitions:
1,4 | 2,3,5 |
1,4,5 | 2,3 |
1,5 | 2,3,4 |
1 | 2 | 3,4,5 |
1 | 2,3 | 4,5 |
1 | 2,3,4 | 5 |
procedure generate_multi_partitions(values: array of Integer; KP: Integer);
var
n, i: Integer;
avail: array of Boolean;
output: array of TStringList;
procedure foo(k: Integer); forward;
procedure bar(k, i: Integer);
var
j: Integer;
begin
output[k].add(IntToStr(values[i]));
avail[i] := False;
foo(k + 1);
for j := i + 1 to n - 1 do
if avail[j] and ((j = 0) or (values[j - 1] <> values[j]) or
(not avail[j - 1])) then
bar(k, j);
output[k].Delete(output[k].Count - 1);
avail[i] := True;
end;
procedure foo(k: Integer);
var
i, j: Integer;
s: string;
begin
if (k >= 2) and (output[k - 2].CommaText > output[k - 1].CommaText) then
Exit;
if k = KP - 1 then begin
output[k].Clear;
for i := 0 to n - 1 do
if avail[i] then
output[k].add(IntToStr(values[i]));
if (output[k].Count > 0) and
((k = 0) or (output[k - 1].CommaText <= output[k].CommaText)) then
begin
s := '';
for j := 0 to KP - 1 do
s := s + output[j].CommaText + ' | ';
Memo1.Lines.add(s);
end;
output[k].Clear;
end
else
for i := 0 to n - 1 do
if avail[i] then begin
bar(k, i);
Exit;
end;
end;
begin
n := length(values);
SetLength(avail, n);
SetLength(output, KP);
for i := 0 to KP - 1 do
output[i] := TStringList.Create;
for i := 0 to n - 1 do
avail[i] := True;
foo(0);
for i := 0 to KP - 1 do
output[i].Free;
end;
var
parts: Integer;
begin
for parts := 1 to 5 do
generate_multi_partitions([1, 2, 3, 4, 5], parts);
end;

Compile With Win32- Ok But With Win64- Compiler Error E2064

The following code compiles with Win32 but produces Delphi compiler error E2064 left side cannot be assigned to when compiled with Win64.
type
PRGB24 = ^TRGB24;
TRGB24 = record
B, G, R: Byte;
end;
PRGBArray = ^TRGBArray;
TRGBArray = array [Word] of TRGB24;
procedure TFormCurves.ApplyCurve(Src: TIEBitmap);
var
iRGBArray: PRGBArray;
SFill, X, Y: Integer;
begin
if not AImageLoaded then
Exit;
iRGBArray := PRGBArray(Src.Scanline[0]);
SFill := Integer(Src.Scanline[1]) - Integer(iRGBArray);
for Y := 0 to Src.Height - 1 do
begin
for X := 0 to Src.Width - 1 do
begin
iRGBArray[X].R := ALUT[0, ALUT[1, iRGBArray[X].R]];
iRGBArray[X].G := ALUT[0, ALUT[2, iRGBArray[X].G]];
iRGBArray[X].B := ALUT[0, ALUT[3, iRGBArray[X].B]];
end;
Inc(Integer(iRGBArray), SFill);//compiler error E2064 left side cannot be assigned to
end;
end;
procedure TFormCurves.GetHist;
var
iRGBArray: PRGBArray;
X, Y, SFill: Integer;
iIEBitmap: TIEBitmap;
iRGB: TRGB24;
R, G, B, l: Byte;
begin
if not AImageLoaded then
Exit;
for Y := 0 to 3 do
begin
AMaxHistory[Y] := 0;
for X := 0 to 255 do
AHistory[Y, X] := 0;
end;
iIEBitmap := imgView.IEBitmap;
iRGBArray := PRGBArray(iIEBitmap.Scanline[0]);
SFill := Integer(iIEBitmap.Scanline[1]) - Integer(iRGBArray);
for Y := 0 to iIEBitmap.Height - 1 do
begin
for X := 0 to iIEBitmap.Width - 1 do
begin
iRGB := iRGBArray[X];
R := iRGB.R;
G := iRGB.G;
B := iRGB.B;
l := (R + G + B) div 3;
AHistory[0, l] := AHistory[0, l] + 1;
AHistory[1, R] := AHistory[1, R] + 1;
AHistory[2, G] := AHistory[2, G] + 1;
AHistory[3, B] := AHistory[3, B] + 1;
end;
Inc(Integer(iRGBArray), SFill); //compiler error E2064 left side cannot be assigned to
end;
for Y := 0 to 3 do
for X := 0 to 255 do
if AHistory[Y, X] > AMaxHistory[Y] then
AMaxHistory[Y] := AHistory[Y, X];
end;
How can I eliminate the compiler error with Win64?
On Win64 a pointer is 64 bits wide and an Integer is 32 bits wide. Such a cast requires both sides of the assignment expression to be the same size. Hence the error.
Instead of casting to Integer cast to PByte.
Inc(PByte(iRGBArray), SFill);
All your other Integer casts are wrong. You have to grasp the different size of these types. You might cast to NativeInt to resolve them.

Number Partition Algorithm Generator in Delphi XE8

How to make efficient and simplest algorithm to output a list of number N Partitions in Delphi XE8?
For example N=4, the result (Lets say listed in a TListBox):
4
3 + 1
2 + 2
2 + 1 + 1
1 + 1 + 1 + 1
I have tried something, decided to use a dynamic array:
var
IntegerArray: array of Integer;
To count the ones, twos, threes,...
And this to type out the dynamic array in a TListBox:
procedure TMForm.AddItem;
var
Temp: String;
I: Integer;
II: Integer;
begin
Temp:= '';
for II:= 0 to Length(IntegerArray)-1 do
begin
for I := 0 to (IntegerArray[(Length(IntegerArray)-II)-1]-1) do
begin
Temp:= Temp+IntToStr(Length(IntegerArray)-II-1);
Temp:= Temp+'+';
end;
end;
delete(Temp,length(Temp),1);
ListBox1.Items.Add(Temp);
end;
And started writing the algorithm (so far works but uses only numbers 1,2 and 3 to write partitions), but it seems I need to rewrite it to use recursion (so it will use all available numbers to write partitions), and that's my question; how to use recursion here?
function TMForm.Calculate(MyInt: Integer): Integer;
var
I: Integer;
begin
ListBox1.Clear;
GlobalInt:= MyInt;
Result:= 0;
SetLength(IntegerArray, 0);
SetLength(IntegerArray, (MyInt+1));
IntegerArray[1]:= MyInt;
AddItem;
Result:= Result+1;
//
if MyInt>1 then
begin
repeat
IntegerArray[1]:= IntegerArray[1]-2;
IntegerArray[2]:= IntegerArray[2]+1;
AddItem;
Result:= Result+1;
until ((IntegerArray[1]/2) < 1 );
if MyInt>2 then
repeat
IntegerArray[3]:= IntegerArray[3]+1;
IntegerArray[1]:= MyInt-IntegerArray[3]*3;
IntegerArray[2]:= 0;
AddItem;
Result:= Result+1;
if NOT ((IntegerArray[1]/2) < 1) then
repeat
IntegerArray[1]:= IntegerArray[1]-2;
IntegerArray[2]:= IntegerArray[2]+1;
AddItem;
Result:= Result+1;
until ((IntegerArray[1]/2) <=1 );
IntegerArray[1]:= MyInt-IntegerArray[3]*3;
IntegerArray[2]:= 0;
until ((IntegerArray[1]/3) < 1 );
//if MyInt>3 then...
end;
Edit1.Text:= IntToStr(Result);
end;
Example of running the current program:
Update
Managed to make it work like this:
procedure TMForm.Calculate(MyInt: Integer);
var
I: Integer;
begin
ListBox1.Clear;
GlobalInt:= MyInt;
ItemCount:= 0;
SetLength(IntegerArray, 0);
SetLength(IntegerArray, (MyInt+1));
IntegerArray[1]:= MyInt;
AddItem;
ItemCount:= ItemCount+1;
//
if MyInt>1 then
Step2;
if MyInt>2 then
for I := 3 to MyInt do
Steps(I);
Edit1.Text:= IntToStr(ItemCount);
end;
procedure TMForm.Steps(n: Integer);
var
I,II: Integer;
begin
if not ((IntegerArray[1]/n) < 1 ) then
repeat
IntegerArray[n]:= IntegerArray[n]+1;
//
IntegerArray[1]:= GlobalInt;
for I:= 3 to GlobalInt do IntegerArray[1]:= IntegerArray[1]-IntegerArray[I]*I;
//
AddItem;
ItemCount:= ItemCount+1;
Step2;
if n>3 then
for II := 3 to (n-1) do
begin
Steps(II);
end;
until ((IntegerArray[1]/n) < 1 );
//
IntegerArray[n]:= 0;
IntegerArray[1]:= GlobalInt;
for I:= 3 to GlobalInt do IntegerArray[1]:= IntegerArray[1]-IntegerArray[I]*I;
end;
procedure TMForm.SpinBox1Change(Sender: TObject);
begin
SpinBox2.Value:= SpinBox1.Value;
end;
procedure TMForm.Step2;
var
I: Integer;
begin
if NOT ((IntegerArray[1]/2) < 1) then
repeat
IntegerArray[1]:= IntegerArray[1]-2;
IntegerArray[2]:= IntegerArray[2]+1;
AddItem;
ItemCount:= ItemCount+1;
until ((IntegerArray[1]/2) < 1 );
IntegerArray[2]:= 0;
IntegerArray[1]:= GlobalInt;
for I:= 3 to GlobalInt do IntegerArray[1]:= IntegerArray[1]-IntegerArray[I]*I;
end;
procedure TMForm.FormCreate(Sender: TObject);
begin
//
end;
But clearly, I need some optimization.
You are right, the simplest implementation is recursive.
There are some possibilities for optimization (for larger values it would be nice to store partitions of smaller values and use them again and again), but I think that for big N values the result list size will be too huge for output
//N is number for partitions, M is maximum part value
//(used here to avoid permutation repeats like 3 1 and 1 3)
procedure Partitions(N, M: integer; s: string);
var
i: integer;
begin
if N = 0 then
Memo1.Lines.Add(s)
else
for i := Min(M, N) downto 1 do
Partitions(N - i, i, s + IntToStr(i) + ' ');
end;
begin
Partitions(7, 7, '');
gives output
7
6 1
5 2
5 1 1
4 3
4 2 1
4 1 1 1
3 3 1
3 2 2
3 2 1 1
3 1 1 1 1
2 2 2 1
2 2 1 1 1
2 1 1 1 1 1
1 1 1 1 1 1 1
From your link there was a reference to: Fast Algorithms for Generating Integer Partitions
.
Implementing the proposed fastest algorithms there (ZS1 and ZS2) looks like this:
(Note, there is no recursion here!)
procedure PartitionsZS1(n: Integer);
var
x: TArray<Integer>;
i,r,h,t,m: Integer;
begin
SetLength(x,n+1);
for i := 1 to n do x[i] := 1;
x[1] := n;
m := 1;
h := 1;
WriteLn(x[1]);
while (x[1] <> 1) do begin
if (x[h] = 2) then begin
m := m + 1;
x[h] := 1;
h := h - 1;
end
else begin
r := x[h] - 1;
t := m - h + 1;
x[h] := r;
while (t >= r) do begin
h := h + 1;
x[h] := r;
t := t - r;
end;
if (t = 0) then
m := h
else begin
m := h + 1;
if (t > 1) then begin
h := h + 1;
x[h] := t;
end;
end;
end;
for i := 1 to m do Write(x[i]);
WriteLn;
end;
end;
procedure PartitionsZS2(n: Integer);
var
x: TArray<Integer>;
i,j,r,h,m: Integer;
begin
SetLength(x,n+1);
for i := 1 to n do x[i] := 1;
for i := 1 to n do Write(x[i]);
WriteLn;
x[0] := -1;
x[1] := 2;
h := 1;
m := n - 1;
for i := 1 to m do Write(x[i]);
WriteLn;
while (x[1] <> n) do begin
if (m-h > 1) then begin
h := h + 1;
x[h] := 2;
m := m - 1;
end
else begin
j := m - 2;
while (x[j] = x[m - 1]) do begin
x[j] := 1;
j := j - 1;
end;
h := j + 1;
x[h] := x[m - 1] + 1;
r := x[m] + x[m - 1]*(m-h-1);
x[m] := 1;
if (m - h) > 1 then
x[m-1] := 1;
m := h + r - 1;
end;
for i := 1 to m do Write(x[i]);
WriteLn;
end;
end;
program Project61;
{$APPTYPE CONSOLE}
begin
PartitionsZS1(7);
WriteLn;
PartitionsZS2(7);
end.
Outputs:
7
61
52
511
43
421
4111
331
322
3211
31111
2221
22111
211111
1111111
1111111
211111
22111
2221
31111
3211
322
331
4111
421
43
511
52
61
7

Delphi - Sorting real numbers in high, low, high, low order

Say I have the data
1,2,3,4,5,6
I want to sort this data so that it outputs
6 1 5 2 4 3
This way, numbers are matched so that low numbers pair with high numbers
Would i use a merge sort to sort it in numerical order, then split the list and match them according to this conditions?
I'm trying to sort real number data in a string grid which is read from a data file; I have a working program that sorts these data in numerical order but I'm not sure how to code it so that it sorts in terms of high,low,high,low
This is the code for my grid sorting
procedure TForm1.SortGrid(Grid: TStringGrid; const SortCol: Integer;
//sorting the string grid
const datatype: Integer; const ascending: boolean);
var
i: Integer;
tempgrid: TStringGrid;
list: array of Integer;
begin
tempgrid := TStringGrid.create(self);
with tempgrid do
begin
rowcount := Grid.rowcount;
ColCount := Grid.ColCount;
fixedrows := Grid.fixedrows;
end;
with Grid do
begin
setlength(list, rowcount - fixedrows);
for i := fixedrows to rowcount - 1 do
begin
list[i - fixedrows] := i;
tempgrid.rows[i].assign(Grid.rows[i]);
end;
Mergesort(Grid, list, SortCol + 1, datatype, ascending);
for i := 0 to rowcount - fixedrows - 1 do
begin
rows[i + fixedrows].assign(tempgrid.rows[list[i]])
end;
row := fixedrows;
end;
tempgrid.free;
setlength(list, 0);
end;
First, sort the numbers in descending order by using any algorithm you want (I used bubble sort in example)
Then, if you have n elements in array:
set a counter going from 1 to (n div 2)
take last element and store it in temporary variable (tmp)
shift all elements by one place to the right, starting from (counter - 1) * 2 + 1. This would overwrite last element, but you have it stored in tmp var
set array[(counter - 1) * 2 + 1] element to tmp
end counter
This way you would effectively take last element from array and insert it at 1, 3, 5... position, until you insert last half of array elements.
Sample code:
procedure Sort(var AArray: array of Double);
var
C1, C2: Integer;
tmp : Double;
pivot : Integer;
begin
for C1 := Low(AArray) to High(AArray) - 1 do
for C2 := C1 + 1 to High(AArray) do
if AArray[C1] < AArray[C2] then
begin
tmp := AArray[C1];
AArray[C1] := AArray[C2];
AArray[C2] := tmp;
end;
pivot := Length(AArray) div 2;
for C1 := 1 to pivot do
begin
tmp := AArray[High(AArray)];
for C2 := High(AArray) downto (C1 - 1) * 2 + 1 do
AArray[C2] := AArray[C2 - 1];
AArray[(C1 - 1) * 2 + 1] := tmp;
end;
end;
From sample data you provided above, I am assuming that the input array is presorted.
[Note that I don't have a compiler at hand, so you'll have to run it and see that it works --minor fiddling might be needed.]
procedure SerratedSort(var AArray: array of Double);
var
Length1: Integer;
Index1: Integer;
Temp1: Double;
begin
Length1 := Length(AArray);
Index1 := 0;
while Index1 < Length1 do begin
Temp1 := AArray[Length1 - 1];
System.Move(AArray[Index1], AArray[Index1 + 1], (Length1 - Index1 + 1) * SizeOf(Double));
AArray[Index1] := Temp1;
Index1 := Index1 + 2;
end;
end;
Here is how it (should) work(s) step-by-step
Input AArray: 123456
Index1: 0
Temp1 := 6
System.Move: 112345
AArray: 612345
Index1: 2
Temp1 := 5
System.Move: 612234
AArray: 615234
Index1: 4
Temp1 := 4
System.Move: 615233
AArray: 615243
Output AArray: 615243
For a record structure, such as, TPerson, it would be like this:
procedure SerratedSort(var A: array of TPerson);
var
s: Integer;
i: Integer;
t: TPerson;
begin
s := Length(A);
i := 0;
while i < s do begin
t := A[s - 1];
System.Move(A[i], A[i + 1], (s - i + 1) * SizeOf(TPerson));
A[i] := t;
i := i + 2;
end;
end;
Sort the data in ascending order. Then pick out the values using the following indices: 0, n-1, 1, n-2, ....
In pseudo code the algorithm looks like this:
Sort;
lo := 0;
hi := n-1;
while lo<=hi do
begin
yield lo;
inc(lo);
if lo>hi then break;
yield hi;
dec(hi);
end;
Example program demonstrating the already above given solutions:
program Project1;
{$APPTYPE CONSOLE}
const
Count = 12;
type
TValues = array[0..Count - 1] of Double;
const
Input: TValues = (1,2,4,9,13,14,15,23,60,100,101,102);
var
I: Integer;
Output: TValues;
procedure ShowValues(Caption: String; Values: TValues);
var
I: Integer;
begin
Write(Caption);
for I := 0 to Count - 2 do
Write(Round(Values[I]), ', ');
WriteLn(Round(Values[Count - 1]));
end;
begin
if Odd(Count) then
WriteLn('Cannot compute an odd number of input values')
else
begin
WriteLn('Program assumes sorted input!');
ShowValues('Input: ', Input);
for I := 0 to (Count div 2) - 1 do
begin
Output[2 * I] := Input[I];
Output[2 * I + 1] := Input[Count - 1 - I];
end;
ShowValues('Output: ', Output);
end;
ReadLn;
end.

Connect 4: Check for winner

In Delphi, I have a Connect 4 board representation (7 columns x 6 lines) in form of an array:
TBoard = Array[1..7, 1..6] of SmallInt;
Board: TBoard; // instance ob TBoard
Each element can have three different states:
1 = player 1's pieces
0 = empty
-1 = player 2's pieces
Now I need a function which checks if there's a winner or a draw:
function CheckForWinner(): SmallInt;
... where 1 is player 1's win, 0 is a draw, -1 is player 2's win and "nil" is for a game which has not ended yet.
My draft is as follows - split into two single functions:
function CheckForWinner(): SmallInt;
var playerToCheck: ShortInt;
s, z: Byte;
draw: Boolean;
begin
draw := TRUE;
for s := 1 to 7 do begin
for z := 1 to 6 do begin
if Board[s, z] = 0 then draw := FALSE; // if there are empty fields then it is no draw
end;
end;
if draw then begin
result := 0;
end
else begin
playerToCheck := Board[lastPieceX, lastPieceY]; // only for last-moving player
if searchRow(playerToCheck, +1, 0, lastPieceX, lastPieceY) then // search right/left
result := playerToCheck
else if searchRow(playerToCheck, 0, +1, lastPieceX, lastPieceY) then // search up/down
result := playerToCheck
else if searchRow(playerToCheck, +1, +1, lastPieceX, lastPieceY) then // search right-down/left-up
result := playerToCheck
else if searchRow(playerToCheck, +1, -1, lastPieceX, lastPieceY) then // search right-up/left-down
result := playerToCheck;
else
result := nil;
end;
end;
end;
function searchRow(player: SmallInt; sChange, zChange: ShortInt; startS, startZ: Byte): Boolean;
var inRow, s, z: SmallInt;
begin
inRow := 0;
s := startS;
z := startZ;
while (Board[s, z] = player) AND (inRow < 4) AND (s >= 1) AND (s <= 7) AND (z >= 1) AND (z <= 6) do begin
s := s+sChange;
z := z+zChange;
inRow := inRow+1;
end;
s := startS-sChange;
z := startZ-zChange;
while (Board[s, z] = player) AND (inRow < 4) AND (s >= 1) AND (s <= 7) AND (z >= 1) AND (z <= 6) do begin
s := s-sChange;
z := z-zChange;
inRow := inRow+1;
end;
if inRow = 4 then
result := TRUE
else
result := FALSE;
end;
What do you think of this approach? Do you have a better (faster / shorter) solution?
Thank you very much!
I didn't read your code. I just elected to write some myself with a blank slate.
Here's my version:
const
RowCount = 6;
ColCount = 7;
type
TState = (stNone, stA, stB);
TBoard = array [1..RowCount] of array [1..ColCount] of TState;
function ValidLocation(Row, Col: Integer): Boolean;
begin
Result := InRange(Row, 1, RowCount) and InRange(Col, 1, ColCount);
end;
procedure Check(
const Board: TBoard;
const StartRow, StartCol: Integer;
const RowDelta, ColDelta: Integer;
out Winner: TState
);
var
Row, Col, Count: Integer;
State: TState;
begin
Winner := stNone;
Row := StartRow;
Col := StartCol;
State := Board[Row, Col];
if State=stNone then
exit;
Count := 0;
while ValidLocation(Row, Col) and (Board[Row, Col]=State) do begin
inc(Count);
if Count=4 then begin
Winner := State;
exit;
end;
inc(Row, RowDelta);
inc(Col, ColDelta);
end;
end;
function Winner(const Board: TBoard): TState;
var
Row, Col: Integer;
begin
for Row := 1 to RowCount do begin
for Col := 1 to ColCount do begin
Check(Board, Row, Col, 0, 1, Result);//check row
if Result<>stNone then
exit;
Check(Board, Row, Col, 1, 0, Result);//check column
if Result<>stNone then
exit;
Check(Board, Row, Col, 1, 1, Result);//check diagonal
if Result<>stNone then
exit;
Check(Board, Row, Col, 1, -1, Result);//check other diagonal
if Result<>stNone then
exit;
end;
end;
Result := stNone;
end;
Big long pile of code. Uses brute force approach, not that performance matters for Connect 4. Don't like the four identical if Result<>stNone then exit; lines, but you can surely think of a cleaner way. Code has not been run. It might not even work!! Just the way my brain attempted to solve the problem.
Checking for a winner in very much the same way as you do, only with a little less code.
I think you wouldn't need to check all fields to determine if the game is done. Just increase a counter when you drop a piece in the game. The game is a draw if the counter reaches 42 and there is no winner yet.
function CheckRow(x, y, xd, yd: Integer): Boolean;
var
c: Integer;
function RowLength(x, y, xd, yd: Integer): Integer;
begin
Result := 0;
repeat
Inc(Result);
Inc(x, xd);
Inc(y, yd);
until not ((x in [1..7]) and (y in [1..6]) and (Board[x, y] = c));
end;
begin
c := Board[x, y];
Result := 4 <= RowLength(x, y, xd, yd) + RowLength(x, y, xd*-1, yd*-1) - 1;
end;
function CheckForWinner(x, y: Integer): Integer;
begin
Result := 0;
if CheckRow(x, y, 0, 1) or CheckRow(x, y, 1, 1) or
CheckRow(x, y, 1, 0) or CheckRow(x, y, 1, -1) then
Result := Board[x,y];
end;
Disclaimer: I haven't studied the algorithm in detail. The comments below are merely my first reactions after staring at the code for less than ten seconds.
I have some very quick remarks. First, I think
TCellState = (csUnoccupied, csPlayerA, csPlayerB)
TBoard = Array[1..7, 1..6] of TCellState;
is nicer. Of course, you can save compatibility with your old code by doing
TCellState = (csUnoccupied = 0, csPlayerA = 1, csPlayerB = -1)
Second,
draw := true;
for s := 1 to 7 do begin
for z := 1 to 6 do begin
if Board[s, z] = 0 then draw := false;
end;
end;
You don't need the begin and end parts:
draw := TRUE;
for s := 1 to 7 do
for z := 1 to 6 do
if Board[s, z] = 0 then
draw := false;
More importantly, as a gain in performance, you should break the loops as soon as you have set drawn to false:
draw := true;
for s := 1 to 7 do
for z := 1 to 6 do
if Board[s, z] = 0 then
begin
draw := false;
break;
end;
This will, however, only break the z loop. To break both loops, the nicest way is to put the entire block above in a local function. Let's call it CheckDraw:
function CheckDraw: boolean;
begin
result := true;
for s := 1 to 7 do
for z := 1 to 6 do
if Board[s, z] = 0 then
Exit(false);
end;
Alternatively, you can use label and goto to break out of both loops at once.
Update
I see now that you can just do
for s := 1 to 7 do
for z := 1 to 6 do
if Board[s, z] = 0 then
Exit(0);
and you don't even need to introduce the draw local variable!
End update
Furthermore,
if inRow = 4 then
result := TRUE
else
result := FALSE;
is bad. You should do just
result := inRow = 4;
Finally, In my taste
s := s+sChange;
should be written
inc(s, sChange);
and
inRow := inRow+1
should be
inc(inRow);
Oh, and nil is a pointer, not an integer.
The source code from the Fhourstones Benchmark from John Tromp uses a fascinating algorithm for testing a connect four game for a win. The algorithm uses following bitboard representation of the game:
. . . . . . . TOP
5 12 19 26 33 40 47
4 11 18 25 32 39 46
3 10 17 24 31 38 45
2 9 16 23 30 37 44
1 8 15 22 29 36 43
0 7 14 21 28 35 42 BOTTOM
There is one bitboard for the red player and one for the yellow player. 0 represents a empty cell, 1 represents a filled cell. The bitboard is stored in an unsigned 64 bit integer variable. The bits 6, 13, 20, 27, 34, 41, >= 48 have to be 0.
The algorithm is:
// return whether 'board' includes a win
bool haswon(unsigned __int64 board)
{
unsigned __int64 y = board & (board >> 6);
if (y & (y >> 2 * 6)) // check \ diagonal
return true;
y = board & (board >> 7);
if (y & (y >> 2 * 7)) // check horizontal
return true;
y = board & (board >> 8);
if (y & (y >> 2 * 8)) // check / diagonal
return true;
y = board & (board >> 1);
if (y & (y >> 2)) // check vertical
return true;
return false;
}
You have to call the function for the bitboard of the player who did the last move

Resources