Lazarus в Windows - неполадки в сравнении строк

[slyubez]

Приветствую всех.

Встала задача работы со строками в UTF8 с выдергиванием отдельных символов. Программа будет работать под Windows.
Приведу такой тестовый код.

Код: Выделить всё

uses LazUTF8;
...
procedure TForm1.FormShow(Sender: TObject);
const
SRC1 = 'РАБОТА';
var s: String;
begin
s:=UTF8Copy(SRC1, 3, 1);
if s='Б'
  then ShowMessage ('Равно')
  else ShowMessage ('Не равно');
end;   

На старом Lazarus 2.0.12 все работает четко, а на версиях 3.2.х код выдает "Не равно", причем отладчик показывает одни и те же символы. Может быть, кто-нибудь знает, что может быть?

[Sharfik]

Половина когда UTF8, половина кода ANSI формата. Насколько помню laz 3.2 уже без разницы, и он все автоматом конвертирует в UTF8, но все же.
Ему должно быть без разницы Copy или UTFCopy. Я об этом. Но раз используется правильная функция, то и сравнивать стоит через UTF8CompareStr
И желательно расставить begin-end в условиях. У меня было, что без них неправильно работало условие.
*проверить сейчас не где, на работе

[slyubez]

Насколько помню laz 3.2 уже без разницы, и он все автоматом конвертирует в UTF8, но все же.

Все строки, используемые мной - UTF8. И Лазарь 2.0... это воспринимал как надо. А тут такая засада. И насколько я понимаю, там отнюдь не ANSI.

Добавлено спустя 35 секунд:
С UTF8CompareStr попробую. Спасибо за подсказку.

Добавлено спустя 7 минут 13 секунд:

Ему должно быть без разницы Copy или UTFCopy. Я об этом.

А разве Copy не по байту берет? Я использую UTF8Copy и UTF8Length, чтобы получать символы вне зависимости от их размера.

[xchgeaxeax]

А разве Copy не по байту берет?

Вот именно. В Copy придется указывать индекс в байтах от начала строки, а UTF8Copy примет его в символах.

Как вариант вы можете задать константу явного типа при использовании =

Код: Выделить всё

procedure TForm1.FormShow(Sender: TObject);
const
SRC1: UTF8String = 'РАБОТА';
COMP: UTF8String = 'Б';
var s: UTF8String;
begin
s:=UTF8Copy(SRC1, 3, 1);
if s=COMP
  then ShowMessage ('Равно')
  else ShowMessage ('Не равно');
end;

[slyubez]

Я просто привел тестовый пример, направленный на то, чтобы показать баг. Но когда я немного раньше экспериментировал со своим кодом (это не показано), я попробовал использовать функцию Length к строке s, и она показала два байта. Почему получается не равно, я так и не понял.

[iskander]

На старом Lazarus 2.0.12 все работает четко, а на версиях 3.2.х код выдает

Так текущая релизная версия Лазаря как бы 4.0.

Код: Выделить всё

procedure TForm1.Button1Click(Sender: TObject);
const
  SRC1 = 'РАБОТА';
var
  s: string;
begin
  s := UTF8Copy(SRC1, 3, 1);
  if s = 'Б' then
    ShowMessage ('Равно')
  else
    ShowMessage ('Не равно');
end;


Lazarus 4.0-win64 говорит "Равно".

[slyubez]

Посмотрю более точно дома, на какой версии всплыл косяк.

[Alexander]

В моём новом органайзере есть экспериментальный сортировщик во многом написанный ИИ и чуть-чуть вручную. http://soft.self-made-free.ru/GORG64_474.tar.xz директория sortucs4-src. Может быть это направление пригодиться. Там свежий LazUTF8 (он заметно крупнее старого), юниты и тесты скорости ucs4 и сам сортировщик. Принцип такой: вначале переводится из utf8 в utf32/ucs4, а затем легко адресуется посимвольно, затем обратно в utf8 (если требуется).

[iskander]

