Sorting a string list containing numbers and strings - sorting
I'm trying to sort a string grid filled with scores and strings like so:
via a sorted string list which is sorted by single columns from the grid called SUB 1, SUB 2, FINAL, TOTAL respectively (all these columns work except FINAL) and I'm not getting the results I need in the FINAL column.
I'm trying to get the column sorted like so, for example :
24
20
12
5
DNF
EXE
WE
but I'm getting this result instead (the result I do not want):
DNF
EXE
WE
24
20
12
5
In what way could I change my code to sort the grid as I want to sort it?
My code:
function Compare2(
List : TStringList;
Index1 : Integer;
Index2 : Integer) : Integer;
begin
//comparer for custom sort used in SortLTSGrid
if List[Index1] = List[Index2] then
Result := 0
else if List[Index1] < List[Index2] then
Result := 1
else
Result := -1;
end;
procedure TfrmPuntehou.SortLTSGrid(var grid: TStringGrid; columntotal: Integer);
var
TheList : TStringList;
i,l,iCount,m:integer;
const
separator = ',';
const
arrCodes:array[1..10] of string = ('DNF','DNS','WD','WE','DNA','OD','RD','EXR','EXE','PP');
begin
//sorts grid largest to smallest according to one column
//get grid row amount
iCount:=grid.RowCount - 1;
//create and fill the string list
TheList := TStringList.Create;
//fill the list
for i := 1 to (iCount) do
begin
for l := 1 to Length(arrCodes) do
begin
if grid.Rows[i].Strings[columntotal] = arrCodes[l] then
begin
TheList.Add('0'+separator+grid.Rows[i].Text);
end;
end;
TheList.Add(grid.Rows[i].Strings[columntotal]+separator+grid.Rows[i].Text);
end;
//try block to sort and write all strings in the list to the grid correctly
try
TheList.CustomSort(Compare2);
for i:= 1 to (iCount) do
begin
grid.Rows[i].Text := TheList.Strings[(i-1)] ;
end;
//fill the row numbers
for m := 1 to iCount do
begin
grid.Cells[0,m]:= IntToStr(m);
end;
finally
TheList.Free;
end;
end;
You can use two different lists to store items, and two different sorting functions (because you want to sort them in different direction; numbers will be ordered as decreasing and strings will be ordered as ascending) to sort lists. Sort the lists separately, and than merge them.
Please consider #David Heffernan's performance warning.
program Project3;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils, System.Classes;
var
slStrings, slNumbers:TStringList;
test:string;
function CompareForNumbers(
List : TStringList;
Index1 : Integer;
Index2 : Integer) : Integer;
var
val1, val2:Integer;
begin
val1 := StrToInt(List[Index1]);
val2 := StrToInt(List[Index2]);
if val1 = val2 then
Result := 0
else if val1 < val2 then
Result := 1
else
Result := -1;
end;
function CompareForStrings(
List : TStringList;
Index1 : Integer;
Index2 : Integer) : Integer;
begin
if List[Index1] = List[Index2] then
Result := 0
else if List[Index1] > List[Index2] then
Result := 1
else
Result := -1;
end;
begin
slStrings := TStringList.Create();
slNumbers := TStringList.Create();
try
slStrings.Add('EXE');
slStrings.Add('WE');
slStrings.Add('DNF');
slNumbers.Add('5');
slNumbers.Add('20');
slNumbers.Add('24');
slNumbers.Add('12');
slNumbers.CustomSort(CompareForNumbers);
slStrings.CustomSort(CompareForStrings);
slNumbers.AddStrings(slStrings);
Writeln(slNumbers.Text);
Readln(test);
finally
slStrings.Free();
slNumbers.Free();
end;
end.
To use single list to handle #David Heffernan's performance warning, i've write this;
program Project3;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils, System.Classes;
var
slStrings:TStringList;
test:string;
function Compare(
List : TStringList;
Index1 : Integer;
Index2 : Integer) : Integer;
var
val1, val2:Integer;
val1integer, val2integer:Boolean;
begin
val1integer := TryStrToInt(List[Index1], val1);
val2integer := TryStrToInt(List[Index2], val2);
if val1integer and val2integer then
begin
if val1 = val2 then
Result := 0
else if val1 < val2 then
Result := 1
else
Result := -1;
end
else if (not val1integer) And (not val2integer) then
begin
if List[Index1] = List[Index2] then
Result := 0
else if List[Index1] > List[Index2] then
Result := 1
else
Result := -1;
end
else
begin
if val1integer then
Result := -1
else
Result := 1;
end;
end;
begin
slStrings := TStringList.Create();
try
slStrings.Add('EXE');
slStrings.Add('5');
slStrings.Add('WE');
slStrings.Add('20');
slStrings.Add('DNF');
slStrings.Add('24');
slStrings.Add('12');
slStrings.Add('A');
slStrings.Add('6');
slStrings.Add('E');
slStrings.Add('B');
slStrings.Add('4');
slStrings.Add('T');
slStrings.Add('444');
slStrings.CustomSort(Compare);
Writeln(slStrings.Text);
Readln(test);
finally
slStrings.Free();
end;
end.
I believe you want to sort times by shortest to longest first, then all text alphabetically (although that is arguable).
I would not modify the texts in the way that you do. Instead I would simply modify the comparer function and pass the texts 'as is'.
To test it I used a TMemo, but the principle applies to the tables - just copy the appropriate column to the string list.
function Compare2(
List : TStringList;
Index1 : Integer;
Index2 : Integer) : Integer;
var
i1IsNumeric, i2IsNumeric : boolean;
i1, i2 : integer;
begin
//comparer for custom sort used in SortLTSGrid
i1IsNumeric := TryStrToInt( List[Index1], i1 );
i2IsNumeric := TryStrToInt( List[Index2], i2 );
if i1IsNumeric and (not i2IsNumeric) then
begin
Result := -1;
end
else if i2IsNumeric and (not i1IsNumeric) then
begin
Result := 1;
end
else if i1IsNumeric then
begin
Result := Sign( i1-i2);
end
else
begin
Result := CompareStr( List[Index1], List[Index2] );
end;
end;
Here is my test routine using a memo
procedure TForm4.Button1Click(Sender: TObject);
var
iList : TStringList;
begin
iList := TStringList.Create;
try
iList.Assign( Memo1.Lines );
iList.CustomSort( Compare2 );
Memo1.Lines.Assign( iList );
finally
iList.Free;
end;
end;
Your routine would be more like (although this I have not tested)
procedure TfrmPuntehou.SortLTSGrid(var grid: TStringGrid; columntotal: Integer);
var
TheList : TStringList;
i,l,iCount,m:integer;
const
separator = ',';
const
arrCodes:array[1..10] of string = ('DNF','DNS','WD','WE','DNA','OD','RD','EXR','EXE','PP');
begin
//sorts grid largest to smallest according to one column
//get grid row amount
iCount:=grid.RowCount - 1;
//create and fill the string list
TheList := TStringList.Create;
//fill the list
for i := 1 to (iCount) do
begin
TheList.Add(grid.Rows[i].Text);
end;
//try block to sort and write all strings in the list to the grid correctly
try
TheList.CustomSort(Compare2);
for i:= 1 to (iCount) do
begin
grid.Rows[i].Text := TheList.Strings[(i-1)] ;
end;
//fill the row numbers
for m := 1 to iCount do
begin
grid.Cells[0,m]:= IntToStr(m);
end;
finally
TheList.Free;
end;
end;
Related
Pascal: Error trying to rewrite array and assistance with printing my array
So i'm working on this pascal application which has a menu where you can do multiple things. After entering an album (which is what my program does) and trying to edit it by writing over the current album I get an error as shown in the image. There have been no errors when compiling except the warning: (100,9) Warning: Function result variable does not seem to initialized Here is my code: program MusicPlayer; uses TerminalUserInput; type // You should have a track record TrackRec = record name: String; location: String; end; type TrackArray = array of TrackRec; GenreType = (Pop, Rap, Rock, Classic); AlbumRec = Record name: String; genre: GenreType; location: array of TrackRec; // this and track should be track: array of TrackRec numberOfTracks: Integer; tracks: TrackArray; end; type AlbumArray = array of AlbumRec; // this should be an array of AlbumRec function ReadGenre(prompt: String): GenreType; var option: Integer; begin WriteLn('Press 1 for Pop'); WriteLn('Press 2 for Rap'); WriteLn('Press 3 for Rock'); WriteLn('Press 4 for Classic'); option := ReadInteger(prompt); while (option<1) or (option>3) do begin WriteLn('Please enter a number between 1-4'); option := ReadInteger(prompt); end; case option of 1: result := Pop; 2: result := Rap; 3: result := Rock; else result := Classic; end; end; function CheckLength(prompt: string): Integer; var i: Integer; begin i := ReadInteger(prompt); while (i < 0) or (i > 20) do begin WriteLn('Please enter a number between 1-20'); i := ReadInteger(prompt); end; result := i; end; function ReadTracks(count: Integer): TrackArray; var i: Integer; begin setLength(result, count); for i := 0 to High(result) do begin result[i].name := ReadString('Track Name: '); result[i].location := ReadString('Track Location: '); end; end; function ReadAlbum(): AlbumRec; begin result.name := ReadString('What is the name of the album?'); result.genre := ReadGenre('What is the genre of the album?'); result.numberOfTracks := CheckLength('How many tracks are in the album?'); result.tracks := ReadTracks(result.numberOfTracks); end; function ReadAlbums(count: Integer): AlbumArray; var i: Integer; begin SetLength(result, count); for i := 0 to High(result) do begin result[i] := ReadAlbum(); end; end; function ChangeAlbum(count: Integer): AlbumArray; var i: Integer; begin for i := count to count do begin result[i] := ReadAlbum(); end; end; procedure PrintAlbum(count: Integer; album: array of AlbumRec); var i: Integer; begin if count = 1 then begin for i := 0 to High(album) do begin WriteLn('Album Number: ', i); WriteLn('Album name is: ', album[i].name); WriteLn('Album genre is: ', album[i].genre); end end; for i := 1 to count - 1 do begin WriteLn('Album name is: ', album[i].name); WriteLn('Album genre is: ', album[i].genre); end; end; procedure PrintTrack(tracks: TrackArray); var i: Integer; begin i := ReadInteger('Which track number do you wish to play?'); i := i - 1; WriteLn('Now playing track: ', tracks[i].name); WriteLn('Track location: ', tracks[i].location); end; function CheckIfFinished(): Boolean; var answer: String; begin WriteLn('Do you want to enter another set of tracks? '); ReadLn(answer); LowerCase(answer); case answer of 'no': result := true; 'n': result := true; 'x': result := true; else result := false; end; end; procedure Main(); var i, count, select, change: Integer; albums: AlbumArray; begin WriteLn('Please select an option: '); WriteLn('-------------------------'); WriteLn('1. Read Albums'); WriteLn('2. Display Albums'); WriteLn('3. Select an Album'); WriteLn('4. Update an Album'); WriteLn('5. Exit'); WriteLn('-------------------------'); repeat i := ReadInteger('Your Option:'); case i of 1: begin count := ReadInteger('How many albums: '); albums := ReadAlbums(count); end; 2: begin WriteLn('1. Display All Albums'); WriteLn('2. Display All Albums by Genre'); select := ReadInteger('Your Option: '); if i = 1 then begin PrintAlbum(select, albums); end; // if i = 2 then // WriteLn('1. Pop'); // WriteLn('2. Rap'); // WriteLn('3. Rock'); // WriteLn('4. Classic'); // albums := ReadAlbums(count); end; 3: begin select := ReadInteger('Which album would you like to play? '); PrintAlbum(select, albums); PrintTrack(albums[select-1].tracks); end; 4: begin change := ReadInteger('Which album would you like to edit?'); albums := ChangeAlbum(change); end; end; until i = 5; end; begin Main(); end.
The function that the warning refers to, on line 100, is function ChangeAlbum(count: Integer): AlbumArray; var i: Integer; begin for i := count to count do begin result[i] := ReadAlbum(); end; end; The warning says: Warning: Function result variable does not seem to initialized And indeed the result variable has not been initialized. The design of the function is wrong though. You are trying to modify an existing element in an array. You should not be returning a new array. The function is not necessary though. You should simply remove it. Then you need to look at the one place where you call the function. change := ReadInteger('Which album would you like to edit?'); albums := ChangeAlbum(change); You should instead code that like this: change := ReadInteger('Which album would you like to edit?'); albums[change] := ReadAlbum(); I've not checked anything else in your program. I would not be surprised if there are other problems. I've just tried to address the specific question that you asked.
Validation in Delphi
I'm a student and stuck on Delphi Validation. Here is my code: begin valid := true; for I:=1 to Length(edtvalue.Text) do if not (edtvalue.Text[I] in ['0'..'9','.'] )then valid:= false; if not valid then begin showmessage ('This item is not within the range'); DataItem1 := 0; end else dataitem1 := strtofloat(edtvalue.Text); This code reads in a value that the user inputs and checks whether it actually is an integer and detects when a user inputs letters. However when the user inputs something else (e.g. + or #) the code doesn't work and breaks the system. Is there a way I can fix this please? Thanks in advance
Use TryStrToFloat : var F: Double; begin if not TryStrToFloat(edtvalue.Text, F) then showmessage ('This item is not within the range'); else dataitem1 := F; end; Or if you want to set DataItem1 to 0 when error : var F: Double; begin if not TryStrToFloat(edtvalue.Text, F) then begin showmessage ('This item is not within the range'); DataItem1 := 0; end else dataitem1 := F; end; Also you can create a Function to do that , like : function IsFloat(Str: string): Boolean; var I: Double; C: Integer; begin Val(Str, I, C); Result := C = 0; end;
I changed to use TryStrToFloat as recommended by David in the comments, you just need to declare that val variable: var val: Extended; begin val := 0; if not TryStrToFloat(edtvalue.Text, val) then showmessage ('This item is not within the range'); dataitem1 := val; end;
Checking if word is palindrome with function
I have to write a program in Pascal which checks whether a word is a palindrome. For example: if I input "abba" then write 'TRUE' input 'abb a' then write 'TRUE' input 'abca' write 'FALSE' I wrote this: program palindromek; var i,j,delka,pul:integer; str:string; function palindrom(slovo:string):boolean; const mezera=32; begin delka:=length(str); if (delka mod 2) = 0 then pul:=delka div 2 else pul:=(delka-1) div 2; for i:=1 to delka do begin if (ord(slovo[i])>=ord('a')) and (ord(slovo[i])<=ord('z')) then begin if (delka>=4)and(delka<=100) then begin if (length(str) mod 2) = 0 then {slovo se sudym poctem pismen} begin for j:=1 to pul do begin if slovo[j]=slovo[length(str)-j+1] then palindrom:=true else palindrom:=false end end else begin for j:=1 to pul do begin if slovo[j]=slovo[length(str)-j+1] then palindrom:=true else palindrom:=false end end end else if slovo[1]=slovo[delka] then palindrom:=true else palindrom:=false end end; end; begin readln(str); writeln(palindrom(str)); end. but it has to ignore spaces. Do you have any idea please?
To remove all spaces, you can use function like this: procedure RemoveSpacesInplace(var s: string); var i, SpaceCount: Integer; begin SpaceCount := 0; for i := 1 to Length(s) do if s[i] = ' ' then Inc(SpaceCount) else s[i - SpaceCount] := s[i]; SetLength(s, Length(s) - SpaceCount); end; You can modify it for other non-letter chars. Note that your logic for odd and even length is excessive. Try to simplify it.
You can use the functions StringReplace and ReverseString for your task. program palindromek; uses SysUtils, StrUtils; var str:string; function palindrom(slovo:string):boolean; begin slovo := StringReplace(slovo, ' ', '', [rfReplaceAll]); Result := slovo = ReverseString(slovo) end; begin readln(str); writeln(palindrom(str)); readln; end. If you are not allowed to use SysUtils and StrUtils then you can manually reverse your string and then compare if the original string and the reversed string are equal. This would look something like this: (not tested!) function palindrom(slovo:string):boolean; var slovofor: string; slovorev: string; i: integer; begin for i:= length(slovo) downto 1 do begin if slovo[i] <> ' ' then begin slovofor := slovofor + slovo[length(slovo)-i+1]; slovorev := slovorev + slovo[i]; end; end; writeln(slovofor); Result := slovofor = slovorev end;
Converting String to Byte array won't work
I want to convert a String to a byte array, the code looks like the following: procedure StringToByteArray(const s : String; var tmp: array of Byte); var i : integer; begin For i:=1 to Length(s) do begin tmp[i-1] := Ord(s[i]); end; end; s[i] here is the i'th String element (= char at pos i) and I'm saving its numerical value to tmp. This works for some characters, but not for all, for example: Ord('•') returns Dec(149), which is what I expect. But in my procedure Ord(s[i]) returns Dec(8226) for the same character! Edit1: I think the defect lies in my other function "ByteArrayToStr" When converting ... tmp:= 149 // tmp is of type byte Log('experiment: ' + Chr(tmp)); // prints "•" Log('experiment2 ' + IntToStr(Ord(Chr(tmp)))); // prints 149 ... back and forth, this seems to work. But using the same conversion in the following function won't do it: function ByteArrayToStr( a : array of Byte ) : String; var S:String; I:integer; begin S:=''; For I:=0 to Length(a) -1 do begin tmp := Chr(a[I]) ; // for a[I] equals 149 this will get me "?" instead of "•" S:=S+tmp; end; Result:=S; end; To make it clear: ByteArrayToStr does not convert Ord(149) to "•" as expected, and therefore StringToByteArray won't work later on
You need to turn your parameters into AnsiString type. By doing so, you can write functions like this: [Setup] AppName=My Program AppVersion=1.5 DefaultDirName={pf}\My Program OutputDir=userdocs:Inno Setup Examples Output [Code] procedure StringToByteArray(const S: AnsiString; out ByteArray: array of Byte); var I: Integer; begin SetArrayLength(ByteArray, Length(S)); for I := 1 to Length(S) do ByteArray[I - 1] := Ord(S[I]); end; function ByteArrayToString(const ByteArray: array of Byte): AnsiString; var I: Integer; begin SetLength(Result, GetArrayLength(ByteArray)); for I := 1 to GetArrayLength(ByteArray) do Result[I] := Chr(ByteArray[I - 1]); end; procedure InitializeWizard; var S: AnsiString; ByteArray: array of Byte; begin S := '•'; StringToByteArray(S, ByteArray); MsgBox(IntToStr(ByteArray[0]), mbInformation, MB_OK); S := ''; S := ByteArrayToString(ByteArray); MsgBox(S, mbInformation, MB_OK); end;
How to synchronize equal lines in two stringlists
I have two stringlists that I wish to synchronize, so that equal lines get the same index, while different lines will be kept in the list where they originally were, and the other stringlist should get a "filler" for that index. Consider this example: SL1: 1,1,2,3,5,8 SL2: 1,3,5,7,9 procedure SyncStringlists(aSL1,aSL2 : TStringList; aFill : string = '-'); The procedure should change the lists to this SL1: 1,1,2,3,5,8,-,- SL2: 1,-,-,3,5,-,7,9 or, if the lists are sorted, to this SL1: 1,1,2,3,5,-,8,- SL2: 1,-,-,3,5,7,',9 How should I go about doing this?
Try this for the case where your lists are monotone increasing. procedure SyncStringlists(SL1, SL2: TStringList; const Fill: string='-'); var i1, i2: Integer; begin i1 := 0; i2 := 0; while (i1<SL1.Count) and (i2<SL2.Count) do begin if SL1[i1]<SL2[i2] then begin SL2.Insert(i2, Fill); end else if SL1[i1]>SL2[i2] then begin SL1.Insert(i1, Fill); end; inc(i1); inc(i2); end; while SL1.Count<SL2.Count do begin SL1.Add(Fill); end; while SL2.Count<SL1.Count do begin SL2.Add(Fill); end; end;
I actually managed to make a method that suits my need: procedure SyncStringlists(aSL1,aSL2 : TStringList; aFill : string = '-'); var I,J : integer; begin I := 0; J := 0; aSL1.Sort; aSL2.Sort; while (I<aSL1.Count) and (J<aSL2.Count) do begin if aSL1[I] > aSL2[J] then aSL1.Insert(I,aFill) else if aSL1[I] < aSL2[J] then aSL2.Insert(J,aFill); inc(I); inc(J); end; while aSL1.Count < aSL2.Count do aSL1.Add(aFill); while aSL2.Count < aSL1.Count do aSL2.Add(aFill); end; It requires the lists to be sorted, but NOT to have the sorted property true (because then we can't insert into it) Sample run: SL1: 1,1,2,3,5,8,a,b,c,d,e,f SL2: 1,3,5,7,9,e,f,g,h,i synced: SL1: 1,1,2,3,5,-,8,-,a,b,c,d,e,f,-,-,- SL2: 1,-,-,3,5,7,-,9,-,-,-,-,e,f,g,h,i
I hope some kind of this (Levenshtein distance) algorithm can help you.