From Lenze manual
Code number (C1, C2)
Standard addressing
The meaning of the code numbers and the assigned parameters can be obtained from
the code table (see chapter 8.2). When transmitting data, the code number are
coded as follows:
The following calculation determines the two ASCII digits from the code number
(value range: 0..6229) (value range: 48dec 127dec):
C1 = INTEGER((REMAINDER(code number/790))/10) + 48dec
C2 = REMAINDER(REMAINDER(code number/790)/10) +
INTEGER(code number/790) x 10 + 48dec
Procedure for calculating C1 and C2 from codenumber.
procedure pCodeNumberToC1C2(CodeNumber: Word; var C1, C2: Byte);
begin
C1 := Byte((CodeNumber mod 790) div 10) + 48;
C2 := ((CodeNumber mod 790) mod 10) + 48 + 10 * Byte(CodeNumber div 790);
end;
But, how to calculate it the other way without the aweful:
function fC1C2ToCodeNumber(iC1, iC2: Byte): Word;
var
C1, C2: Byte;
i: Integer;
Begin
Result := 0;
For i := 0 to 6229 Do Begin
pCodeNumberToC1C2(i, C1, C2);
if (C1 = iC1) and (C2 = iC2) Then Result := i;
End;
Result := cn;
End;
Let's
N = p * 790 + q
then
c1 = 48 + q div 10
c2 = 48 + q mod 10 + 10 * p
so
p = (c2-48) div 10
q = (c2-48) mod 10 + (c1-48) * 10
test:
var
c1, c2: Byte;
n, p, q, t: Word;
begin
for t := 0 to 6229 do begin
n := t;
pCodeNumberToC1C2(n, c1, c2);
p := (c2-48) div 10;
q := (c2-48) mod 10 + (c1-48) * 10;
n := 790*p+q;
if n <> t then
Memo1.Lines.Add('Failed at ' + IntToStr(t))
end;
Final:
function C1C2ToCodeNumber(C1, C2: Byte): Word;
begin
Result := ((C2 - 48) div 10) * 790 + ((C2 - 48) mod 10 + (C1 - 48) * 10);
end;
As an alternative to arithmetic you could consider a lookup table. At the cost of memory, this gives you better performance. The code looks like this:
const
CodeNumberTable: array [48..126, 48..127] of Word = (
.... code removed because of Sack Overflow post size limitation
);
const
MinC1 = low(CodeNumberTable);
MinC2 = high(CodeNumberTable);
MaxC1 = low(CodeNumberTable[MinC1]);
MaxC2 = high(CodeNumberTable[MinC1]);
type
EInvalidParameters = class(Exception);
function fC1C2ToCodeNumber(iC1, iC2: Byte): Word;
begin
if not InRange(iC1, MinC1, MaxC1) then
raise EInvalidParameters.CreateFmt(
'iC1 (%d) must be in the range %d to %d',
[iC1, MinC1, MaxC1]
);
if not InRange(iC2, MinC2, MaxC2) then
raise EInvalidParameters.CreateFmt(
'iC2 (%d) must be in the range %d to %d',
[iC2, MinC2, MaxC2]
);
Result := CodeNumberTable[iC1, iC2];
if Result=high(Word) then
raise EInvalidParameters.CreateFmt(
'CodeNumber not defined for iC1=%d, ic2=%d',
[iC1, iC2]
);
end;
I can supply the table via paste bin if you are interested.
Related
In Delphi one can calculate Skewness using System.Math's function MomentSkewKurtosis().
var m1, m2, m3, m4, skew, k: Extended;
System.Math.MomentSkewKurtosis([1.1,
3.345,
12.234,
11.945,
14.235,
16.876,
20.213,
11.001,
7.098,
21.234], m1, m2, m3, m4, skew, k);
This will prints skew equal to -0.200371489809269.
Minitab prints the value -0.24
SigmaXL prints the value -0.23611
The reason is that Delphi does not not perform adjustment.
Here is my implementation which calculates adjustment:
function Skewness(const X: array of Extended; const Adjusted: Boolean): Extended;
begin
var AMean := Mean(X);
var xi_minus_mean_power_3 := 0.0;
var xi_minus_mean_power_2 := 0.0;
for var i := Low(X) to High(X) do
begin
xi_minus_mean_power_3 := xi_minus_mean_power_3 + IntPower((X[i] - AMean), 3);
xi_minus_mean_power_2 := xi_minus_mean_power_2 + IntPower((X[i] - AMean), 2);
end;
// URL : https://www.gnu.org/software/octave/doc/v4.0.1/Descriptive-Statistics.html
{ mean ((x - mean (x)).^3)
skewness (X) = ------------------------.
std (x).^3
}
var N := Length(X);
Result := xi_minus_mean_power_3 / N /
IntPower(Sqrt(1 / N * xi_minus_mean_power_2), 3);
// URL : https://www.gnu.org/software/octave/doc/v4.0.1/Descriptive-Statistics.html
{ sqrt (N*(N-1)) mean ((x - mean (x)).^3)
skewness (X, 0) = -------------- * ------------------------.
(N - 2) std (x).^3
}
if Adjusted then
Result := Result * Sqrt(N * Pred(N)) / (N - 2);
end;
The helper routine IntPower is as follows:
function IntPower(const X: Extended; const N: Integer): Extended;
/// <remarks>
/// Calculate any float to non-negative integer power. Developed by Rory Daulton and used with permission. Last modified December 1998.
/// </remarks>
function IntPow(const Base: Extended; const Exponent: LongWord): Extended;
{ Heart of Rory Daulton's IntPower: assumes valid parameters &
non-negative exponent }
{$IFDEF WIN32}
asm
fld1 // Result := 1
cmp eax, 0 // eax := Exponent
jz ##3
fld Base
jmp ##2
##1: fmul ST, ST // X := Base * Base
##2: shr eax,1
jnc ##1
fmul ST(1),ST // Result := Result * X
jnz ##1
fstp st // pop X from FPU stack
##3:
fwait
end;
{$ENDIF}
{$IFDEF WIN64}
begin
Result := Power(Base, Exponent);
end;
{$ENDIF}
begin
if N = 0 then
Result := 1
else if (X = 0) then
begin
if N < 0 then
raise EMathError.Create('Zero cannot be raised to a negative power.')
else
Result := 0
end
else if (X = 1) then
Result := 1
else if X = -1 then
begin
if Odd (N) then
Result := -1
else
Result := 1
end
else if N > 0 then
Result := IntPow (X, N)
else
begin
var P: LongWord;
if N <> Low (LongInt) then
P := Abs(N)
else
P := LongWord(High(LongInt)) + 1;
try
Result := IntPow(X, P);
except
on EMathError do
begin
Result := IntPow(1 / X, P); // try again with another method, perhaps less precise
Exit;
end;
end;
Result := 1 / Result;
end;
end;
With that function the adjusted skewness becomes the accurate -0.237611357234441 matching Matlab and Minitab.
The only explanation I found is:
https://octave.org/doc/v4.0.1/Descriptive-Statistics.html
"The adjusted skewness coefficient is obtained by replacing the sample
second and third central moments by their bias-corrected versions."
Same goes with Kurtosis:
function Kurtosis(const X: array of Extended; const Adjusted: Boolean): Extended;
begin
var AMean := Mean(X);
var xi_minus_mean_power_4 := 0.0;
var xi_minus_mean_power_2 := 0.0;
for var i := Low(X) to High(X) do
begin
xi_minus_mean_power_4 := xi_minus_mean_power_4 + IntPower((X[i] - AMean), 4);
xi_minus_mean_power_2 := xi_minus_mean_power_2 + IntPower((X[i] - AMean), 2);
end;
{ mean ((x - mean (x)).^4)
k1 = ------------------------
std (x).^4
}
var N := Length(X);
Result := xi_minus_mean_power_4 / N /
IntPower(1 / N * xi_minus_mean_power_2, 2);
{ N - 1
k0 = 3 + -------------- * ((N + 1) * k1 - 3 * (N - 1))
(N - 2)(N - 3)
}
if Adjusted then
// Mathlab, Minitab and SigmaXL do not add 3 (which is the kurtosis for normal distribution
Result := {3 + }(N - 1) / ((N - 2) * (N - 3)) * ((N + 1) * Result - 3 * (N - 1));
end;
What is the reason for such adjustments and why Delphi decided not to implement it?
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;
I have been looking for usable and full code for chi-square distribution in Delphi. There are some codes via net, but usually they don't work or have missing parts, do not compile etc.. There are also some libraries, but I'm interested about some code that I just can simply implement.
I've found something almost working. Some german parts have been fixed, it compiles and it gives p-values for most of the data:
function LnGamma (x : Real) : Real;
const
a0 = 0.083333333096;
a1 = -0.002777655457;
a2 = 0.000777830670;
c = 0.918938533205;
var
r : Real;
begin
r := (a0 + (a1 + a2 / sqr(x)) / sqr(x)) / x;
LnGamma := (x - 0.5) * ln(x) - x + c + r;
end;
function LnFak (x : Real) : Real;
var
z : Real;
begin
z := x+1;
LnFak := LnGamma(z);
end;
function Reihe (chi : Real; f : Real) : Real;
const MaxError = 0.0001;
var
Bruch,
Summe,
Summand : Real;
k, i : longint;
begin
Summe := 1;
k := 1;
repeat
Bruch := 1;
for i := 1 to k do
Bruch := Bruch * (f + 2 * i);
Summand := power(chi, 2 * k) / Bruch;
Summe := Summe + Summand;
k := succ(k);
until (Summand < MaxError);
Reihe := Summe;
end;
function IntegralChi (chisqr : Real; f : longint) : Real;
var
s : Real;
begin
S := power((0.5 * chisqr), f/2) * Reihe(sqrt(chisqr), f)
* exp((-chisqr/2) - LnGamma((f + 2) / 2));
IntegralChi := 1 - s;
end;
It works quite good for relatively big results.
For example:
For Chi = 1.142132 and df = 1 I'm getting p about 0.285202, which is perfect. Same as SPSS result or other programs.
But for example Chi = 138.609137 and df = 4 I should recieive something about 0.000000, but I'm getting floating point overflow error in Reiche function. Summe and Summand are very big then.
I admit that understanding distribution function is not my strong point, so maybe someone will tell me what I did wrong?
Thank you very much for the information
You should debug your program and find that there is an overflow
in your loop for k=149. For k=148 the value of Bruch is 3.3976725289e+304. The next computation of Bruch overflows. A fix is to code
for i := 1 to k do
Bruch := Bruch / (f + 2 * i);
Summand := power(chi, 2 * k) * Bruch;
With this change you get the value IntegralChi(138.609137,4) = 1.76835197E-7 after 156th iteration.
Note that your computation (even for this simple algorithm) is sub-optimal
because you compute the Bruch value over and over again. Just update it once
per loop:
function Reihe (chi : Real; f : Real) : Real;
const MaxError = 0.0001;
var
Bruch,
Summe,
Summand : Real;
k : longint;
begin
Summe := 1;
k := 1;
Bruch := 1;
repeat
Bruch := Bruch / (f + 2 * k);
Summand := power(chi, 2 * k) * Bruch;
Summe := Summe + Summand;
k := succ(k);
until (Summand < MaxError);
Reihe := Summe;
end;
Similar consideration should be applied to compute power(chi, 2*k) and then combine this with the improved evaluation of Bruch.
Edit: As a response to your comment, here the improved version based on the property of the power function, that is power(chi, 2*(k+1)) = power(chi, 2*k)*sqr(chi)
function Reihe (chi : Real; f : Real) : Real;
const MaxError = 0.0001;
var
chi2,
Summe,
Summand : Real;
k : longint;
begin
Summe := 1;
k := 1;
Summand := 1;
chi2 := sqr(chi);
repeat
Summand := Summand * chi2 / (f + 2 * k);
Summe := Summe + Summand;
k := succ(k);
until (Summand < MaxError);
Reihe := Summe;
end;
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.
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