SRL Archive - OSR Help

I need to sort a string array in alphabetical order for a school assignment program. Right now, it works for the first two letters in the string. I need help making it check the next letter if necessary, and keep doing it until everything is sorted properly.

program Alphabetical_Sorting;

function alpha_GetLetters(s: TStringArray; index: Integer): Array of String;
var
  i: Integer;
begin
  SetLength(Result, Length(s));
               
  for i := 0 to High(s) do
    Result[i] := Lowercase(StrGet(s[i], index));
end;

function alpha_SortLetters(s: TStringArray; index: Integer): Array of String;
var
  alphabet: TStringArray;
  letters: Array of String;
  letterVals: Array of Integer;
  hi, i, j: Integer;
begin
  SetLength(Result, Length(s));
  SetLength(letterVals, Length(s));
  letters := alpha_GetLetters(s, index);
  
  alphabet := ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
               'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm',
               'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z'];

  hi := High(alphabet);
  for i := 0 to High(s) do
    for j := 0 to hi do
      if (letters[i] = alphabet[j]) then
        letterVals[i] := j;
        
  BubbleSort(letterVals);
  for i := 0 to High(letterVals) do
    for j := 0 to hi do
      if (letterVals[i] = j) then
        Result[i] := alphabet[j];
end;

function alpha_Occurrences(s: TStringArray; index: Integer): Array of Integer;
var
  sorted: Array of String;
  occurrences, hi, i, j: Integer;
begin
  SetLength(Result, 0);
  sorted := alpha_SortLetters(s, index);
  
  hi := High(sorted);
  for i := 0 to hi do
  begin
    if (i > 0) then
      if (sorted[i] = sorted[i - 1]) then
        Continue;
  
    for j := 0 to hi do
      if (sorted[i] = sorted[j]) then
        Inc(occurrences);
        
    SetLength(Result, Length(Result) + 1);
    Result[High(Result)] := occurrences;
    occurrences := 0;
  end;
end;

function alpha_SortWords(s: TStringArray; index: Integer): Array of String;
var
  letters, sorted: Array of String;
  i, j, k: Integer;
begin
  SetLength(Result, 0);
  letters := alpha_GetLetters(s, index);
  sorted := alpha_SortLetters(s, index);
      
  for j := 0 to High(sorted) do
    for k := 0 to High(letters) do
    begin
      if (InStrArr(s[k], Result, False)) then
        Continue;
        
      if (sorted[j] = letters[k]) then
      begin
        SetLength(Result, Length(Result) + 1);
        Result[High(Result)] := s[k];
      end;
    end;
end;

function alpha_GetDuplicates(s: TStringArray; index: Integer): Array of Array of String;
var
  sorted: Array of String;
  occurrences: Array of Integer;
  temp, start, finish, i, j, k: Integer;
begin
  sorted := alpha_SortWords(s, index);
  occurrences := alpha_Occurrences(sorted, index);

  for i := 0 to High(occurrences) do
  begin
    SetLength(Result, i + 1);
    
    for j := 0 to i do
      temp := temp + occurrences[j];
    
    start := (temp - occurrences[i]);
    finish := (temp - occurrences[i]) + (occurrences[i] - 1);
    
    for k := start to finish do
    begin
      SetLength(Result[i], Length(Result[i]) + 1);
      Result[i][High(Result[i])] := sorted[k];
    end;
    
    temp := 0;
  end;
end;

function alpha_SortDuplicates(s: TStringArray; index: Integer): Array of Array of String;
var
  duplicates: Array of Array of String;
  i: Integer;
begin
  duplicates := alpha_GetDuplicates(s, index);
  SetLength(Result, Length(duplicates));
  
  for i := 0 to High(duplicates) do
    Result[i] := alpha_SortWords(duplicates[i], index + 1);
end;

function alpha_SortStringArray(s: TStringArray): Array of String;
var
  index, i, j: Integer;
  sorted, dupSorted: Array of String;
  duplicates: Array of Array of String;
begin
  Inc(index);
  sorted := alpha_SortWords(s, index);
  duplicates := alpha_GetDuplicates(sorted, index);
  
  for i := 0 to High(duplicates) do
  begin
    if (Length(duplicates[i]) > 1) then
      duplicates[i] := alpha_SortWords(duplicates[i], index + 1);

    for j := 0 to High(duplicates[i]) do
    begin
      SetLength(Result, Length(Result) + 1);
      Result[High(Result)] := duplicates[i][j];
    end;
  end;
end;

var
  theArray, strings: Array of String;
  i: Integer;
begin
  ClearDebug;
  strings := ['Chair', 'Bed', 'Cabnet', 'Tape', 'Book', 'Lamp', 'Light',
              'Table', 'Shelf', 'Door', 'Binder'];
    
  theArray := alpha_SortStringArray(strings);
  for i := 0 to High(theArray) do
    Writeln(theArray[i]);
