source array(4 bytes)
[$80,$80,$80,$80] =integer 0
[$80,$80,$80,$81] = 1
[$80,$80,$80,$FF] = 127
[$80,$80,$81,$01] = 128
need to convert this to integer.
below is my code and its working at the moment.
function convert(b: array of Byte): Integer;
var
i, st, p: Integer;
Negative: Boolean;
begin
result := 0;
st := -1;
for i := 0 to High(b) do
begin
if b[i] = $80 then Continue // skip leading 80
else
begin
st := i;
Negative := b[i] < $80;
b[i] := abs(b[i] - $80);
Break;
end;
end;
if st = -1 then exit;
for i := st to High(b) do
begin
p := round(Power(254, High(b) - i));
result := result + b[i] * p;
result := result - (p div 2);
end;
if Negative then result := -1 * result
end;
i'm looking for a better function?
Update:
file link
https://drive.google.com/file/d/0ByBA4QF-YOggZUdzcXpmOS1aam8/view?usp=sharing
in uploaded file ID field offset is from 5 to 9
NEW:
Now i got into new problem which is decoding date field
Date field hex [$80,$8F,$21,$C1] -> possible date 1995-12-15
* in uploaded file date field offset is from 199 to 203
Just an example of some improvements as outlined by David.
The array is passed by reference as a const.
The array is fixed in size.
The use of floating point calculations are converted directly into a constant array.
Const
MaxRange = 3;
Type
TMySpecial = array[0..MaxRange] of Byte;
function Convert(const b: TMySpecial): Integer;
var
i, j: Integer;
Negative: Boolean;
Const
// Pwr[i] = Round(Power(254,MaxRange-i));
Pwr: array[0..MaxRange] of Cardinal = (16387064,64516,254,1);
begin
for i := 0 to MaxRange do begin
if (b[i] <> $80) then begin
Negative := b[i] < $80;
Result := Abs(b[i] - $80)*Pwr[i] - (Pwr[i] shr 1);
for j := i+1 to MaxRange do
Result := Result + b[j]*Pwr[j] - (Pwr[j] shr 1);
if Negative then
Result := -Result;
Exit;
end;
end;
Result := 0;
end;
Note that less code lines is not always a sign of good performance.
Always measure performance before optimizing the code in order to find real bottlenecks.
Often code readability is better than optimizing over the top.
And for future references, please tell us what the algorithm is supposed to do.
Code for testing:
const
X : array[0..3] of TMySpecial =
(($80,$80,$80,$80), // =integer 0
($80,$80,$80,$81), // = 1
($80,$80,$80,$FF), // = 127
($80,$80,$81,$01)); // = 128
var
i,j: Integer;
sw: TStopWatch;
begin
sw := TStopWatch.StartNew;
for i := 1 to 100000000 do
for j := 0 to 3 do
Convert(X[j]);
WriteLn(sw.ElapsedMilliseconds);
ReadLn;
end.
I slept over the answer to question Quicksort drama and wanted to recode it from scratch, implementing your tip with the call-by-reference var. And again: I cannot find any failure I made again. I compare the code to your program one by one and I cannot find the problem. The following code produces an Exception (External:SIGSEV at address 11602) during compilation/run
program quicksort;
var
iArray : array[0..8] of integer;
procedure fillArray(var iArray : array of integer);
begin;
iArray[0] := 3;
iArray[1] := 1;
iArray[2] := 8;
iArray[3] := 4;
iArray[4] := 9;
iArray[5] := 0;
iArray[6] := 8;
iArray[7] := 2;
iArray[8] := 5;
end;
procedure writeArray(iArray : array of integer);
var i:integer;
begin
for i:=low(iArray) to high(iArray) do begin
write(iArray[i]);
end;
writeln('');
end;
procedure quickSort(var iArray : array of integer; links : integer; rechts:integer);
var
l,r,pivot, temp: integer;
begin
if (rechts > links) then begin
l := links;
r := rechts;
pivot := iArray[(rechts+links) div 2];
while (l<r) do begin
while (iArray[l] < pivot) do l:=l+1;
while (iArray[r] > pivot) do r:=r-1;
if (l<=r) then begin
temp := iArray[l];
iArray[l] := iArray[r];
iArray[r] := temp;
end;
end;
if (links < r) then quickSort(iArray, links, r);
if (l < rechts) then quickSort(iArray, l, rechts);
end;
end;
begin
fillArray(iArray);
quickSort(iArray,low(iArray),high(iArray));
writeArray(iArray);
end.
The block of code that swaps, also needs to increment l and decrement r once the swap is complete:
if (l <= r) then
begin
temp := iArray[l];
iArray[l] := iArray[r];
iArray[r] := temp;
inc(l); // <-- this was missing
dec(r); // <-- as was this
end;
The complete program, with some other minor tidy ups:
program quicksort24340509;
var
iArray: array [0 .. 8] of integer;
Procedure fillArray(var iArray: array of integer);
begin;
iArray[0] := 3;
iArray[1] := 1;
iArray[2] := 8;
iArray[3] := 4;
iArray[4] := 9;
iArray[5] := 0;
iArray[6] := 8;
iArray[7] := 2;
iArray[8] := 5;
end;
Procedure writeArray(const iArray: array of integer);
var
i: integer;
begin
for i := low(iArray) to high(iArray) do
begin
write(iArray[i], ' ');
end;
writeln;
end;
Procedure quickSort(var iArray: array of integer; links, rechts: integer);
var
l, r, pivot, temp: integer;
begin
if (rechts > links) then
begin
l := links;
r := rechts;
pivot := iArray[(rechts + links) div 2];
while l < r do
begin
while iArray[l] < pivot do inc(l);
while iArray[r] > pivot do dec(r);
if l <= r then
begin
temp := iArray[l];
iArray[l] := iArray[r];
iArray[r] := temp;
inc(l);
dec(r);
end;
end;
if links < r then
quickSort(iArray, links, r);
if l < rechts then
quickSort(iArray, l, rechts);
end;
end;
begin
fillArray(iArray);
quickSort(iArray, low(iArray), high(iArray));
writeArray(iArray);
readln;
end.
Output
0 1 2 3 4 5 8 8 9
The reason that your version fails, without the missing lines, is that the recursive calls to quickSort operate on the wrong ranges.
For example, Given your input of
3 1 8 4 9 0 8 2 5
the partitioning step pivots on 9 and results in
3 1 8 4 5 0 8 2 9
Now, the recursive step should be to sort all the values to the left of the pivot, and all the values to the right. And we leave the pivot alone because partitioning ensured that it is in its final position.
There are no values to the right of the pivot so we should be making a recursive call for the range 0 to 7. But if you inspect what happens with your code you will find that it does not. Instead it makes a recursive call for the range 0 to 8. That in itself is a little benign, but once the ranges become small, at the stopping condition, it's different. Try asking your program to sort these values:
1 2
The code pivots on 1. At the end of partitioning we have:
links = 0
rechts = 1
l = 0
r = 0
So we recursively call quickSort passing l and rechts as the ranges. But that's exactly the same call as we initially made. And that therefore leads to a stack overflow.
So the point is that we must make sure that when we partition on a pivot, we exclude that pivot from all future recursive calls to quickSort. If we don't do that we don't sub-divide the problem, and the recursion does not terminate.
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.
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.