Code:
program sorting;
{$mode delphi}{$H+}
uses
classes, sysutils, strutils;
const
// Known filename Prefix (letters) table. Their index is used as 'weight'
Prefixes: array[0..9] of string = (
'vvt', // very very top
'vh', // very high
'sh', // slightly high
'mc', // middle central view
'mh', // medium high
'sl', // slightly low
'vl', // very low
'b', // botom
'vb', // very bottom
'vvb' // very very bottom
);
// Still quick 'n' sloppy function
function SplitIntoPrefixAndNumber(s: string; var Prefix: string; var Number: integer): boolean;
var
idx : integer;
ch : char;
numsy : string = '';
begin
result := false;
prefix := '';
number := 0;
for idx := 1 to length(s) do
begin
ch := s[idx];
case ch of
'0'..'9' : numsy := numsy + ch;
'.' : break;
'a'..'z' : prefix := prefix + ch;
else break;
end;
end;
number := StrToInt(numsy);
end;
// Get the 'weight' of a prefix based on the index of prefixes.
function getPrefixWeight(Prefix: string): integer;
var
idx: integer;
begin
// correction for weight in case non-matching
result := High(Prefixes) + 1;
// parse Prefixes array from top to bottom
// and exits by returning the index value when the.
// filename Prefix starts with the first letters.
// from the current item in the prefixes table.
for idx := low(Prefixes) to High(Prefixes) do
begin
if AnsiStartsStr(Prefixes[idx], Prefix) then
begin
result := idx;
exit;
end;
end;
// See setting the result in the first line of this
// routine:
// if no prefix match was found then return the highest
// possible 'weight' to indicate this.
// This 'weight' will then be automatically sorted to.
// the bottom of the list.
end;
// The actual sorting implementation
// Callback type as per:
// FPC : https://www.freepascal.org/docs-html/rtl/classes/tstringlistsortcompare.html
// Delphi: https://docwiki.embarcadero.com/Libraries/Sydney/en/System.Classes.TStringListSortCompare
// TStringListSortCompare = function(List: TStringList; Index1, Index2: Integer): Integer;
function StringListSortCompare(sl: TStringList; idx1, idx2: Integer): Integer;
const
SortDescending = false; // set to true to sort in descending order
var
filename1 , filename2 : string; // current filenames to compare
prefix1 , prefix2 : string; // current prefix string parts
weight1 , weight2 : integer; // current prefix 'weights'
number1 , number2 : integer; // current number parts
begin
result := 0;
// get filename strings that needs to be compared
filename1 := sl[idx1];
filename2 := sl[idx2];
// get prefixes and numbers from corresponding filenames
SplitIntoPrefixAndNumber(filename1, prefix1, number1);
SplitIntoPrefixAndNumber(filename2, prefix2, number2);
// get 'value' (weight) of a prefix
// note that GetPrefixWeight already accounts for non-matching
// prefixes and they are placed at the bottom of the list
// because they have the 'highest' weight.
weight1 := GetPrefixWeight(prefix1);
weight2 := GetPrefixWeight(prefix2);
// in case you wish to 'witness' the actual sorting
// writeln('filename1:',filename1:10,' prefix1:', prefix1:3, ' number1:', number1:3, ' weigth1:', weight1);
// writeln('filename2:',filename2:10,' prefix2:', prefix2:3, ' number2:', number2:3, ' weight2:', weight2);
// prefix weights differ so exit sorting based on the weight
if weight1 <> weight2 then
begin
if SortDescending
then result := weight2 - weight1
else result := weight1 - weight2;
exit;
end;
// prefix weights are same so need to sort on number as well
if SortDescending.
then result := number2 - number1
else result := number1 - number2;
exit;
// in case wanting to add even more sorting rules then compare the two
// item(parts) and when they match, move on to the next sort comparison
// e.g. only exit the sort routine when the item-parts differ.
// That can be done indefinitely...
end;
procedure fill(strings: TStrings; sa: array of string);
var idx: integer;
begin
for idx := low(sa) to high(sa)
do strings.Add(sa[idx]);
end;
procedure show(strings: TStrings);
var idx: integer;
begin
for idx := 0 to strings.count-1
do writeln(strings[idx]);
end;
procedure shuffle(strings: TStrings);
var
ridx, idx: integer;
begin
randomize;
for idx := 0 to strings.count-1 do
begin
ridx := random(strings.count-idx);
strings.Exchange(idx, idx + ridx);
end;
end;
const
ExampleFilenames: array[0..15] of string =
(
'bf15.png', 'bf35.png',
'bs00.png', 'bs30.png',
'mcf30.png', 'mcf45.png', 'mcf60.png',
'mhf15.png', 'mhf30.png',
'shf25.png', 'shf40.png',
'sls00.png', 'vbf25.png',.
'vhs00.png', 'vhs175.png', 'vvt120.png'
);
var
SomeList: TStringList;
begin
SomeList := TStringList.Create;
fill(SomeList, ExampleFilenames);
writeln('unsorted');
show(SomeList);
writeln;
writeln('shuffled');
shuffle(SomeList);
show(SomeList);
writeln;
writeln('sorted (default)');
SomeList.Sort;
show(SomeList);
writeln;
// Using customsort as per:.
// FPC : https://www.freepascal.org/docs-html/rtl/classes/tstringlist.customsort.html
// Delphi: https://docwiki.embarcadero.com/Libraries/Sydney/en/System.Classes.TStringList.CustomSort
SomeList.CustomSort(StringListSortCompare);
writeln('custom sorted');
show(SomeList);
writeln;
SomeList.Free;
end.
Mostly the same but some stuff rewritten to make it compatible with Delphi7 (hopefully). Added the missing prefix that you added (and I initially missed) and added a descending sort option so you can see how that is done.
Bookmarks