end.

Thanks in advance,
Coh3n

Best way to do it would probably be with a recursive algorithm to sort through a single index and move through it that way.

Not really 100% how to do it, I wish I could help you out more though.

program New;


  function QueryPerformanceFrequency(out Frequency: Int64): LongBool; external 'QueryPerformanceFrequency@kernel32.dll stdcall';
  function QueryPerformanceCounter(out Counter: Int64): LongBool; external 'QueryPerformanceCounter@kernel32.dll stdcall';

procedure MarkTime(var Time: Int64);
var
  Freq: Int64;
begin
  if QueryPerformanceFrequency(Freq) then
    QueryPerformanceCounter(Time)
  else
    Time := GetTickCount;
end;

function TimeFromMark(Mark: Int64): Double;
var
  Freq, Now: Int64;
begin
  if QueryPerformanceFrequency(Freq) then
  begin
    QueryPerformanceCounter(Now);
    Result := ((Now - Mark) / Freq) * 1000;
  end
  else
    Result := (GetTickCount - Mark);
end;


function MatchCount(Match, Str: string): Integer;
var
  p: Integer;
begin
  Result := 0;
  p := Pos(Match, Str);
  while (p > 0) do
  begin
    Inc(Result);
    p := PosEx(Match, Str, p + 1);
  end;
end;

(*function WordCount(Str: string): Integer;
{$IFNDEF SCAR320_UP}
var
  InWord: Boolean;
  i, l: Integer;
{$ENDIF}
begin
{$IFNDEF SCAR320_UP}
  Result := 0;
  i := 1;
  l := Length(Str);
  while (i <= l) do
  begin
    case Str[i] of
      'a'..'z', 'A'..'Z', '0'..'9':
        InWord := True;
      '_':
        if InWord then
          while (i < l) do
          begin
            Inc(i);
            case Str[i] of
              //'_': {nothing};
              'a'..'z', 'A'..'Z', '0'..'9':
                Break;
              else if (Str[i] <> '_') then
                begin
                  Inc(Result);
                  InWord := False;
                  Break;
                end;
            end;
          end;
      else if InWord then
      begin
        InWord := False;
        Inc(Result);
      end;
    end;
    Inc(i);
  end;
  if InWord then
    Inc(Result);
{$ELSE}
  Result := Length(GetNumbers(ReplaceRegex(ReplaceRegex(Str, '\W+', ' '), '\w+', '1')));
{$ENDIF}
end;  *)

function WordCount(Str: string): Integer;
var
  i: Integer;
  s: TStringArray;
begin
  Result := 0;
  s := Explode(' ', Str);

  for i := High(s) downto 0 do
    if (s[i] <> '') then
      Inc(Result);
end;

function AlphaIndexSort(InputString: TStringArray; InputIndex: TIntegerArray; Offset: Integer; CaseInsensitive: Boolean): TIntegerArray;
var
  i, ii, l: Integer;
  Input_Int: array of Word;

  {
    non AlphaNumeric 0..1, Numberic 2..11, Alpha UP 12..37, Alpha LO 38..63
    //CaseInsensitive: Alpha UP + LO combined -> AaBbCcDd
    CaseInsensitive: LO = UP
  }
  Output_Int: array[0..63] of record
    Index: TIntegerArray;
    Len: Integer;
  end;
  tmp: TIntegerArray;
  c: Char;
  s: string;
begin
  l := High(InputIndex);
  SetLength(Input_Int, l + 1);
  SetLength(Result, l + 1);
  if (Offset <= 0) then
    Offset := 1;

  for i := l downto 0 do
  begin
    if (Offset > Length(InputString[InputIndex[i]])) then
    begin
      Input_Int[i] := 0;
      Continue;
    end;
    c := InputString[InputIndex[i]][Offset];

    case c of
      'a'..'z':
        if CaseInsensitive then
          Input_Int[i] := ((Ord(c) - {97}85) {shl 1}) {+ 13}
        else
          Input_Int[i] := Ord(c) - 59;
      'A'..'Z':
        if CaseInsensitive then
          Input_Int[i] := ((Ord(c) - {65}53) {shl 1}) {+ 12}
        else
          Input_Int[i] := Ord(c) - 53;
      '0'..'9':
        Input_Int[i] := Ord(c) - 46;
      else
        Input_Int[i] := 1;
    end;
  end;

  for i := l downto 0 do
    with Output_Int[Input_Int[i]] do
    begin
      SetLength(Index, Len + 1);
      Index[Len] := InputIndex[i];
      Len := Len + 1;
    end;

  for i := 0 to 63 do
    with Output_Int[i] do
      if (Len > 1) then
      begin
        if CaseInsensitive then
        begin
          s := UpperCase(TrimOthers(InputString[Index[0]]));
          for ii := Len - 1 downto 1 do
            if (UpperCase(TrimOthers(InputString[Index[ii]])) <> s) then
              Break;
        end
        else
        begin
          s := TrimOthers(InputString[Index[0]]);
          for ii := Len - 1 downto 1 do
            if (TrimOthers(InputString[Index[ii]]) <> s) then
              Break;
        end;
        if (ii > 0) then
        begin
          tmp := AlphaIndexSort(InputString, Index, Offset + 1, CaseInsensitive);
          Index := tmp;
        end;
      end;

  l := 0;
  for i := 0 to 63 do
    with Output_Int[i] do
      if (Len > 0) then
        for ii := 0 to Len - 1 do
        begin
          Result[l] := Index[ii];
          l := l + 1;
        end;
