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.

Resources