I'm using the code from: http://www.swissdelphicenter.ch/torry/showcode.php?id=1103
to sort my TListView, which works GREAT on everything but numbers with decimals.
So I tried to do this myself, and I created a new Custom Sort called: cssFloat
Created a new function
function CompareFloat(AInt1, AInt2: extended): Integer;
begin
if AInt1 > AInt2 then Result := 1
else
if AInt1 = AInt2 then Result := 0
else
Result := -1;
end;
Added of the case statement telling it what type the column is..
cssFloat : begin
Result := CompareFloat(i2, i1);
end;
And I changed the Column click event to have the right type selected for the column.
case column.Index of
0: LvSortStyle := cssNumeric;
1: LvSortStyle := cssFloat;
2: LvSortStyle := cssAlphaNum;
else LvSortStyle := cssNumeric;
And The ListView Sort type is currently set to stBoth.
It doesn't sort correctly. And Ideas on how to fix this?
Thank you
-Brad
I fixed it... after 3 hours of struggling with this.. not understanding why.. I finally saw the light.. CompareFloat was asking if two integers were greater or less than each other.
cssFloat : begin
r1 := IsValidFloat(s1, e1);
r2 := IsValidFloat(s2, e2);
Result := ord(r1 or r2);
if Result <> 0 then
Result := CompareFloat(e2, e1);
end;
(Copied and modified from EFG's Delphi site)
FUNCTION isValidFloat(CONST s: STRING; var e:extended): BOOLEAN;
BEGIN
RESULT := TRUE;
TRY
e:= StrToFloat(s)
EXCEPT
ON EConvertError DO begin e:=0; RESULT := FALSE; end;
END
END {isValidFloat};
While I don't know what is the problem which you faced perhaps is useful for you...
function CompareFloat(AStr1, AStr2: string): Integer;
const
_MAGIC = -1; //or ANY number IMPOSSIBLE to reach
var
nInt1, nInt2: extended;
begin
nInt1:=StrToFloatDef(AStr1, _MAGIC);
nInt2:=StrToFloatDef(AStr2, _MAGIC);
if nInt1 > nInt2 then Result := 1
else
if nInt1 = nInt2 then Result := 0
else
Result := -1;
end;
..and another snippet (perhaps much better):
function CompareFloat(aInt1, aInt2: extended): integer;
begin
Result:=CompareValue(aInt1, aInt2); // :-) (see the Math unit) - also you can add a tolerance here (see the 'Epsilon' parameter)
end;
Besides the rounding which can cause you problems you can see what the format settings are in conversion between string and numbers (you know, the Decimal Point, Thousands Separator aso.) - see TFormatSettings structure in StringToFloat functions. (There are two - overloaded).
HTH,
Related
After looking at Delphi extract string between to 2 tags and trying the code given there by Andreas Rejbrand I realized that I needed a version that wouldn't stop after one tag - my goal is to write all the values that occur between two strings in several .xml files to a logfile.
<screen> xyz </screen> blah blah <screen> abc </screen>
-> giving a logfile with
xyz
abc
... and so on.
What I tried was to delete a portion of the text read by the function, so that when the function repeated, it would go to the next instance of the desired string and then write that to the logfile too until there were no matches left - the boolean function would be true and the function could stop - below the slightly modified function as based on the version in the link.
function ExtractText(const Tag, Text: string): string;
var
StartPos1, StartPos2, EndPos: integer;
i: Integer;
mytext : string;
bFinished : bool;
begin
bFinished := false;
mytext := text;
result := '';
while not bFinished do
begin
StartPos1 := Pos('<' + Tag, mytext);
if StartPos1 = 0 then bFinished := true;
EndPos := Pos('</' + Tag + '>', mytext);
StartPos2 := 0;
for i := StartPos1 + length(Tag) + 1 to EndPos do
if mytext[i] = '>' then
begin
StartPos2 := i + 1;
break;
end;
if (StartPos2 > 0) and (EndPos > StartPos2) then
begin
result := result + Copy(mytext, StartPos2, EndPos - StartPos2);
delete (mytext, StartPos1, 1);
end
So I create the form and assign a logfile.
procedure TTagtextextract0r.FormCreate(Sender: TObject);
begin
Edit2.Text:=(TDirectory.GetCurrentDirectory);
AssignFile(LogFile, 'Wordlist.txt');
ReWrite(LogFile);
CloseFile(Logfile);
end;
To then get the files in question, I click a button which then reads them.
procedure TTagtextextract0r.Button3Click(Sender: TObject);
begin
try
sD := TDirectory.GetCurrentDirectory;
Files:= TDirectory.GetFiles(sD, '*.xml');
except
exit
end;
j:=Length(Files);
for k := 0 to j-1 do
begin
Listbox2.Items.Add(Files[k]);
sA:= TFile.ReadAllText(Files[k]);
iL:= Length(sA);
AssignFile(LogFile, 'Wordlist.txt');
Append(LogFile);
WriteLn(LogFile, (ExtractText('screen', sA)));
CloseFile (LogFile);
end;
end;
end.
My problem is that without the boolean loop in the function, the application only writes the one line per file and then stops but with the boolean code the application gets stuck in an infinite loop - but I can't quite see where the loop doesn't end. Is it perhaps that the "WriteLn" command can't then output the result of the function? If it can't, I don't know how to get a new line for every run of the function - what am I doing wrong here?
First you need to get a grip on debugging
Look at this post for a briefing on how to pause and debug a program gone wild.
Also read Setting and modifying breakpoints to learn how to use breakpoints. If you would have stepped through your code, you would soon have seen where you go wrong.
Then to your problem:
In older Delphi versions (up to Delphi XE2) you could use the PosEx() function (as suggested in comments), which would simplify the code in ExtractText() function significantly. From Delphi XE3 the System.Pos() function has been expanded with the same functionality as PosEx(), that is, a third parameter Offset: integer
Since you are on Delphi 10 Seattle you can use interchangeably either System.StrUtils.PosEx() or System.Pos().
System.StrUtils.PosEx
PosEx() returns the index of SubStr in S, beginning the search at
Offset
function PosEx(const SubStr, S: string; Offset: Integer = 1): Integer; inline; overload;
The implementation of ExtractText() could look like this (with PosEx()):
function ExtractText(const tag, text: string): string;
var
startPos, endPos: integer;
begin
result := '';
startPos := 1;
repeat
startPos := PosEx('<'+tag, text, startpos);
if startPos = 0 then exit;
startPos := PosEx('>', text, startPos)+1;
if startPos = 1 then exit;
endPos := PosEx('</'+tag+'>', text, startPos);
if endPos = 0 then exit;
result := result + Copy(text, startPos, endPos - startPos) + sLineBreak;
until false;
end;
I added sLineBreak (in unit System.Types) after each found text, otherwise it should work as you intended it (I believe).
procedure TfrmSorting.btnSortClick(Sender: TObject);
var
K,L,I,iNumElements : integer;
sKeep : string;
begin
iNumElements := length(arrNames);
for K := 1 to iNumElements - 1 do
begin
for L := K + 1 to iNumElements do
begin
if arrNames[K] < arrNames[L] then
begin
sKeep := arrNames[L];
arrNames[L] := arrNames[K];
arrNames[K] := sKeep;
end;
end;
end;
reditNames.Lines.Clear;
I := 1;
for K := 1 to iNumElements - 1 do
begin
reditNames.Lines.Add(arrNames[I]);
I := I + 1;
end;
end;
I'm using this sorting algorithm to sort an Array. I then diplay the contents on a richedit but instead of going from A..Z its displays Z..A. Is there a problem with the algorithm or the way im adding lines to the richedit? Thanks
K is less than L and you swap items if the K-th is less than the L-th. You have your comparison the wrong way round. Use > rather than <.
Your indexing is dubious also. Is your array really 1-based? And why do you only add 1 to N-1 to the output? Are you missing the last item In other words, I suspect there are other defects in your code. You have not shown it all so I cannot be sure.
Finally, why not use the built in sorting functionality?
Here is my current code:
function StudentQuickSort(StudentList:TStudentArray;ArrayLength:integer):TStudentArray;
var
Pivot:TstudentArray;
LesserList:TStudentArray;
GreaterList:TstudentArray;
ArrayCount:Integer;
LesserCount:Integer;
GreaterCOunt:integer;
procedure ConcatArrays(const A,B,C: TStudentArray; var D: TStudentArray);
var i, nA,nB,nC: integer;
begin
nA := length(A);
nB := length(B);
nC := Length(C);
SetLength(D,nA+nB+nC);
for i := 0 to nA-1 do
D[i] := A[i];
for i := 0 to nB-1 do
D[i+nA] := B[i];
for i := 0 to nC-1 do
D[i+nA+nB] := C[i];
end;
begin
if Arraylength<=1 then
begin
Result:=(StudentList);
end
else
begin
SetLength(StudentList,ArrayLength);
SetLength(LesserList,ArrayLength);
SetLength(GreaterList,ArrayLength);
SetLength(Pivot,1);
LesserCOunt:=0;
GreaterCount:=0;
Pivot[0]:=StudentList[0];
for ArrayCount := 1 to ArrayLength-1 do
begin
if strtoint(StudentList[ArrayCount].StudentNo)>strtoint(Pivot[0].StudentNo) then
begin
GreaterList[GreaterCOunt]:=StudentList[ArrayCount];
GreaterCount:=GreaterCount+1;
end
else
begin
LesserList[LesserCOunt]:=StudentList[ArrayCount];
LesserCount:=LesserCount+1;
end;
end;
SetLength(LesserLIst,LesserCount);
SetLength(GreaterList,GreaterCount);
ConcatArrays(StudentQuickSort(LesserList,LesserCount),Pivot,StudentQuickSort(GreaterList,GreaterCount),Result)
end;
end;
How can this be stabilized, ideally changing as little code as possible. IS it a problem with using dynamic arrays? I need to be able to sort through at least 600 records without error.
Your code cannot be salvaged. You are going about solving this problem in the wrong way and I advise you to abandon your existing code. Here is how I believe sorting should be done.
Note that I am assuming that you don't have generics available to you. In modern Delphi versions you can use TArray.Sort<T> from Generics.Collections to sort. If you have access to that, you should use it
First of all the key is to separate the sorting from the array being sorted. To achieve that define the following types:
type
TCompareIndicesFunction = function(Index1, Index2: Integer): Integer of object;
TExchangeIndicesProcedure = procedure(Index1, Index2: Integer) of object;
The point is that all the common algorithms that can sort an array need only to be able to compare two items, and exchange two items. These procedural types enable separation of the sorting algorithm from the underlying array storage and types.
With these definitions in place, we are ready to write our general purpose sorting algorithms. For quicksort it looks like this:
procedure QuickSort(Count: Integer; Compare: TCompareIndicesFunction;
Exchange: TExchangeIndicesProcedure);
procedure Sort(L, R: Integer);
var
I, J, P: Integer;
begin
repeat
I := L;
J := R;
P := (L+R) div 2;
repeat
while Compare(I, P)<0 do inc(I);
while Compare(J, P)>0 do dec(J);
if I<=J then
begin
if I<>J then
begin
Exchange(I, J);
//may have moved the pivot so we must remember which element it is
if P=I then
P := J
else if P=J then
P := I;
end;
inc(I);
dec(J);
end;
until I>J;
if L<J then
Sort(L, J);
L := I;
until I>=R;
end;
begin
if Count>0 then
Sort(0, Count-1);
end;
In order to use this you need to wrap your array in a class which exposes compare and exchange methods.
I'm coding this function where if a string differs only by one character, returns the distinct characters position, if they're right the same is supposed to return -1 and -10 in the case they differ by more than 1 character.
Just for giving and example, '010' and '110' or '100' and '110' works good, returning 0 and 1 each...
However, when I try with '100' and '101'or with '110' and '111' I get a result of -1 when it should be 2! I've done the desktop testing and I can't just see the mistake.
function combine (m1, m2 : string) : integer;
var
dash : integer;
distinct : integer;
i : integer;
begin
distinct := 0;
dash := -1;
for i := 0 to Length(m1)-1 do
begin
if m1[i] <> m2[i] then
begin
distinct := distinct+1;
dash := i;
if distinct > 1 then
begin
result:= -10;
exit;
end;
end;
end;
result := dash;
end;
I'm always getting same length strings,
What am I doing wrong?
The main problem is that Delphi strings are 1-based. Your loop needs to run from 1 to Length(m1).
If you enabled range checking in the compiler options, then the compiler would have raised an error at runtime which would have led you to the fault. I cannot stress enough that you should enable range checking. It will lead to the compiler finding errors in your code.
Note also that this means that the returned values will also be 1-based. So an input of '100', '101' will give the result 3 since that is the index of the first difference.
You should also check that m1 and m2 are the same length. If not raise an exception.
Another tip. The idiomatic way to increment a variable by 1 is like so:
inc(distinct);
If you want to increment by a different value write:
inc(distinct, n);
So, I would write the function like this:
function combine(const m1, m2: string): integer;
var
i: integer;
dash: integer;
distinct: integer;
begin
if Length(m1)<>Length(m2) then begin
raise EAssertionFailed.Create('m1 and m2 must be the same length');
end;
distinct := 0;
dash := -1;
for i := 1 to Length(m1) do
begin
if m1[i] <> m2[i] then
begin
inc(distinct);
dash := i;
if distinct > 1 then
begin
result := -10;
exit;
end;
end;
end;
result := dash;
end;
Hi i am having a problem with incremental search in delphi.
I Have looked at this http://delphi.about.com/od/vclusing/a/lb_incremental.htm
But this doesn't work in firemonkey so i came up with this :
for I := 0 to lstbxMapList.Items.Count-1 do
begin
if lstbxMapList.Items[i] = edtSearch.Text then
begin
lstbxMapList.ItemByIndex(i).Visible := True;
end;
if lstbxMapList.Items[I] <> edtSearch.Text then
begin
lstbxMapList.ItemByIndex(i).Visible := False;
end;
end;
When i use this the listbox is just blank.
You're hiding every item that doesn't exactly match edtSearch.Text. Try this instead (tested in XE3):
// Add StrUtils to your uses clause for `StartsText`
uses
StrUtils;
procedure TForm1.edtSearchChange(Sender: TObject);
var
i: Integer;
NewIndex: Integer;
begin
NewIndex := -1;
for i := 0 to lstBxMapList.Items.Count - 1 do
if StartsText(Edit1.Text, lstBxMapList.Items[i]) then
begin
NewIndex := i;
Break;
end;
// Set to matching index if found, or -1 if not
lstBxMapList.ItemIndex := NewIndex;
end;
Following from Kens answer, if you want to hide items as per your question, just set the Visible property but note that since the expression of an if statement returns a boolean and Visible is a boolean property it's possible to greatly simplify things. Note also that I've also used ContainsText which will match the string anywhere in the item text:
procedure TForm1.edtSearchChange(Sender: TObject);
var
Item: TListBoxItem;
begin
for Item in lstbxMapList.ListItems do
Item.Visible := ContainsText(Item.Text.ToLower, Edit1.Text.ToLower);
end;