end;

function StringSort(Input: TStringArray; SortMethod: (smAlpha, smWordCount, smMatchCount); MatchStr: string; CaseInsensitive: Boolean): TStringArray;
var
  i, ii, l, m: Integer;
  Input_Int: TIntegerArray;
  Output_Int: array of record
    Index: TIntegerArray;
    Len: Integer;
  end;
  tmp: TIntegerArray;
  Match: string;
begin
  l := High(Input);
  m := 0;
  SetLength(Input_Int, l + 1);
  SetLength(Result, l + 1);

  case SortMethod of
    smAlpha:
      begin
        for i := l downto 0 do
          Input_Int[i] := i;
        Input_Int := AlphaIndexSort(Input, Input_Int, 1, CaseInsensitive);
        for i := l downto 0 do
          Result[i] := Input[Input_Int[i]];
        Exit;
      end;
    smWordCount:
      for i := l downto 0 do
      begin
        Input_Int[i] := WordCount(Input[i]);
        if (Input_Int[i] > m) then
          m := Input_Int[i];
      end;
    smMatchCount:
      begin
        if CaseInsensitive then
          Match := UpperCase(MatchStr)
        else
          Match := MatchStr;
        for i := l downto 0 do
        begin
          if CaseInsensitive then
            Input_Int[i] := MatchCount(Match, UpperCase(Input[i]))
          else
            Input_Int[i] := MatchCount(Match, Input[i]);
          if (Input_Int[i] > m) then
            m := Input_Int[i];
        end;
      end;
    else
      begin
        WriteLn('Invalid SortMethod used in StringSort!');
        Exit;
      end;
  end;

  SetLength(Output_Int, m + 1);

  for i := l downto 0 do
    with Output_Int[Input_Int[i]] do
    begin
      SetLength(Index, Len + 1);
      Index[Len] := i;
      Len := Len + 1;
    end;

  for i := 0 to m do
    with Output_Int[i] do
      if (Len > 1) then
      begin
        Match := UpperCase(TrimOthers(Input[Index[0]]));
        if CaseInsensitive then
        begin
          for ii := Len - 1 downto 1 do
            if (UpperCase(TrimOthers(Input[Index[ii]])) <> Match) then
              Break;
        end
        else
        begin
          Match := TrimOthers(Input[Index[0]]);
          for ii := Len - 1 downto 1 do
            if (TrimOthers(Input[Index[ii]]) <> Match) then
              Break;
        end;
        if (ii > 0) then
        begin
          tmp := AlphaIndexSort(Input, Index, 1, CaseInsensitive);
          Index := tmp;
        end;
      end;

  l := 0;
  for i := m downto 0 do
    with Output_Int[i] do
      if (Len > 0) then
        for ii := 0 to Len - 1 do
        begin
          Result[l] := Input[Index[ii]];
          l := l + 1;
        end;
end;


var
  s, ss: TStringArray;
  i: Integer;
  t: Int64;
begin
  //s := ['z', 'y', 'x', 'Z', 'Y', 'X', 'a', 'b', 'c', 'aa', 'aa', 'ab', 'aaaa', 'aaaa', '.abc', '.0123', '=abcdef', '987', '654', '05', '987A', '987.'];
  s := ['say lol 1', 'h^ehehe', 's.ay ONE two three', 'say lol', 'say heho! (not!)', 'Hey', 'Hello', 'Hai', 'Hoi ', 'hello', 'hEY', 'hello', 'Hoi', '.lo l123', '.lol ', '.lol.', '.lolA', '.lola', '.567', '567', '0123', '...lol', 'bye', 'cya', 'zebra', 'ZONK!'];

  MarkTime(t);
  for i := 1 to 50 do
    ss := StringSort(s, smAlpha, 'he', False);
  WriteLn(FloatToStr(TimeFromMark(t) / 50.0)+' ms.');

  ClearReport;
  for i := 0 to High(ss) do
    AddToReport(ss[i]);