В моём новом органайзере есть экспериментальный сортировщик во многом написанный ИИ

Имхо щит-гопота решила постебаться.

[Alexander]

Что за живность? За борт.

[iskander]

... щит-гопота ...

Что за живность?

ChatGPT и иже с нею.

За борт.

Поддерживаю.

[Alexander]

То был https://chat.deepseek.com/ . Но ведь работает при этом.

[iskander]

То был https://chat.deepseek.com/

А какая разница(c)

Но ведь работает при этом.

На утечки памяти проверялось?

Напоминает FizzBuzz Enterprise Edition.
То что нагородил ди-псих можно заменить двумя строчками(в транковом FPC одной), при этом будет работать значительно быстрее.

Добавлено спустя 22 часа 20 минут 40 секунд:

То что нагородил ди-псих можно заменить двумя строчками(в транковом FPC одной), при этом будет работать значительно быстрее.

Поделие ди-психа это сплошная утечка памяти.
Если это исправить, то программа из двух строчек сортирует список из 1000 слов в семь с лишним тысяч раз быстрее, чем психокод.

[Alexander]

Ну для соревнований на скорость эта версия была явно не пригодной. Это была экспериментальная версия с сортировкой "пузырьком". Показал её только потому, что был задан этот вопрос.

Я изменил подход к работе кода - теперь там более явно используется ucs4 и код стал в целом стройнее и снова запустил deepseek.com с одной задачей: заменить "пузырьком" на QuickSort. Заодно сделан шаг от экспериментальной в сторону бета версии. В таком виде можно и по скоростям соревнование устроить - это интересная мысль. Так что я жду здесь те самые "две строчки" кода с которыми можно устроить соревнование. Это так же улучшит ответ на заданный вопрос, показав разные пути к его решению.

Код: Выделить всё

program sortucs4;

{$MODE OBJFPC}{$H+}
{$CODEPAGE UTF8}
{$INLINE ON}
// GNU AGPLv3
uses
  SysUtils, ucs4unit, ucs4opunit, LazUTF8, Math;

type
  TSortOptions = record
    InputFile: string;
    IsTable: Boolean;
    ColumnIndex: LongInt;
    Delimiter: ucs4;
  end;

  TSortItem = record
    s: string;
    u: ucs4;
  end;

  TSortItems = array of TSortItem;

  TCmpResult = (crBelow, crEqual, crAbove);

var
  Options: TSortOptions;
  Lines: TSortItems;

procedure PrintHelp;
begin
  Writeln('Использование:');
  Writeln('  sortucs4 - выводит эту справку');
  Writeln('  sortucs4 <файл> - сортирует строки файла UTF-8');
  Writeln('  sortucs4 <файл> <столбец> - сортирует таблицу (разделитель - табуляция) по указанному столбцу');
  Writeln('  sortucs4 <файл> <столбец> <разделитель> - сортирует таблицу с указанным разделителем');
end;

function ParseCommandLine: TSortOptions;
begin
  Result.InputFile := '';
  Result.IsTable := False;
  Result.ColumnIndex := 0;

  if ParamCount = 0 then Exit;

  Result.InputFile := ParamStr(1);

  if ParamCount >= 2 then
  begin
    Result.IsTable := True;
    if not TryStrToInt(ParamStr(2), Result.ColumnIndex) then
    begin
      Writeln('Ошибка: номер столбца должен быть целым числом');
      Halt(1);
    end;
    Result.ColumnIndex := Result.ColumnIndex - 1; // Переводим в 0-based индекс
  end;

  if ParamCount >= 3 then
  begin
    Result.Delimiter := ParamStr(3);
  end else Result.Delimiter := #9;
end;

function ExtractField(const Line: string): ucs4; register;
var
  ucsLine: ucs4;
  StartPos, EndPos, FieldCount, i: LongInt;
