How do I determine which value occurs the most after I filled the array with 100 random values which are between 1 and 11?
Here is a sample code:
procedure TForm1.Button1Click(Sender: TObject);
function Calculate: Integer;
var
Numbers: array [1..100] of Byte;
Counts: array [1..11] of Byte;
I: Byte;
begin
// Fill the array with random numbers
for I := Low(Numbers) to High(Numbers) do
Numbers[I] := Random(11) + 1;
// Count the occurencies
ZeroMemory(#Counts, SizeOf(Counts));
for I := Low(Numbers) to High(Numbers) do
Inc(Counts[Numbers[I]]);
// Identify the maximum
Result := Low(Counts);
for I := Low(Counts) + 1 to High(Counts) do
if Counts[I] > Counts[Result] then
Result := I;
end;
begin
ShowMessage(Calculate.ToString);
end;
It is a simple question [...]
Yes
but I can't seem to find any straight answers online.
You shouldn't be searching for solutions on-line; instead, you should start to think about how to design an algorithm able to solve the problem. For this, you may need pen and paper.
First, we need some data to work with:
const
ListLength = 100;
MinValue = 1;
MaxValue = 11;
function MakeRandomList: TArray<Integer>;
begin
SetLength(Result, ListLength);
for var i := 0 to High(Result) do
Result[i] := MinValue + Random(MaxValue - MinValue + 1);
end;
The MakeRandomList function creates a dynamic array of integers. The array contains ListLength = 100 integers ranging from MinValue = 1 to MaxValue = 11, as desired.
Now, given such a list of integers,
var L := MakeRandomList;
how do we find the most frequent value?
Well, if we were to solve this problem without a computer, using only pen and paper, we would probably count the number of times each distinct value (1, 2, ..., 11) occurs in the list, no?
Then we would only need to find the value with the greatest frequency.
For instance, given the data
2, 5, 1, 10, 1, 5, 2, 7, 8, 5
we would count to find the frequencies
X Freq
2 2
5 3
1 2
10 1
7 1
8 1
Then we read the table from the top line to the bottom line to find the row with the greatest frequency, constantly keeping track of the current winner.
Now that we know how to solve the problem, it is trivial to write a piece of code that performs this algorithm:
procedure FindMostFrequentValue(const AList: TArray<Integer>);
type
TValueAndFreq = record
Value: Integer;
Freq: Integer;
end;
var
Frequencies: TArray<TValueAndFreq>;
begin
if Length(AList) = 0 then
raise Exception.Create('List is empty.');
SetLength(Frequencies, MaxValue - MinValue + 1);
// Step 0: Label the frequency list items
for var i := 0 to High(Frequencies) do
Frequencies[i].Value := i + MinValue;
// Step 1: Obtain the frequencies
for var i := 0 to High(AList) do
begin
if not InRange(AList[i], MinValue, MaxValue) then
raise Exception.CreateFmt('Value out of range: %d', [AList[i]]);
Inc(Frequencies[AList[i] - MinValue].Freq);
end;
// Step 2: Find the winner
var Winner: TValueAndFreq;
Winner.Value := 0;
Winner.Freq := 0;
for var i := 0 to High(Frequencies) do
if Frequencies[i].Freq > Winner.Freq then
Winner := Frequencies[i];
ShowMessageFmt('The most frequent value is %d with a count of %d.',
[Winner.Value, Winner.Freq]);
end;
Delphi has a TDictionary class, which you can use to implement a frequency map, eg:
uses
..., System.Generics.Collections;
function MostFrequent(Arr: array of Integer) : Integer;
var
Frequencies: TDictionary<Integer, Integer>;
I, Freq, MaxFreq: Integer;
Elem: TPair<Integer, Integer>;
begin
Frequencies := TDictionary<Integer, Integer>.Create;
// Fill the dictionary with numbers
for I := Low(Arr) to High(Arr) do begin
if not Frequencies.TryGetValue(Arr[I], Freq) then Freq := 0;
Frequencies.AddOrSetValue(Arr[I], Freq + 1);
end;
// Identify the maximum
Result := 0;
MaxFreq := 0;
for Elem in Frequencies do begin
if Elem.Value > MaxFreq then begin
MaxFreq := Elem.Value;
Result := Elem.Key;
end;
end;
Frequencies.Free;
end;
var
Numbers: array [1..100] of Integer;
I: Integer;
begin
// Fill the array with random numbers
for I := Low(Numbers) to High(Numbers) do
Numbers[I] := Random(11) + 1;
// Identify the maximum
ShowMessage(IntToStr(MostFrequent(Numbers)));
end;
I am also still learning and therefore feel that the way I approached this problem might be a little closer to the way would have done:
procedure TForm1.GetMostOccuring;
var
arrNumbers : array[1..100] of Integer;
iNumberWithMost : Integer;
iNewAmount, iMostAmount : Integer;
I, J : Integer;
begin
for I := 1 to 100 do
arrNumbers[I] := Random(10) + 1;
iMostAmount := 0;
for I := 1 to 10 do
begin
iNewAmount := 0;
for J := 1 to 100 do
if I = arrNumbers[J] then
inc(iNewAmount);
if iNewAmount > iMostAmount then
begin
iMostAmount := iNewAmount;
iNumberWithMost := I;
end;
end;
ShowMessage(IntToStr(iNumberWithMost));
end;
I hope this is not completely useless.
It is just a simple answer to a simple question.
I am building a stringlist from an ADO query, in the query it is much faster to return sorted results and then add them in order. this gives me an already sorted list and then calling either Sort or setting sorted true costs me time as the Quicksort algorithm does not preform well on an already sorted list. Is there some way to set the TStringList to use the Binary search without running the sort?
before you ask I don't have access to the CustomSort attribute.
I am not sure I understand what you are worried about, assuming the desired sort order of the StringList is the same as the ORDER BY of the AdoQuery.
Surely the thing to do is to set Sorted on your StringList to True while it is still empty and then insert the rows from the AdoQuery. That way, when the StringList is about to Add an entry, it will search for it using IndexOf, which will in turn use Find, which does a binary search, to check for duplicates. But using Add in this way does not involve a quicksort because the StringList is already treating itself as sorted.
In view of your comments and your own answer I ran the program below through the Line Timer profiler in NexusDB's Quality Suite. The result is that although there are detectable differences in execution speed using a binary search versus TStringList.IndexOf, they are nothing to do with the use (or not) of TStringList's QuickSort. Further, the difference is explicable by a subtle difference between how the binary search I used and the one in TStringList.Find work - see Update #2 below.
The program generates 200k 100-character strings and then inserts them into a StringList. The StringList is generated in two ways, first with Sorted set to True before any strings are added and then with Sorted set to True only after the strings have been added. StringList.IndexOf and your BinSearch is then used to look up each of the strings which has been added. The results are as follows:
Line Total Time Source
80 procedure Test;
119 0.000549 begin
120 2922.105618 StringList := GetList(True);
121 2877.101652 TestIndexOf;
122 1062.461975 TestBinSearch;
123 29.299069 StringList.Free;
124
125 2970.756283 StringList := GetList(False);
126 2943.510851 TestIndexOf;
127 1044.146265 TestBinSearch;
128 31.440766 StringList.Free;
129 end;
130
131 begin
132 Test;
133 end.
The problem I encountered is that your BinSearch never actually returns 1 and the number of failures is equal to the number of strings searched for. If you can fix this, I'll be happy to re-do the test.
program SortedStringList2;
[...]
const
Rows = 200000;
StrLen = 100;
function ZeroPad(Number : Integer; Len : Integer) : String;
begin
Result := IntToStr(Number);
if Length(Result) < Len then
Result := StringOfChar('0', Len - Length(Result)) + Result;
end;
function GetList(SortWhenEmpty : Boolean) : TStringList;
var
i : Integer;
begin
Result := TStringList.Create;
if SortWhenEmpty then
Result.Sorted := True;
for i := 1 to Rows do
Result.Add(ZeroPad(i, StrLen));
if not SortWhenEmpty then
Result.Sorted := True;
end;
Function BinSearch(slList: TStringList; sToFind : String) : integer;
var
i, j, k : integer;
begin
try
i := slList.Count div 2;
k := i;
if i = 0 then
begin
Result := -1;
// SpendLog('BinSearch List Empty, Exiting...');
exit;
end;
while slList.Strings[i] <> sToFind do
begin
if CompareText(slList.Strings[i], sToFind) < 0 then
begin
j := i;
k := k div 2;
i := i + k;
if j=i then
break;
end else
if CompareText(slList.Strings[i], sToFind) > 0 then
begin
j := i;
k := k div 2;
i := i - k;
if j=i then
break;
end else
break;
end;
if slList.Strings[i] = sToFind then
result := i
else
Result := -1;
except
//SpendLog('<BinSearch> Exception: ' + ExceptionMessage + ' At Line: ' + Analysis.LastSourcePos);
end;
end;
procedure Test;
var
i : Integer;
StringList : TStringList;
procedure TestIndexOf;
var
i : Integer;
Index : Integer;
Failures : Integer;
S : String;
begin
Failures := 0;
for i := 1 to Rows do begin
S := ZeroPad(i, StrLen);
Index := StringList.IndexOf(S);
if Index < 0 then
Inc(Failures);
end;
Assert(Failures = 0);
end;
procedure TestBinSearch;
var
i : Integer;
Index : Integer;
Failures : Integer;
S : String;
begin
Failures := 0;
for i := 1 to Rows do begin
S := ZeroPad(i, StrLen);
Index := BinSearch(StringList, S);
if Index < 0 then
Inc(Failures);
end;
//Assert(Failures = 0);
end;
begin
StringList := GetList(True);
TestIndexOf;
TestBinSearch;
StringList.Free;
StringList := GetList(False);
TestIndexOf;
TestBinSearch;
StringList.Free;
end;
begin
Test;
end.
Update I wrote my own implementation of the search algorithm in the Wikipedia article https://en.wikipedia.org/wiki/Binary_search_algorithm as follows:
function BinSearch(slList: TStringList; sToFind : String) : integer;
var
L, R, m : integer;
begin
L := 0;
R := slList.Count - 1;
if R < L then begin
Result := -1;
exit;
end;
m := (L + R) div 2;
while slList.Strings[m] <> sToFind do begin
m := (L + R) div 2;
if CompareText(slList.Strings[m], sToFind) < 0 then
L := m + 1
else
if CompareText(slList.Strings[m], sToFind) > 0 then
R := m - 1;
if L > R then
break;
end;
if slList.Strings[m] = sToFind then
Result := m
else
Result := -1;
end;
This seems to work correctly, and re-profiling the test app using this gave these results:
Line Total Time Source
113 procedure Test;
153 0.000490 begin
154 3020.588894 StringList := GetList(True);
155 2892.860499 TestIndexOf;
156 1143.722379 TestBinSearch;
157 29.612898 StringList.Free;
158
159 2991.241659 StringList := GetList(False);
160 2934.778847 TestIndexOf;
161 1113.911083 TestBinSearch;
162 30.069241 StringList.Free;
On that showing, a binary search clearly outperforms TStringList.IndexOf and contrary to my expectations it makes no real difference whether TStringList.Sorted is set to True before or after the strings are added.
Update#2 it turns out that the reason BinSearch is faster than TStringList.IndexOf is purely because BinSearch uses CompareText whereas TStringList.IndexOf uses AnsiCompareText (via .Find). If I change BinSearch to use AnsiCompareText, it becomes 1.6 times slower than TStringList.IndexOf!
I was about to suggest using an interposer class to directly change the FSorted field without calling its setter method which as a side effect calls the Sort method. But looking at the implementation of TStringList in Delphi 2007, I found that Find will always do a binary search without checking the Sorted property. This will, of course fail, if the list items aren't sorted, but in your case they are. So, as long as you remember to call Find rather than IndexOf, you don't need to do anything.
in the end I just hacked up a binary search to check the stringlist like an array:
Function BinSearch(slList: TStringList; sToFind : String) : integer;
var
i, j, k : integer;
begin
try
try
i := slList.Count div 2;
k := i;
if i = 0 then
begin
Result := -1;
SpendLog('BinSearch List Empty, Exiting...');
exit;
end;
while slList.Strings[i] <> sToFind do
begin
if CompareText(slList.Strings[i], sToFind) < 0 then
begin
j := i;
k := k div 2;
i := i + k;
if j=i then
break;
end else
if CompareText(slList.Strings[i], sToFind) > 0 then
begin
j := i;
k := k div 2;
i := i - k;
if j=i then
break;
end else
break;
end;
if slList.Strings[i] = sToFind then
result := i
else
Result := -1;
except
SpendLog('<BinSearch> Exception: ' + ExceptionMessage + ' At Line: ' + Analysis.LastSourcePos);
end;
finally
end;
end;
I'll clean this up later if needed.
I have a BIG problem here and do not even know how to start...
In short explanation, I need to know if a number is in a set of results from a random combination...
Let me explain better: I created a random "number" with 3 integer chars from 1 to 8, like this:
procedure TForm1.btn1Click(Sender: TObject);
var
cTmp: Char;
sTmp: String[3];
begin
sTmp := '';
While (Length(sTmp) < 3) Do
Begin
Randomize;
cTmp := IntToStr(Random(7) + 1)[1];
If (Pos(cTmp, sTmp) = 0) Then
sTmp := sTmp + cTmp;
end;
edt1.Text := sTmp;
end;
Now I need to know is some other random number, let's say "324" (example), is in the set of results of that random combination.
Please, someone can help? A link to get the equations to solve this problem will be enough...
Ok, let me try to add some useful information:
Please, first check this link https://en.wikipedia.org/wiki/Combination
Once I get some number typed by user, in an editbox, I need to check if it is in the set of this random combination: S = (1..8) and k = 3
Tricky, hum?
Here is what I got. Maybe it be usefull for someone in the future. Thank you for all people that tried to help!
Function IsNumOnSet(const Min, Max, Num: Integer): Boolean;
var
X, Y, Z: Integer;
Begin
Result := False;
For X := Min to Max Do
For Y := Min to Max Do
For Z := Min to Max Do
If (X <> Y) and (X <> Z) and (Y <> Z) Then
If (X * 100 + Y * 10 + Z = Num) Then
Begin
Result := True;
Exit;
end;
end;
You want to test whether something is a combination. To do this you need to verify that the putative combination satisfies the following conditions:
Each element is in the range 1..N and
No element appears more than once.
So, implement it like this.
Declare an array of counts, say array [1..N] of Integer. If N varies at runtime you will need a dynamic array.
Initialise all members of the array to zero.
Loop through each element of the putative combination. Check that the element is in the range 1..N. And increment the count for that element.
If any element has a count greater than 1 then this is not a valid combination.
Now you can simplify by replacing the array of integers with an array of booleans but that should be self evident.
You have your generator. Once your value is built, do something like
function isValidCode( Digits : Array of Char; Value : String ) : Boolean;
var
nI : Integer;
begin
for nI := 0 to High(Digits) do
begin
result := Pos(Digits[nI], Value ) > 0;
if not result then break;
end;
end;
Call like this...
isValidCode(["3","2","4"], RandomValue);
Note : it works only because you have unique digits, the digit 3 is only once in you final number. For something more generic, you'll have to tweak this function. (testing "3","3","2" would return true but it would be false !)
UPDATED :
I dislike the nested loop ^^. Here is a function that return the nTh digit of an integer. It will return -1 if the digits do not exists. :
function TForm1.getDigits(value : integer; ndigits : Integer ) : Integer;
var
base : Integer;
begin
base := Round(IntPower( 10, ndigits-1 ));
result := Trunc( value / BASE ) mod 10;
end;
nDigits is the digits number from right to left starting at 1. It will return the value of the digit.
GetDigits( 234, 1) returns 4
GetDigits( 234, 2) returns 3
GetDigits( 234, 3) returns 2.
GetDigits( 234, 4) returns 0.
Now this last function checks if a value is a good combination, specifying the maxdigits you're looking for :
function isValidCombination( value : integer; MinVal, MaxVal : Integer; MaxDigits : Integer ) : Boolean;
var
Buff : Array[0..9] of Integer;
nI, digit: Integer;
begin
ZeroMemory( #Buff, 10*4);
// Store the count of digits for
for nI := 1 to MaxDigits do
begin
digit := getDigits(value, nI);
Buff[digit] := Buff[digit] + 1;
end;
// Check if the value is more than the number of digits.
if Value >= Round(IntPower( 10, MaxDigits )) then
begin
result := False;
exit;
end;
// Check if the value has less than MaxDigits.
if Value < Round(IntPower( 10, MaxDigits-1 )) then
begin
result := False;
exit;
end;
result := true;
for nI := 0 to 9 do
begin
// Exit if more than One occurence of digit.
result := Buff[nI] < 2 ;
if not result then break;
// Check if digit is present and valid.
result := (Buff[nI] = 0) or InRange( nI, MinVal, MaxVal );
if not result then break;
end;
end;
Question does not seem too vague to me,
Maybe a bit poorly stated.
From what I understand you want to check if a string is in a set of randomly generated characters.
Here is how that would work fastest, keep a sorted array of all letters and how many times you have each letter.
Subtract each letter from the target string
If any value in the sorted int array goes under 0 then that means the string can not be made from those characters.
I made it just work with case insensitive strings but it can easily be made to work with any string by making the alphabet array 255 characters long and not starting from A.
This will not allow you to use characters twice like the other example
so 'boom' is not in 'b' 'o' 'm'
Hope this helps you.
function TForm1.isWordInArray(word: string; arr: array of Char):Boolean;
var
alphabetCount: array[0..25] of Integer;
i, baseval, position : Integer;
s: String;
c: Char;
begin
for i := 0 to 25 do alphabetCount[i] := 0; // init alphabet
s := UpperCase(word); // make string uppercase
baseval := Ord('A'); // count A as the 0th letter
for i := 0 to Length(arr)-1 do begin // disect array and build alhabet
c := UpCase(arr[i]); // get current letter
inc(alphabetCount[(Ord(c)-baseval)]); // add 1 to the letter count for that letter
end;
for i := 1 to Length(s) do begin // disect string
c := s[i]; // get current letter
position := (Ord(c)-baseval);
if(alphabetCount[position]>0) then // if there is still latters of that kind left
dec(alphabetCount[position]) // delete 1 to the letter count for that letter
else begin // letternot there!, exit with a negative result
Result := False;
Exit;
end;
end;
Result := True; // all tests where passed, the string is in the array
end;
implemented like so:
if isWordInArray('Delphi',['d','l','e','P','i','h']) then Caption := 'Yup' else Caption := 'Nope'; //yup
if isWordInArray('boom',['b','o','m']) then Caption := 'Yup' else Caption := 'Nope'; //nope, a char can only be used once
Delphi rocks!
begin
Randomize; //only need to execute this once.
sTmp := '';
While (Length(sTmp) < 3) Do
Begin
cTmp := IntToStr(Random(7) + 1)[1]; // RANDOM(7) produces # from 0..6
// so result will be '1'..'7', not '8'
// Alternative: clmp := chr(48 + random(8));
If (Pos(cTmp, sTmp) = 0) Then
sTmp := sTmp + cTmp;
IF SLMP = '324' THEN
DOSOMETHING; // don't know what you actually want to do
// Perhaps SET SLMP=''; to make sure '324'
// isn't generated?
end;
edt1.Text := sTmp;
end;
I need input sequence of Integer number and find the longest arithmetic and geometric progression sequence. I had wrote this code( I must use Delphi 7)
program arithmeticAndGeometricProgression;
{ 203. In specifeied sequence of integer numbers find the longest sequence, which is
arithmetic or geometric progression. }
{$APPTYPE CONSOLE}
uses
SysUtils;
var
sequence, longArithmSequ, longGeomSequ: Array of Integer;
curArithmSequ, curGeomSequ: Array of Integer; // Current progress
q, q1: Double;
d1, d: Double;
i, k: Integer;
begin
i := 0;
d := 0;
k := 0;
d1 := 0;
Repeat
SetLength(sequence, i + 1);
// Make room for another item in the array
try
read(sequence[i]);
except // If the input character is not an integer interrupt cycle
Break;
end;
inc(i);
Until False;
k := 0;
curArithmSequ := NIL;
curGeomSequ := NIL;
longArithmSequ := NIL;
longGeomSequ := NIL;
d1 := sequence[1] - sequence[0];
q1 := sequence[1] / sequence[0];
i := 1;
repeat
d := d1;
q := q1;
d1 := sequence[i] - sequence[i - 1];
q1 := sequence[i] / sequence[i - 1];
if d = d1 then
begin
SetLength(curArithmSequ, Length(curArithmSequ) + 1);
curArithmSequ[Length(curArithmSequ) - 1] := sequence[i];
end;
if q = q1 then
begin
SetLength(curGeomSequ, Length(curGeomSequ) + 1);
curGeomSequ[Length(curGeomSequ) - 1] := sequence[i];
end;
if Length(curArithmSequ) > Length(longArithmSequ) then
begin
longArithmSequ := NIL;
SetLength(longArithmSequ, Length(curArithmSequ));
for k := 0 to Length(curArithmSequ) - 1 do
longArithmSequ[k] := curArithmSequ[k];
end;
if Length(curGeomSequ) > Length(longGeomSequ) then
begin
longGeomSequ := NIL;
SetLength(longGeomSequ, Length(curGeomSequ));
for k := 0 to Length(curGeomSequ) - 1 do
longGeomSequ[k] := curGeomSequ[k];
end;
if d <> d1 then
curArithmSequ := NIL;
if q <> q1 then
curGeomSequ := NIL;
inc(i);
Until i >= Length(sequence) - 1;
writeLn('The Longest Arithmetic Progression');
for k := 0 to Length(longArithmSequ) - 1 do
Write(longArithmSequ[k], ' ');
writeLn('The Longest Geometric Progression');
for k := 0 to Length(longGeomSequ) - 1 do
Write(longGeomSequ[k], ' ');
Readln(k);
end.
I have such question:
Why it can't print first 1-2 members of arithmetic progression
Why it always print '2' as geometric progression
Is there monkey-style code in my programm?
Please mention to me where are my mistakes.
Updated:
You need to change the logic inside the repeat loop in this way:
if d = d1 then
begin
if (Length(curArithmSequ) = 0) then
begin
if (i > 1) then
SetLength(curArithmSequ,3)
else
SetLength(curArithmSequ,2);
end
else
SetLength(curArithmSequ,Length(curArithmSequ)+1);
for k := 0 to Length(curArithmSequ) - 1 do
curArithmSequ[k] := sequence[i - (Length(curArithmSequ) - k - 1)];
end
else
SetLength(curArithmSequ,0);
if q = q1 then
begin
if (Length(curGeomSequ) = 0) then
begin
if (i > 1) then
SetLength(curGeomSequ,3)
else
SetLength(curGeomSequ,2);
end
else
SetLength(curGeomSequ,Length(curGeomSequ)+1);
for k := 0 to Length(curGeomSequ) - 1 do
curGeomSequ[k] := sequence[i - (Length(curGeomSequ) - k - 1)];
end
else
SetLength(curGeomSequ,0);
An input sequence of:
2,6,18,54 gives LAP=2,6 and LGP=2,6,18,54
while an input sequence of:
1,3,5,7,9 gives: LAP=1,3,5,7,9 and LGP=1,3
And a sequence of
5,4,78,2,3,4,5,6,18,54,16 gives LAP=2,3,4,5,6 and LGP=6,18,54
Here is my complete test (see comments below):
program arithmeticAndGeometricProgression;
{ 203. In specified sequence of integer numbers find the longest sequence, which is
arithmetic or geometric progression. }
{$APPTYPE CONSOLE}
uses
SysUtils;
Type
TIntArr = array of integer;
TValidationProc = function( const sequence : array of integer) : Boolean;
function IsValidArithmeticSequence( const sequence : array of integer) : Boolean;
begin
Result :=
(Length(sequence) = 2) // Always true for a sequence of 2 values
or
// An arithmetic sequence is defined by: a,a+n,a+2*n, ...
// This gives: a+n - a = a+2*n - (a+n)
// s[1] - s[0] = s[2] - s[1] <=> 2*s[1] = s[2] + s[0]
(2*sequence[1] = (Sequence[2] + sequence[0]));
end;
function IsValidGeometricSequence( const sequence : array of integer) : Boolean;
var
i,zeroCnt : Integer;
begin
// If a zero exists in a sequence all members must be zero
zeroCnt := 0;
for i := 0 to High(sequence) do
if (sequence[i] = 0) then
Inc(zeroCnt);
if (Length(sequence) = 2) then
Result := (zeroCnt in [0,2])
else
// A geometric sequence is defined by: a*r^0,a*r^1,a*r^2 + ... ; r <> 0
// By comparing sequence[i]*sequence[i-2] with Sqr(sequence[i-1])
// i.e. a*(a*r^2) with Sqr(a*r) we can establish a valid geometric sequence
Result := (zeroCnt in [0,3]) and (Sqr(sequence[1]) = sequence[0]*Sequence[2]);
end;
procedure AddSequence( var arr : TIntArr; sequence : array of Integer);
var
i,len : Integer;
begin
len := Length(arr);
SetLength(arr,len + Length(sequence));
for i := 0 to High(sequence) do
arr[len+i] := sequence[i];
end;
function GetLongestSequence( IsValidSequence : TValidationProc;
const inputArr : array of integer) : TIntArr;
var
i : Integer;
currentSequence : TIntArr;
begin
SetLength(Result,0);
SetLength(currentSequence,0);
if (Length(inputArr) <= 1)
then Exit;
for i := 1 to Length(inputArr)-1 do begin
if (Length(Result) = 0) then // no valid sequence found so far
begin
if IsValidSequence([inputArr[i-1],inputArr[i]])
then AddSequence(currentSequence,[inputArr[i-1],inputArr[i]]);
end
else
begin
if IsValidSequence([inputArr[i-2],inputArr[i-1],inputArr[i]]) then
begin
if (Length(currentSequence) = 0) then
AddSequence(currentSequence,[inputArr[i-2],inputArr[i-1],inputArr[i]])
else
AddSequence(currentSequence,inputArr[i]);
end
else // Reset currentSequence
SetLength(currentSequence,0);
end;
// Longer sequence ?
if (Length(currentSequence) > Length(Result)) then
begin
SetLength(Result,0);
AddSequence(Result,currentSequence);
end;
end;
end;
procedure OutputSequence( const arr : TIntArr);
var
i : Integer;
begin
for i := 0 to High(arr) do begin
if i <> High(arr)
then Write(arr[i],',')
else WriteLn(arr[i]);
end;
end;
begin
WriteLn('Longest Arithmetic Sequence:');
OutputSequence(GetLongestSequence(IsValidArithmeticSequence,[0,1,2,3,4,5,6]));
OutputSequence(GetLongestSequence(IsValidArithmeticSequence,[1,0,1,2,3,4,5,6]));
OutputSequence(GetLongestSequence(IsValidArithmeticSequence,[0,0,0,0,0,0]));
OutputSequence(GetLongestSequence(IsValidArithmeticSequence,[0,0,1,2,4,8,16]));
OutputSequence(GetLongestSequence(IsValidArithmeticSequence,[0,0,6,9,12,4,8,16]));
OutputSequence(GetLongestSequence(IsValidArithmeticSequence,[9,12,16]));
OutputSequence(GetLongestSequence(IsValidArithmeticSequence,[1,0,1,-1,-3]));
OutputSequence(GetLongestSequence(IsValidArithmeticSequence,[5,4,78,2,3,4,5,6,18,54,16]));
WriteLn('Longest Geometric Sequence:');
OutputSequence(GetLongestSequence(IsValidGeometricSequence,[0,1,2,3,4,5,6]));
OutputSequence(GetLongestSequence(IsValidGeometricSequence,[1,0,1,2,3,4,5,6]));
OutputSequence(GetLongestSequence(IsValidGeometricSequence,[0,0,0,0,0,0]));
OutputSequence(GetLongestSequence(IsValidGeometricSequence,[0,0,1,2,4,8,16]));
OutputSequence(GetLongestSequence(IsValidGeometricSequence,[0,0,6,9,12,4,8,16]));
OutputSequence(GetLongestSequence(IsValidGeometricSequence,[9,12,16]));
OutputSequence(GetLongestSequence(IsValidGeometricSequence,[1,0,9,-12,16]));
OutputSequence(GetLongestSequence(IsValidGeometricSequence,[5,4,78,2,3,4,5,6,18,54,16]));
ReadLn;
end.
As commented by David, mixing floating point calculations with integers can cause unwanted behavior. Eg. input sequence 9,12,16 with a geometric factor of 4/3 will work here, but other similar non-integer geometric factors may fail. More extensive testing is required to verify this.
In order to remove the dependency of floating point operations, following change in the loop can be made:
// A geometric function is defined by a + n*a + n^2*a + ...
// By comparing sequence[i]*sequence[i-2] with Sqr(sequence[i-1])
// i.e. n^2*a*a with Sqr(n*a) we can establish a valid geometric sequence
q := Sqr(sequence[i-1]);
if (i < 2)
then q1 := q // Special case, always true
else q1 := sequence[i] * sequence[i - 2];
Change the declarations of d,d1,q,q1 to Integer and remove the assignment of q1 before the loop.
The test code is updated to reflect these changes.
There is a problem when a sequence has one or more zeroes for the geometric sequence calculations.
Zero is only considered a member of a geometric sequence if all values are zero.
Geometric sequence: a*r^0, a*r^1, a*r^2, etc; r <> 0.
With a = 0 the progression consists of zeroes only.
This also implies that a valid geometric sequence can not hold both non-zero and zero values.
To rectify this with current structure it became messy. So I updated my test above with a better structured program that handles all input sequences.
This is quite an interesting problem. LU RD has given you an answer that fixes your code. I offer as an alternative, the way I would address the problem:
program LongestSubsequence;
{$APPTYPE CONSOLE}
type
TSubsequence = record
Start: Integer;
Length: Integer;
end;
function Subsequence(Start, Length: Integer): TSubsequence;
begin
Result.Start := Start;
Result.Length := Length;
end;
type
TTestSubsequenceRule = function(a, b, c: Integer): Boolean;
function FindLongestSubsequence(
const seq: array of Integer;
const TestSubsequenceRule: TTestSubsequenceRule
): TSubsequence;
var
StartIndex, Index: Integer;
CurrentSubsequence, LongestSubsequence: TSubsequence;
begin
LongestSubsequence := Subsequence(-1, 0);
for StartIndex := low(seq) to high(seq) do
begin
CurrentSubsequence := Subsequence(StartIndex, 0);
for Index := CurrentSubsequence.Start to high(seq) do
begin
if (CurrentSubsequence.Length<2)
or TestSubsequenceRule(seq[Index-2], seq[Index-1], seq[Index]) then
begin
inc(CurrentSubsequence.Length);
if CurrentSubsequence.Length>LongestSubsequence.Length then
LongestSubsequence := CurrentSubsequence;
end
else
break;
end;
end;
Result := LongestSubsequence;
end;
function TestArithmeticSubsequence(a, b, c: Integer): Boolean;
begin
Result := (b-a)=(c-b);
end;
function FindLongestArithmeticSubsequence(const seq: array of Integer): TSubsequence;
begin
Result := FindLongestSubsequence(seq, TestArithmeticSubsequence);
end;
function TestGeometricSubsequence(a, b, c: Integer): Boolean;
begin
Result := (b*b)=(a*c);
end;
function FindLongestGeometricSubsequence(const seq: array of Integer): TSubsequence;
begin
Result := FindLongestSubsequence(seq, TestGeometricSubsequence);
end;
procedure OutputSubsequence(const seq: array of Integer; const Subsequence: TSubsequence);
var
Index: Integer;
begin
for Index := 0 to Subsequence.Length-1 do
begin
Write(seq[Subsequence.Start + Index]);
if Index<Subsequence.Length-1 then
Write(',');
end;
Writeln;
end;
procedure OutputLongestArithmeticSubsequence(const seq: array of Integer);
begin
OutputSubsequence(seq, FindLongestArithmeticSubsequence(seq));
end;
procedure OutputLongestGeometricSubsequence(const seq: array of Integer);
begin
OutputSubsequence(seq, FindLongestGeometricSubsequence(seq));
end;
begin
Writeln('Testing arithmetic sequences:');
OutputLongestArithmeticSubsequence([]);
OutputLongestArithmeticSubsequence([1]);
OutputLongestArithmeticSubsequence([1,2]);
OutputLongestArithmeticSubsequence([1,2,3]);
OutputLongestArithmeticSubsequence([1,2,4]);
OutputLongestArithmeticSubsequence([6,1,2,4,7]);
OutputLongestArithmeticSubsequence([6,1,2,4,6,7]);
Writeln('Testing geometric sequences:');
OutputLongestGeometricSubsequence([]);
OutputLongestGeometricSubsequence([1]);
OutputLongestGeometricSubsequence([1,2]);
OutputLongestGeometricSubsequence([1,2,4]);
OutputLongestGeometricSubsequence([7,1,2,4,-12]);
OutputLongestGeometricSubsequence([-16,-12,-9]);
OutputLongestGeometricSubsequence([4,-16,-12,-9]);
Readln;
end.
The key point to stress is that your code is hard to understand because all the different aspects are mixed in with each other. I have attempted here to break the algorithm down into smaller parts which can be understood in isolation.