I am unable to convert my string format date (French) to TDateTime format. I am working on files which contain string format dates in English and other languages.
For example, 1st March 2021 will be in an English file as 1 mar 2021, and in a French file as 1 mars 2021.
var
_StrDate: String;
_MyDateTime: TDateTime;
begin
_StrDate := '1 mar 2021'; // English
_MyDateTime := VarToDateTime(_StrDate); // works perfect
_StrDate := '1 mars 2021'; // French
_MyDateTime := VarToDateTime(_StrDate); // error
end;
I'm getting this error msg:
Could not convert variant of type (UnicodeString) into type (Date)
I wrote a parser for the specific format your have. Well, I have done the basic work, you'll have to modify it for example to use both French and English month names as well as short names. You should also add some tests to filter invalid values out. And probably ignore character casing in the name of months.
const
MonthsFR : array [1..12] of String = (
'janvier', 'février', 'mars', 'avril', 'mai', 'juin', 'juillet',
'août', 'septembre', 'octobre', 'novembre', 'décembre');
function StrToDateFR(const S : String; out ADate : TDateTime) : Boolean;
var
A : TStringDynArray;
D : Word;
M : Word;
Y : Word;
begin
ADate := 0;
Result := FALSE;
A := SplitString(S, ' ');
if Length(A) <> 3 then
Exit;
D := StrToInt(A[0]);
M := High(MonthsFR);
while (M > Low(MonthsFR)) and (A[1] <> MonthsFR[M]) do
Dec(M);
if M < Low(MonthsFR) then
Exit;
Y := StrToInt(A[2]);
ADate := EncodeDate(Y, M, D);
Result := TRUE;
end;
One idea to expand the code is to have several similar functions for other languages. Since the function return TRUE only when the format is recognized, you may call various versions in sequence until one return true.
function StrToDateFR(const S: String; out ADate: TDateTime): Boolean;
var
A: TStringDynArray;
D: Word;
M: Word;
Y: Word;
i: integer;
begin
ADate := 0;
Result := FALSE;
A := SplitString(S, ' ');
if Length(A) <> 3 then
Exit;
D := StrToInt(A[0]);
M := 0;
for i := Low(MonthsFR) to High(MonthsFR) do
begin
if SameText(A[1], MonthsFR[i]) then
begin
M := i;
Break
end;
end;
if M = 0 then
Exit;
Y := StrToInt(A[2]);
ADate := EncodeDate(Y, M, D);
Result := TRUE;
end;
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.
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.
I have found this Delphi examle. It is supposed to embed CRC and check current CRC. Both should match, but I get different results. How to fix it? And how to speed it up?
CRC32Calc.pas
unit CRC32Calc;
interface
uses Classes, SysUtils, windows, messages;
type
Long = record
LoWord: Word;
HiWord: Word;
end;
const
CRCPOLY = $EDB88320;
procedure BuildCRCTable;
function RecountCRC(b: byte; CrcOld: LongWord): LongWord;
function GetCRC32(FileName: string; Full: boolean): string;
function SetEmbeddedCRC(FileName: string): string;
function GetEmbeddedCRC(FileName: string): string;
function BytesToHexStr(pB: PByte; BufSize: LongWord): String;
function HexStrToBytes(Str: String): String;
implementation
var
CRCTable: array [0 .. 512] Of LongWord;
// A helper routine that creates and initializes
// the lookup table that is used when calculating a CRC polynomial
procedure BuildCRCTable;
var
i, j: Word;
r: LongWord;
begin
FillChar(CRCTable, SizeOf(CRCTable), 0);
for i := 0 to 255 do
begin
r := i shl 1;
for j := 8 downto 0 do
if (r and 1) <> 0 then
r := (r Shr 1) xor CRCPOLY
else
r := r shr 1;
CRCTable[i] := r;
end;
end;
// A helper routine that recalculates polynomial relative to the specified byte
function RecountCRC(b: byte; CrcOld: LongWord): LongWord;
begin
RecountCRC := CRCTable[byte(CrcOld xor LongWord(b))
] xor ((CrcOld shr 8) and $00FFFFFF)
end;
// A helper routine that converts Word into String
function HextW(w: Word): string;
const
h: array [0 .. 15] Of char = '0123456789ABCDEF';
begin
HextW := '';
HextW := h[Hi(w) shr 4] + h[Hi(w) and $F] + h[Lo(w) shr 4] + h[Lo(w) and $F];
end;
// A helper routine that converts LongWord into String
function HextL(l: LongWord): string;
begin
with Long(l) do
HextL := HextW(HiWord) + HextW(LoWord);
end;
// Calculate CRC32 checksum for the specified file
function GetCRC32(FileName: string; Full: boolean): string;
var
f: TFileStream;
i, CRC: LongWord;
aBt: byte;
begin
// Build a CRC table
BuildCRCTable;
CRC := $FFFFFFFF;
// Open the file
f := TFileStream.Create(FileName, (fmOpenRead or fmShareDenyNone));
// To calculate CRC for the whole file use this loop boundaries
if Full then
for i := 0 to f.Size - 1 do
begin
f.Read(aBt, 1);
CRC := RecountCRC(aBt, CRC);
end
else
// To calculate CRC for the file excluding the last 4 bytes
// use these loop boundaries
for i := 0 to f.Size - 5 do
begin
f.Read(aBt, 1);
CRC := RecountCRC(aBt, CRC);
end;
f.Destroy;
CRC := Not CRC;
Result := HextL(CRC);
end;
// Calculate CRC and writes it to the end of file
function SetEmbeddedCRC(FileName: string): string;
var
f: TFileStream;
CRCOffset: LongWord;
CRC: string;
begin
f := TFileStream.Create(FileName, (fmOpenReadWrite or fmShareDenyNone));
CRCOffset := f.Size;
// Append a placeholder for actual CRC to the file
f.Seek(CRCOffset, TSeekOrigin.soBeginning);
f.Write(PByte(HexStrToBytes('FFFFFFFF'))^, 4);
// Obtain CRC
CRC := GetCRC32(FileName, True);
// Write CRC to the end of file
f.Seek(CRCOffset, TSeekOrigin.soBeginning);
f.Write(PByte(HexStrToBytes(CRC))^, 4);
f.Destroy;
Result := CRC;
end;
// Extract the CRC that was stored at last 4 bytes of a file
function GetEmbeddedCRC(FileName: string): string;
var
f: TFileStream;
CRCOffset: LongWord;
pB: PByte;
begin
GetMem(pB, 4);
// Open file
f := TFileStream.Create(FileName, (fmOpenRead or fmShareDenyNone));
// Proceed upto the end of file
CRCOffset := f.Size - 4;
f.Seek(CRCOffset, TSeekOrigin.soBeginning);
// Read the last four bytes where the CRC is stored
f.Read(pB^, 4);
f.Destroy;
Result := BytesToHexStr(pB, 4);
end;
// A helper routine that converts byte value to string with hexadecimal integer
function BytesToHexStr(pB: PByte; BufSize: LongWord): String;
var
i, j, b: LongWord;
begin
SetLength(Result, 2 * BufSize);
for i := 1 to BufSize do
begin
for j := 0 to 1 do
begin
if j = 1 then
b := pB^ div 16
else
b := pB^ - (pB^ div 16) * 16;
case b of
0:
Result[2 * i - j] := '0';
1:
Result[2 * i - j] := '1';
2:
Result[2 * i - j] := '2';
3:
Result[2 * i - j] := '3';
4:
Result[2 * i - j] := '4';
5:
Result[2 * i - j] := '5';
6:
Result[2 * i - j] := '6';
7:
Result[2 * i - j] := '7';
8:
Result[2 * i - j] := '8';
9:
Result[2 * i - j] := '9';
10:
Result[2 * i - j] := 'A';
11:
Result[2 * i - j] := 'B';
12:
Result[2 * i - j] := 'C';
13:
Result[2 * i - j] := 'D';
14:
Result[2 * i - j] := 'E';
15:
Result[2 * i - j] := 'F';
end;
end;
Inc(pB);
end;
end;
// A helper routine that converts string with hexadecimal integer to byte value
function HexStrToBytes(Str: String): String;
var
b, b2: byte;
lw, lw2, lw3: LongWord;
begin
lw := Length(Str) div 2;
SetLength(Result, lw);
for lw2 := 1 to lw do
begin
b := 0;
for lw3 := 0 to 1 do
begin
case Str[2 * lw2 - lw3] of
'0':
b2 := 0;
'1':
b2 := 1;
'2':
b2 := 2;
'3':
b2 := 3;
'4':
b2 := 4;
'5':
b2 := 5;
'6':
b2 := 6;
'7':
b2 := 7;
'8':
b2 := 8;
'9':
b2 := 9;
'a':
b2 := 10;
'b':
b2 := 11;
'c':
b2 := 12;
'd':
b2 := 13;
'e':
b2 := 14;
'f':
b2 := 15;
'A':
b2 := 10;
'B':
b2 := 11;
'C':
b2 := 12;
'D':
b2 := 13;
'E':
b2 := 14;
'F':
b2 := 15;
else
b2 := 0;
end;
if lw3 = 0 then
b := b2
else
b := b + 16 * b2;
end;
Result[lw2] := char(b);
end;
end;
end.
AppendCRC
program AppendCRC;
{$APPTYPE CONSOLE}
uses
SysUtils, Classes,
CRC32Calc in '..\CRC32Checker\CRC32Calc.pas';
var
FileName: string;
begin
{ TODO -oUser -cConsole Main : Insert code here }
if ParamCount = 1 then
begin
FileName := ParamStr(1);
// Verify whether a file exists
if not FileExists(FileName) then
begin
WriteLn('The specified file does not exist.');
Exit;
end;
WriteLn('Full checksum (before): ' + GetCRC32(FileName, True));
SetEmbeddedCRC(FileName);
WriteLn('Half checksum: ' + GetCRC32(FileName, False));
WriteLn('Full checksum (after): ' + GetCRC32(FileName, True));
WriteLn('GetEmbeddedCRC: :' + GetEmbeddedCRC(FileName));
WriteLn('The checksum was successfully embedded.')
end
else
begin;
WriteLn('Wrong parameters.');
WriteLn('Parameter1 - Full path to file.');;
end;
end.
My results are:
AppendCRC.exe Hello_Delphi_World.exe
Full checksum (before): 1912DA64
Half checksum: 1912DA64
Full checksum (after): B3F0A43E
GetEmbeddedCRC: :4400A000
The checksum was successfully embedded.
I am using Delphi XE5.
You should understand how this code works.
Overall idea is to append the CRC as an extra 4 bytes, out of the EXE structure, to the end of file. (A better idea would be to put CRC into a special field inside EXE Header in the beginning).
However that raises the hen and the egg problem: after we calculate CRC and embed it - the CRC file is changed (the value of CRC is appended) and the CRC of changed files changes too.
So you basically has to implement two modes/function of CRC calculation: for the whole file and for the file without last 4 bytes. You should use the latter mode to calculate CRC after appending (you call it embedding), and the former one to calculate CRC before it on vanilla just compiled program.
Your GetCRC32 function always cuts last 4 bytes from the file, thus before embedding it calculates CRC only of some part of file, not of the whole file. But there ahve to be two different modes.
PS: you can also "embed" CRC into NTFS Alternate Stream, like having MyApp.exe program and CRC stored as MyApp.exe:CRC.
PPS. i think using unbuffered read byte by byte in the GetCRC32 should be very slow. If possible, better use TBytesStream to read the file into memory as whole and then scan in usual loop over array. Or read it by chunks of 4096 bytes rather than by byte variables.
For the last non-complete buffer you would clean the rest of buffer with zeroes for example.
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.