///Example
some_array[0]:=0;
some_array[1]:=1;
some_array[2]:=2;
some_array[3]:=3;
some_array[4]:=4;
And now I need to shift values in array like this (by one cell up)
some_array[0]:=1;
some_array[1]:=2;
some_array[2]:=3;
some_array[3]:=4;
some_array[4]:=0;
Is there any build in procedure or I have to do this manually by copying to some temporary array?
There is no built in function for this. You will need to write your own. It might look like this:
procedure ShiftArrayLeft(var arr: array of Integer);
var
i: Integer;
tmp: Integer;
begin
if Length(arr) < 2 then
exit;
tmp := arr[0];
for i := 0 to high(arr) - 1 do
arr[i] := arr[i + 1];
arr[high(arr)] := tmp;
end;
Note that there is no need to copy to a temporary array. You only need to make a temporary copy of one element.
If your arrays are huge then the copying overhead could be significant. In which case you would be better off using a circular array. With a circular array you remember the index of the first element. Then the shift operation is just a simple increment or decrement operation on that index, modulo the length of the array.
If you use a modern Delphi then this could readily be converted to a generic method. And I think it should be easy enough for you to write the shift in the opposite direction.
There is no such procedure in the RTL.
A generic procedure (as proposed by #DavidHeffernan) might look something like this:
Type
TMyArray = record
class procedure RotateLeft<T>(var a: TArray<T>); static;
end;
class procedure TMyArray.RotateLeft<T>(var a: TArray<T>);
var
tmp : T;
i : Integer;
begin
if Length(a) > 1 then begin
tmp := a[0];
for i := 1 to High(a) do
a[i-1] := a[i];
a[High(a)] := tmp;
end;
end;
var
a: TArray<Integer>;
i:Integer;
begin
SetLength(a,5);
for i := 0 to High(a) do a[i] := i;
TMyArray.RotateLeft<Integer>(a);
for i := 0 to High(a) do WriteLn(a[i]);
ReadLn;
end.
A low level routine using Move() could be used if performance is critical:
class procedure TMyArray.RotateLeft<T>(var a: TArray<T>);
var
tmp : T;
begin
if Length(a) > 1 then begin
Move(a[0],tmp,SizeOf(T)); // Temporary store the first element
Move(a[1],a[0],High(a)*SizeOf(T));
Move(tmp,a[High(a)],SizeOf(T)); // Put first element last
// Clear tmp to avoid ref count drop when tmp goes out of scope
FillChar(tmp,SizeOf(T),#0);
end;
end;
Note the FillChar() call to clear the temporary variable at the end. If T is a managed type, it would otherwise drop the reference count of the last array element when going out of scope.
Stumbling across this one while facing a similar issue.
I have not implemented it yet, but have thought about this different approach: KEEP the array as it is, but make a new procedure to read values where you change the "zero" position.
Example:
read_array(index: integer; shift: integer)..
So if your original array is read with this function, using shift "1" it would read "1,2,3,4,0" (obviously looping). It would require you to keep track of a few things, but would not require modifying anything. So performance should be greater for very large arrays.
Similar would work for other types as well.
EDIT: an example function with free start index and variable step size plus sample size is here:
function get_shifted_array(inArray: TStringList; startindex,
lineCount: integer;
stepsize: integer): TStringList;
var
i : integer; // temp counter
nextindex : integer; // calculate where to get next value from...
arraypos : integer; // position in inarray to take
temp : tstringlist;
// function to mimic excel Remainder( A,B) function
// in this remainder(-2,10) = 8
//
function modPositive( dividend, divisor: integer): integer;
var
temp : integer;
begin
if dividend < 0 then
begin
temp := abs(dividend) mod divisor; // 1 mod 10 =9 for -1
// 122 mod 10 = 2 for -122
result := (divisor - temp);
end
else
result := dividend mod divisor;
end;
begin
nextindex := startindex; // where in input array to get info from
temp := tstringlist.create; // output placeholder
for i := 1 to lineCount do
begin
// convert to actual index inside loop
arraypos := modPositive(nextindex, inarray.count); // handle it like Excel: remainder(-1,10) = 9
// if mod is zero, we get array.count back. Need zero index then.
if arraypos = inArray.Count then arraypos := 0; // for negative loops.
// get the value at array position
temp.Add( 'IDX=' + inttostr(arraypos) + ' V=' + inarray[ arraypos ] );
// where to go next
// should we loop ?
if ((nextindex+ stepsize +1)> inArray.Count ) then
begin
nextindex := (nextindex + stepsize ) mod inArray.Count;
end
else
nextindex := nextindex + stepsize;
end;
result := temp;
end;
Thereby:
get_shifted_array(
inputarray,
-1, // shiftindex
length(inputarray),
1 ) // stepsize
would return the array shifted backwards one place.
All without any modification to array.
I have several hardcoded validations like these:
const
cLstAct = 1;
cLstOrg = 4;
cLstClockAct = 11;
const
FUNCT_1 = 224;
FUNCT_2 = 127;
FUNCT_3 = 3;
if lFuncID in [FUNCT_1,FUNCT_2,FUNCT_3] then ...
if not (lListType in [cLstAct..cLstOrg,cLstClockAct]) then ...
if not (lPurpose in [0..2]) then ...
that I want to replace with a common method like
function ValidateInSet(AIntValue: integer; AIntSet: ###): Boolean;
begin
Result := (AIntValue in AIntSet);
if not Result then ...
end;
but what type to choose for AIntSet?
Currently the values to be tested throughout the code go up to a const value 232 (so I can e.g. use a TByteSet = Set of Byte), but I can foresee that we will bump into the E1012 Constant expression violates subrange bounds when the constant values exceed 255.
My Google-fu fails me here...
(Currently on Delphi Seattle Update 1)
Use a dictionary, TDictionary<Integer, Integer>. The value is irrelevant and you only care about the key. If the dictionary contains a specific key then that key is a member of the set. Use AddOrSetValue to add a member, Remove to delete a member and ContainsKey to test membership.
The point of using a dictionary is that it gives you O(1) lookup.
You don't want to use this type directly as a set. You should wrap it in a class that just exposes set like capabilities. An example of that can be found here: https://stackoverflow.com/a/33530037/505088
You can use an array of Integer:
function ValidateInSet(AIntValue: integer; AIntSet: array of Integer): Boolean;
var
I: Integer;
begin
Result := False;
for I := Low(AIntSet) to High(AIntSet) do
begin
if AIntSet[I] = AIntValue then
begin
Result := True;
Break;
end;
end;
if not Result then ...
end;
const
cLstAct = 1;
cLstOrg = 4;
cLstClockAct = 11;
const
FUNCT_1 = 224;
FUNCT_2 = 127;
FUNCT_3 = 3;
if ValidateInSet(lFuncID, [FUNCT_1, FUNCT_2, FUNCT_3]) then ...
if not ValidateInSet(lListType, [cLstAct, 2, 3, cLstOrg, cLstClockAct]) then ...
if not ValidateInSet(lPurpose, [0, 1, 2]) then ...
If you are on a recent Delphi version, you can use TArray<Integer>.
function ValidateInSet(AIntValue: integer; const AIntSet: TArray<Integer>): Boolean;
var
N: Integer;
begin
{ option1 : if AIntSet is always sorted }
result := TArray.BinarySearch(AIntSet, AIntValue, N);
{ option 2: works for any array }
result := false;
for N in AIntSet do begin
if AIntValue = N then begin
result := true;
Break;
end;
end;
if not Result then begin
// ...
end;
end;
Calling is merely the same as with a set (except for ranges):
if ValidateInSet(lFuncID, [FUNCT_1,FUNCT_2,FUNCT_3]) then begin
end;
The direct answer would be TBits class
http://docwiki.embarcadero.com/Libraries/Seattle/en/System.Classes.TBits.Bits
Note: This can only be used starting with Delphi XE4 though - http://qc.embarcadero.com/wc/qcmain.aspx?d=108829
However for your "Set of integers" it in most inflated case would take 2^31 / 8 bytes of memory (because negative values of integer would not be even considered), and that would be a lot...
So I hope you would never really want to have a set of the whole integer. Or you should invest into Sparse Arrays instead.
function ValidateInSet(const AIntValue: integer; const AIntSet: TBits): Boolean;
begin
Result := (AIntValue >= 0) and (AIntValue < AIntSet.Size);
if Result then
Result := AIntSet.Bits[AIntValue];
if not Result then ...
v-a-l-i-d-a-t-e
end;
or rather
function ValidateInSet(const AIntValue: integer; const AIntSet: TBits): Boolean;
begin
Result := false;
if AIntValue < 0 then exit; // Validation criterion #1
if AIntValue >= AIntSet.Size then exit; // Validation criterion #2
if not AIntSet.Bits[AIntValue] then exit; // Validation criterion #3
if .... then exit; // Validation criterion #4
if .... then exit; // Validation criterion #5
if .... then exit; // Validation criterion #6
Result := true;
end;
or perhaps
TSetTestCriterion = TFunc<Integer, Boolean>;
TSetTestCriteria = TArray<TFunc<Integer, Boolean>>;
function ValidateInSet(const AIntValue: integer;
const AIntSet: TBits; const Tests: TSetTestCriteria = nil): Boolean;
var ExtraTest: TSetTestCriterion;
begin
Result := false;
if AIntValue < 0 then exit; // Validation criterion #1
if AIntValue >= AIntSet.Size then exit; // Validation criterion #2
if not AIntSet.Bits[AIntValue] then exit; // Validation criterion #3
if Tests <> nil then // Validation criteria #4, #5, #6, ...
for ExtraTest in Tests do
if not ExtraTest(AIntValue) then exit;
Result := true;
end;
http://docwiki.embarcadero.com/Libraries/Seattle/en/System.SysUtils.TFunc
Now - just for demo, in real app you would create those set and array once and cache for long (forever, or at least unless the configuration change would demand rebuilding them).
Type FuncIDs = ( FUNCT_3 = 3, FUNCT_2 = 127, FUNCT_1 = 224);
var MysticGlobalFlag: Boolean;
function ValidateFuncID( const lFuncID: FuncIDs): Boolean;
var map: TBits;
begin
map := TBits.Create;
try
map.Size := High(lFuncID) + 1;
map.Bits[ Ord(Func_1) ] := True;
map.Bits[ Ord(Func_2) ] := True;
map.Bits[ Ord(Func_3) ] := True;
Result := ValidateInSet( Ord(lFuncID), map,
TSetTestCriteria.Create(
function( lFuncID: integer) : Boolean
begin
Result := MysticGlobalFlag or (lFuncID <> Ord(FuncIDs.FUNC_2))
end
,
function( lFuncID: integer) : Boolean
begin
Result := (lFuncID <> Ord(FuncIDs.FUNC_3)) or (DayOfTheWeek(Now()) = 4)
end
)
);
finally
map.Destroy;
end;
if not Result then // from the original question code
... // seems like a placeholder for error handling or object creation and registration
end;
All, I know it's years since people answered this, but here is a new solution using Delphi generics: -
interface
uses
System.Generics.Defaults;
type
TUtilityArray<T> = class
public
class function Contains(const x : T; const an_array : array of T) : boolean;
end;
implementation
class function TUtilityArray<T>.Contains(const x: T; const an_array: array of T): boolean;
var
y : T;
l_comparer : IEqualityComparer<T>;
begin
Result := false;
l_comparer := TEqualityComparer<T>.Default;
for y in an_array do
begin
if l_comparer.Equals(x, y) then
begin
Result := true;
break;
end;
end;
end;
end.
To use include the class, then write if(TUtilityArray<integer>.Contains(some integer value, [value1, value2 etc.])) then .... An added benefit of this method is that it works for other primitives as well.
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 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.
I have a need to keep the top ten values in sorted order. My data structure is:
TMyRecord = record
Number: Integer;
Value: Float;
end
I will be calculating a bunch of float values. I need to keep the top 10 float values. Each value has an associated number. I want to add "sets"... If my float Value is higher than one of the top 10, it should add itself to the list, and then the "old" number 10, now 11, gets discarded. I should be able to access the list in (float value) sorted order...
It is almost like a TStringList, which maintains sorted order....
Is there anything like this already built into Delphi 2010?
You can use a combination of the generic list Generics.Collections.TList<TMyRecord> and insertion sort.
Your data structure is like this
TMyRecord = record
Number: Integer;
Value: Float;
end;
var
Top10: TList<TMyRecord>;
You'll need to use Generics.Collections to get the generic list.
Instantiate it like this:
Top10 := TList<TMyRecord>.Create;
Use this function to add to the list:
procedure Add(const Item: TMyRecord);
var
i: Integer;
begin
for i := 0 to Top10.Count-1 do
if Item.Value>Top10[i].Value then
begin
Top10.Insert(i, Item);
Top10.Count := Min(10, Top10.Count);
exit;
end;
if Top10.Count<10 then
Top10.Add(Item);
end;
This is a simple implementation of insertion sort. The key to making this algorithm work is to make sure the list is always ordered.
David's answer is great, but I think as you progress through the data, you'll fill the list pretty fast, and the odds of having a value greater than what's already in the list probably decreases over time.
So, for performance, I think you could add this line before the for loop to quickly discard values that don't make it into the top 10:
if (Item.Value <= Top10[Top10.Count - 1].Value) and (Top10.Count = 10) then
Exit;
If the floats are always going to be above a certain threshold, it might make sense to initialize the array with 10 place-holding records with values below the threshold just so you could change the first line to this:
if (Item.Value <= Top10[9].Value) then
Exit;
And improve the method to this:
procedure Add(const Item: TMyRecord);
var
i: Integer;
begin
// Throw it out if it's not bigger than our smallest top10
if (Item.Value <= Top10[9].Value) then
Exit;
// Start at the bottom, since it's more likely
for i := 9 downto 1 do
if Item.Value <= Top10[i - 1].Value then
begin
// We found our spot
Top10.Insert(i, Item);
// We're always setting it to 10 now
Top10.Count := 10;
// We're done
Exit;
end;
// Welcome, leader!
Top10.Insert(0, Item);
// We're always setting it to 10 now
Top10.Count := 10;
end;
Since you are working with a fixed number of items, you could use a plain TMyRecord array, eg:
type
TMyRecord = record
Number: Integer;
Value: Float;
end;
const
MaxRecordsInTopTen = 10;
var
TopTen: array[0..MaxRecordsInTopTen-1] of TMyRecord;
NumRecordsInTopTen: Integer = 0;
procedure CheckValueForTopTen(Value: Float; Number: Integer);
var
I, J, NumToMove: Integer;
begin
// see if the new Value is higher than an value already in the list
for I := 0 to (NumRecordsInTopTen-1) do
begin
if Value > TopTen[I].Value then
begin
// new Value is higher then this value, insert before
// it, moving the following values down a slot, and
// discarding the last value if the list is full
if NumRecordsInTopTen < MaxRecordsInTopTen then
NumToMove := NumRecordsInTopTen - I
else
NumToMove := MaxRecordsInTopTen - I - 1;
for J := 1 to NumToMove do
Move(TopTen[NumRecordsInTopTen-J], TopTen[NumRecordsInTopTen-J-1], SizeOf(TMyRecord));
// insert the new value now
TopTen[I].Number := Number;
TopTen[I].Value := Value;
NumRecordsInTopTen := Min(NumRecordsInTopTen+1, MaxRecordsInTopTen);
// all done
Exit;
end;
end;
// new value is lower then existing values,
// insert at the end of the list if room
if NumRecordsInTopTen < MaxRecordsInTopTen then
begin
TopTen[NumRecordsInTopTen].Number := Number;
TopTen[NumRecordsInTopTen].Value := Value;
Inc(NumRecordsInTopTen);
end;
end;
I wouldn't bother with anything other than straight Object Pascal.
{$APPTYPE CONSOLE}
program test2; uses sysutils, windows;
const
MAX_VALUE = $7FFF;
RANDNUMCOUNT = 1000;
var
topten: array[1..10] of Longint;
i, j: integer;
Value: Longint;
begin
randomize;
FillChar(topten, Sizeof(topten), 0);
for i := 1 to RANDNUMCOUNT do
begin
Value := Random(MAX_VALUE);
j := 1;
while j <= 10 do
begin
if Value > topten[j] then
begin
Move(topten[j], topten[j+1], SizeOf(Longint) * (10-j));
topten[j] := Value;
break;
end;
inc(j);
end;
end;
writeln('Top ten numbers generated were: ');
for j := 1 to 10 do
writeln(j:2, ': ', topten[j]);
readln;
end.