begin
  ucsLine := Line;
  Result.Init;

  StartPos := 0;
  FieldCount := 0;
  for i := 0 to ucsLine.Length - 1 do
  begin
    if ucsLine[i] = options.Delimiter[0] then
    begin
      if FieldCount = options.ColumnIndex then begin
        for EndPos := StartPos to i - 1 do
          Result := Result + ucsLine[EndPos];
        Exit;
      end;
      Inc(FieldCount);
      StartPos := i + 1;
    end;
  end;

  // Добавляем последнее поле
  if FieldCount = options.ColumnIndex then begin
    for EndPos := StartPos to ucsLine.Length - 1 do
      Result := Result + ucsLine[EndPos];
  end;
end;

function ReadLines(const FileName: string): TSortItems;
var
  F: TextFile;
  Line: string;
  Count: LongInt;
begin
  Result := nil;
  if not FileExists(FileName) then
  begin
    Writeln('Ошибка: файл не найден');
    Halt(1);
  end;

  AssignFile(F, FileName);
  Reset(F);
  try
    Count := 0;
    while not Eof(F) do
    begin
      Readln(F, Line);
      Inc(Count);
    end;

    WriteLn('Файл содержит ', Count, ' строк');

    if Count < 2 then begin
      CloseFile(F);
      Halt(0);
    end;

    SetLength(Result, Count);
    Reset(F);
    Count := 0;

    if options.IsTable then begin
      while not Eof(F) do
      begin
        Readln(F, Line);
        Result[Count].s := Line;
        Result[Count].u := ExtractField(Line);
        Inc(Count);
      end;
    end else begin
      while not Eof(F) do
      begin
        Readln(F, Line);
        Result[Count].s := Line;
        Result[Count].u := Line;
        Inc(Count);
      end;
    end;

  finally
    CloseFile(F);
  end;
end;

function CompareLines(const a, b: ucs4): TCmpResult; register;
var
  i: LongInt;
begin
  // Сравниваем посимвольно
  for i := 0 to Min(a.Length, b.Length) - 1 do
  begin
    if a[i] < b[i] then Exit(crBelow);
    if a[i] > b[i] then Exit(crAbove);
  end;
 
  // Если все символы совпадают, более короткая строка считается меньшей
  if a.Length < b.Length then Exit(crBelow);
  if a.Length > b.Length then Exit(crAbove);
 
  Exit(crEqual);
end;

// Процедура для быстрой сортировки (QuickSort)
procedure QuickSort(var A: TSortItems; L, R: LongInt); inline;
var
  I, J: LongInt;
  Pivot: ucs4;
  Temp: TSortItem;
begin
  if L >= R then Exit;
 
  I := L;
  J := R;
  Pivot := A[(L + R) div 2].u;
 
  repeat
    while CompareLines(A[I].u, Pivot) = crBelow do Inc(I);
    while CompareLines(A[J].u, Pivot) = crAbove do Dec(J);
   
    if I <= J then
    begin
      if I < J then
      begin
        Temp := A[I];
        A[I] := A[J];
        A[J] := Temp;
      end;
      Inc(I);
      Dec(J);
    end;
  until I > J;
 
  if L < J then QuickSort(A, L, J);
  if I < R then QuickSort(A, I, R);
end;

procedure SortLines(var Lines: TSortItems);
begin
  if Length(Lines) < 2 then Exit;
  QuickSort(Lines, 0, High(Lines));
end;

var
  fp: TextFile;
  f: Int64;
begin
  if ParamCount = 0 then
  begin
    PrintHelp;
    Halt(0);
  end;

  Options := ParseCommandLine;
  Lines := ReadLines(Options.InputFile);

  WriteLn('Файл загружен в память. Начинается сортировка.');

  SortLines(Lines);

  // Запись обратно в файл
  AssignFile(fp, Options.InputFile);
  try
    ReWrite(fp); // Открываем файл для перезаписи
    for f := 0 to High(Lines)-1 do begin
      WriteLn(fp, Lines[f].s);
    end;
    Write(fp, Lines[High(Lines)].s);
  finally
    CloseFile(fp);
  end;
 
  Writeln('Файл "', Options.InputFile, '" успешно отсортирован.');