end.

I believe this was for some competition, but it might be a bit overkill for a school assignment, though. Recursive would indeed be a good way to do it. What the script above does (AlphaIndexSort) is place all strings in an array according to their startletter. If an array for a certain startletter is larger than 1, you'll have to sort that array on the next letter.

From: Nava2
Best way to do it would probably be with a recursive algorithm to sort through a single index and move through it that way.

Not really 100% how to do it, I wish I could help you out more though.

That's what I was thinking, I was just hoping there was an easier way that I wasn't thinking of. Lol.

From: nielsie95
I believe this was for some competition, but it might be a bit overkill for a school assignment, though. Recursive would indeed be a good way to do it. What the script above does (AlphaIndexSort) is place all strings in an array according to their startletter. If an array for a certain startletter is larger than 1, you'll have to sort that array on the next letter.

Thanks for that, I can't use it exactly because I have to write all the code myself, but at least I have something to refer to if needed. Just looking at it gave me a couple ideas. Hopefully I can make it work. :)

Find length of string a
Find length of string b
Work length is shorter of the two
Counter = one to work length
Compare letter (counter) of string a to letter (counter) of string b
if identical, increment counter and repeat.
if no match at the end of the counter loop, then the shorter comes first. ("Nothing" comes before "something" when alphabetizing)

For the third string, you would have to advance through all the already alphabetized strings one at a time and compare them until you found the slot where it fits.

Hope this helps.

Sometimes you can just use math operators, I'm not sure if this is possible here. For example you can say
IF (stringA<stringB) THEN

From: jimthesoundman
Find length of string a
Find length of string b
Work length is shorter of the two
Counter = one to work length
Compare letter (counter) of string a to letter (counter) of string b
if identical, increment counter and repeat.
if no match at the end of the counter loop, then the shorter comes first. ("Nothing" comes before "something" when alphabetizing)

For the third string, you would have to advance through all the already alphabetized strings one at a time and compare them until you found the slot where it fits.

Hope this helps.

Sometimes you can just use math operators, I'm not sure if this is possible here. For example you can say
IF (stringA<stringB) THEN

I have no idea what you mean. :confused:

I've updated the first post with what I have now. It works for the first two letters in the string. I just need help to make it keep checking the next letter if needed.

Recursion recursion recursion!

Simply produce a function like so:

function: IsBefore(str1, str2: string; p: Integer): Boolean;
begin
  if (str1[p] = str2[p]) then
    Result := IsBefore(str1, str2, p + 1)
  else
    Result := Ord(str1[p]) < Ord(str2[p]); // You probably want a more comprehensive check here
end;

Then voila, you can compare 2 strings of an unknown length (you probably also want a check to make sure you don't go out of string range).

From: mixster
Recursion recursion recursion!

Simply produce a function like so:

function: IsBefore(str1, str2: string; p: Integer): Boolean;
begin
  if (str1[p] = str2[p]) then
    Result := IsBefore(str1, str2, p + 1)
  else
    Result := Ord(str1[p]) < Ord(str2[p]); // You probably want a more comprehensive check here
end;

Then voila, you can compare 2 strings of an unknown length (you probably also want a check to make sure you don't go out of string range).

I'm not sure how I could use that though. :confused: I've been trying to do this for hours, so I probably just can't think.

From: Coh3n
I'm not sure how I could use that though. :confused: I've been trying to do this for hours, so I probably just can't think.

Use in combination with quicksort, where the normal ">/<" comparison would be replaced with this (or a similar) function.

Delphi/FPC has a method (that mixster kinda created), its called "CompareStr" -> http://www.freepascal.org/docs-html/rtl/sysutils/comparestr.html

I believe it should actually work just like that (on a basic level of course). What it does is compare the chars at position p in strings str1 and str2. If they're the same, then it compares the next char, which is at position p + 1. If they're the same, then it compares the next char at p + 2 and so on. If they're not the same, then it returns true if the compared char is a smaller value for str1 (ie str1 comes before str2 in an alphabetic list).

From: mastaraymond
Use in combination with quicksort, where the normal ">/<" comparison would be replaced with this (or a similar) function.

Delphi/FPC has a method (that mixster kinda created), its called "CompareStr" -> http://www.freepascal.org/docs-html/rtl/sysutils/comparestr.html

From: mixster
I believe it should actually work just like that (on a basic level of course). What it does is compare the chars at position p in strings str1 and str2. If they're the same, then it compares the next char, which is at position p + 1. If they're the same, then it compares the next char at p + 2 and so on. If they're not the same, then it returns true if the compared char is a smaller value for str1 (ie str1 comes before str2 in an alphabetic list).

Ohhh okay. I didn't really understand the recursion concept, but that helped a lot.

Thanks guys, I think I know how I can use this to finish up :p