end.

Код: Выделить всё

unit ucs4unit;

{$MODE OBJFPC}{$H+}
{$RANGECHECKS ON}
{$OPTIMIZATION LEVEL3}
{$INLINE ON}
// GNU AGPLv3
interface

uses SysUtils, LazUTF8;

type
  ucs4 = packed object
  private
    FData: PDWord;
    FLength: DWord;
    FCapacity: DWord;
    procedure Grow(MinCapacity: DWord); inline;
    function GetChar(Index: DWord): DWord; inline;
    procedure SetChar(Index: DWord; Value: Dword); inline;
  public
    property Length: DWord read FLength;
    property Chars[Index: DWord]: DWord read GetChar write SetChar; default;
   
    procedure Init; inline;
    procedure Init(l:DWord); inline;
    procedure Clear; inline;
    procedure Reverse;
    function IsRTL: Boolean;
    function Concat(const S: ucs4): ucs4;
    procedure FromUTF8(const S: string);
    function ToUTF8: string;
  end;

implementation

procedure ucs4.Init;
begin
  FData := nil;
  FLength := 0;
  FCapacity := 0;
end;

procedure ucs4.Init(l:DWord);
begin
  FLength := l;
  FCapacity := l;
  FData := GetMem(l);
end;

procedure ucs4.Grow(MinCapacity: DWord);
var
  NewCapacity: DWord;
begin
  if FCapacity = 0 then
    NewCapacity := 8
  else
    NewCapacity := FCapacity * 2;
   
  if NewCapacity < MinCapacity then
    NewCapacity := MinCapacity;
   
  ReallocMem(FData, NewCapacity * SizeOf(DWord));
  FCapacity := NewCapacity;
end;

function ucs4.GetChar(Index: DWord): DWord; inline;
begin
  {$IFDEF RANGECHECKS}
  if Index >= FLength then
    raise Exception.Create('Index out of bounds');
  {$ENDIF}
Exit(FData[Index]);
end;

procedure ucs4.SetChar(Index: DWord; Value: Dword); inline;
begin
  {$IFDEF RANGECHECKS}
  if Index >= FLength then
    raise Exception.Create('Index out of bounds');
  {$ENDIF}
FData[Index] := Value;
end;

procedure ucs4.Clear;
begin
  if FData <> nil then
  begin
    FreeMem(FData);
    FData := nil;
  end;
  FLength := 0;
  FCapacity := 0;
end;

procedure ucs4.Reverse;
var
  I: DWord;
  Tmp: DWord;
  P1, P2: PDWord;
begin
  if FLength <= 1 then Exit;
 
  P1 := @FData[0];
  P2 := @FData[FLength-1];
 
  while P1 < P2 do
  begin
    Tmp := P1^;
    P1^ := P2^;
    P2^ := Tmp;
    Inc(P1);
    Dec(P2);
  end;
end;

function ucs4.IsRTL: Boolean;
var
  I: DWord;
begin
  for I := 0 to FLength - 1 do
    if (FData[I] >= $0590) and (FData[I] <= $08FF) then
      Exit(True);
  Result := False;
end;

function ucs4.Concat(const S: ucs4): ucs4;
begin
  Result.Init;
  if Self.FLength + S.FLength = 0 then Exit;
 
  GetMem(Result.FData, (Self.FLength + S.FLength) * SizeOf(DWord));
  Result.FCapacity := Self.FLength + S.FLength;
  Result.FLength := Result.FCapacity;
 
  if Self.FLength > 0 then
    Move(Self.FData^, Result.FData^, Self.FLength * SizeOf(DWord));
   
  if S.FLength > 0 then
    Move(S.FData^, Result.FData[Self.FLength], S.FLength * SizeOf(DWord));
end;

procedure ucs4.FromUTF8(const S: string);
var
  UTF8Ptr: PChar;
  CharLen: Integer;
  Count, Pos: DWord;
begin
  Clear;
  if S = '' then Exit;

  // Первый проход - подсчет символов
  Count := 0;
  UTF8Ptr := PChar(S);
  while UTF8Ptr^ <> #0 do
  begin
    UTF8CodepointToUnicode(UTF8Ptr, CharLen);
    Inc(UTF8Ptr, CharLen);
    Inc(Count);
  end;

  // Выделение памяти
  if Count > FCapacity then
    Grow(Count);
  FLength := Count;

  // Второй проход - заполнение
  UTF8Ptr := PChar(S);
  Pos := 0;
  while UTF8Ptr^ <> #0 do
  begin
    FData[Pos] := UTF8CodepointToUnicode(UTF8Ptr, CharLen);
    Inc(UTF8Ptr, CharLen);
    Inc(Pos);
  end;
end;

function ucs4.ToUTF8: string;
var
  I, Len: Integer;
  P: PChar;
begin
  if FLength = 0 then Exit('');

  // Максимально возможный размер (4 байта на символ)
  SetLength(Result, FLength * 4);
  P := PChar(Result);
 
  for I := 0 to FLength - 1 do
    Inc(P, UnicodeToUTF8(FData[I], P));
 
  // Корректируем длину под реальный размер
  SetLength(Result, P - PChar(Result));
end;

end.


Код: Выделить всё

unit ucs4opunit;

{$MODE OBJFPC}{$H+}
{$RANGECHECKS ON}
{$OPTIMIZATION LEVEL3}
{$INLINE ON}
{$CODEPAGE UTF8}
// GNU AGPLv3
interface

uses ucs4unit;

operator = (s1,s2:ucs4)r:bytebool;
operator = (s1:ucs4;s2:string)r:bytebool;
operator + (s1,s2:ucs4)r:ucs4;
operator + (s:ucs4;c:DWord)r:ucs4;
operator := (const s: utf8string)r:ucs4;

implementation

operator = (s1,s2:ucs4)r:bytebool;
var f:LongInt;
begin
if s1.Length <> s2.Length then Exit(false);
for f := 0 to s1.Length-1 do if s1[f] <> s2[f] then Exit(false);
Exit(true);
end;

operator = (s1:ucs4;s2:string)r:bytebool;
var tmp:ucs4;
begin
tmp.Init;
tmp.FromUTF8(s2);
r:= s1=tmp;
tmp.Clear;
end;

operator + (s1,s2:ucs4)r:ucs4;
begin
Exit(s1.Concat(s2));
end;

operator + (s:ucs4;c:DWord)r:ucs4;
var tmp:ucs4;
begin
tmp.Init(1);
tmp[0]:=c;
r := s.Concat(tmp);
tmp.Clear;
end;

operator := (const s: utf8string)r:ucs4;
begin
r.Init;
r.FromUTF8(s);
end;

end.


[iskander]

Ну для соревнований на скорость эта версия была явно не пригодной. Это была экспериментальная версия с сортировкой "пузырьком".

Меня больше удивили компараторы, бессмысленные, но совершенно беспощадные.
Для сортировки UTF-8 строк в лексикографическом порядке(кодовых точек) вполне достаточно сравнивать их побайтно.

Так что я жду здесь те самые "две строчки" кода с которыми можно устроить соревнование.

Для этого крайне желательно выделить сортировщик в регулярную процедуру, да и утечки памяти никак пока волшебным образом не рассосались.
Так что я тоже жду исправлений, а пока в аттаче только сравнение исправленной первоначальной версии от ди-психа(две строчки выделены комментами).
Его результат на встроенном наборе данных на win64 машине(Dp - аббревиатура ди-псих):

Код: Выделить всё

Сортировка строк:
  DpSort: 3508,8057 мс
  GcSort: 0,3069 мс
  Результаты совпадают

Сортировка таблицы:
  DpSort: 248972,8733 мс
  GcSort: 3,1576 мс
  Результаты совпадают