Работа со строками

Code:

//Функция нечеткого сравнения строк БЕЗ УЧЕТА РЕГИСТРА

//------------------------------------------------------------------------------

//MaxMatching - максимальная длина подстроки (достаточно 3-4)

//strInputMatching - сравниваемая строка

//strInputStandart - строка-образец

// Сравнивание без учета регистра

// if IndistinctMatching(4, "поисковая строка", "оригинальная строка - эталон") > 40 then ...

type

TRetCount = packedrecord

lngSubRows: Word;

lngCountLike: Word;

end;

//------------------------------------------------------------------------------

function Matching(StrInputA: WideString;

StrInputB: WideString;

lngLen: Integer): TRetCount;

var

TempRet: TRetCount;

PosStrB: Integer;

PosStrA: Integer;

StrA: WideString;

StrB: WideString;

StrTempA: WideString;

StrTempB: WideString;

begin

StrA := string(StrInputA);

StrB := string(StrInputB);

for PosStrA := 1to Length(strA) - lngLen + 1do

begin

StrTempA := System.Copy(strA, PosStrA, lngLen);

PosStrB := 1;

for PosStrB := 1to Length(strB) - lngLen + 1do

begin

StrTempB := System.Copy(strB, PosStrB, lngLen);

if SysUtils.AnsiCompareText(StrTempA, StrTempB) = 0then

begin

Inc(TempRet.lngCountLike);

break;

end;

end;

Inc(TempRet.lngSubRows);

end; // PosStrA

Matching.lngCountLike := TempRet.lngCountLike;

Matching.lngSubRows := TempRet.lngSubRows;

end; { function }

//------------------------------------------------------------------------------

function IndistinctMatching(MaxMatching: Integer;

strInputMatching: WideString;

strInputStandart: WideString): Integer;

var

gret: TRetCount;

tret: TRetCount;

lngCurLen: Integer; //текущая длина подстроки

begin

//если не передан какой-либо параметр, то выход

if (MaxMatching = 0) or (Length(strInputMatching) = 0) or

(Length(strInputStandart) = 0) then

begin

IndistinctMatching := 0;

exit;

end;

gret.lngCountLike := 0;

gret.lngSubRows := 0;

// Цикл прохода по длине сравниваемой фразы

for lngCurLen := 1to MaxMatching do

begin

//Сравниваем строку A со строкой B

tret := Matching(strInputMatching, strInputStandart, lngCurLen);

gret.lngCountLike := gret.lngCountLike + tret.lngCountLike;

gret.lngSubRows := gret.lngSubRows + tret.lngSubRows;

//Сравниваем строку B со строкой A

tret := Matching(strInputStandart, strInputMatching, lngCurLen);

gret.lngCountLike := gret.lngCountLike + tret.lngCountLike;

gret.lngSubRows := gret.lngSubRows + tret.lngSubRows;

end;

if gret.lngSubRows = 0then

begin

IndistinctMatching := 0;

exit;

end;

IndistinctMatching := Trunc((gret.lngCountLike / gret.lngSubRows) * 100);

end;

Code:

uses

Math;

function DoStringMatch(s1, s2: string): Double;

var

i, iMin, iMax, iSameCount: Integer;

begin

iMax := Max(Length(s1), Length(s2));

iMin := Min(Length(s1), Length(s2));

iSameCount := -1;

for i := 0to iMax do

begin

if i > iMin then

break;

if s1[i] = s2[i] then

Inc(iSameCount)

else

break;

end;

if iSameCount > 0then

Result := (iSameCount / iMax) * 100

else

Result := 0.00;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

match: Double;

begin

match := DoStringMatch('SwissDelphiCenter', 'SwissDelphiCenter.ch');

ShowMessage(FloatToStr(match) + ' % match.');

// Resultat: 85%

// Result : 85%

end;

Code:

{ **** UBPFD *********** by delphibase.endimus  ****

>> Быстрые функции сжатия пробелов и управляющих символов в строке.

Функции удаляют из строки начальные и конечные пробелы и управляющие

символы (меньшие пробела). Идущие подряд пробелы и управляющие символы

в середине строки заменяются одним пробелом.

Зависимости: нет

Автор: Александр Шарахов, alsha @ mailru.com, Москва

Copyright: Александр Шарахов

***************************************************** }

// Sha_SpaceCompress удаляет из Ansi-строки начальные и конечные пробелы

// и управляющие символы (меньшие пробела). Идущие подряд пробелы

// и управляющие символы в середине строки заменяются одним пробелом.

// Исходная строка при этом не изменяется. Эта функция работает

// медленнее, чем Sha_SpaceCompressInplace. С целью ускорения работы

// освобождение неиспользуемой памяти за пределами строки не производится.

// Если это критично, после вызова данной функции можно освободить память

// следующим образом: s2:=Sha_SpaceCompress(s1); SetLength(s2,Length(s2));

// Функция не работает, если нарушен формат Ansi-строки, в частности,

// если в конце строки отсутствует терминатор.

function Sha_SpaceCompress(const s: string): string;

var

p, q, t: pchar;

ch: char;

label

rt;

begin

;

p := pointer(s);

q := nil;

if p <> nilthen

begin

;

t := p + (pinteger(p - 4))^;

if p < t then

begin

;

repeat;

dec(t);

if p > t then

goto rt;

until (t^ > ' ');

SetString(Result, nil, (t - p) + 1);

q := pchar(pointer(Result));

repeat;

repeat;

ch := p^;

inc(p);

until ch > ' ';

repeat;

q^ := ch;

ch := p^;

inc(q);

inc(p);

until ch <= ' ';

q^ := ' ';

inc(q);

until p > t;

end;

end;

rt:

if q <> nilthen

begin

;

dec(q);

q^ := #0;

(pinteger(pchar(pointer(Result)) - 4))^ := q - pointer(Result);

end

else

Result := '';

end;

// Sha_SpaceCompressInplace удаляет из Ansi-строки начальные и конечные пробелы

// и управляющие символы (меньшие пробела). Идущие подряд пробелы

// и управляющие символы в середине строки заменяются одним пробелом.

// Результат замещает исходную строку. С целью ускорения работы

// освобождение неиспользуемой памяти за пределами строки не производится.

// Если это критично, после вызова данной функции можно освободить память

// следующим образом: Sha_SpaceCompressInpace(s); SetLength(s,Length(s));

// Процедура не работает, если нарушен формат Ansi-строки, в частности,

// если в конце строки отсутствует терминатор.

procedure Sha_SpaceCompressInplace(var s: string);

var

p, q, t: pchar;

ch: char;

label

rt;

begin

;

UniqueString(s);

p := pointer(s);

if p <> nilthen

begin

;

t := p + (pinteger(p - 4))^;

if p < t then

begin

;

q := p;

repeat;

dec(t);

if p > t then

goto rt;

until (t^ > ' ');

repeat;

repeat;

ch := p^;

inc(p);

until ch > ' ';

repeat;

q^ := ch;

ch := p^;

inc(q);

inc(p);

until ch <= ' ';

q^ := ' ';

inc(q);

until p > t;

dec(q);

rt: q^ := #0;

(pinteger(pchar(pointer(s)) - 4))^ := q - pointer(s);

end;

end;

end;

// Sha_SpaceCompressPChar удаляет из null-terminated строки начальные

// и конечные пробелы и управляющие символы (меньшие пробела), за исключением

// терминатора. Идущие подряд пробелы и управляющие символы в середине строки

// заменяются одним пробелом. Результат замещает исходную строку.

// Никакое перераспределения памяти не производится.

// Функция не работает с read-only строкой.

function Sha_SpaceCompressPChar(p: pchar): pchar;

var

q: pchar;

ch: char;

label

rt;

begin

;

Result := p;

if (p <> nil) and (p^ <> #0) then

begin

;

q := p - 1;

repeat;

repeat;

ch := p^;

inc(p);

if ch = #0then

goto rt;

until ch > ' ';

inc(q);

repeat;

q^ := ch;

ch := p^;

inc(q);

inc(p);

until ch <= ' ';

q^ := ' ';

until ch = #0;

rt: if q < Result then

inc(q);

q^ := #0;

end;

end;

Пример использования:

s2 := Sha_SpaceCompress(s1);

Sha_SpaceCompressInpace(s);

Sha_SpaceCompressPChar(pch);

Code:

type

TStrArray = arrayofstring;

function Explode(var a: TStrArray; Border, S: string): Integer;

var

S2: string;

begin

Result := 0;

S2 := S + Border;

repeat

SetLength(A, Length(A) + 1);

a[Result] := Copy(S2, 0,Pos(Border, S2) - 1);

Delete(S2, 1,Length(a[Result] + Border));

Inc(Result);

until S2 = '';

end;

Code:

procedure TForm1.Button1Click(Sender: TObject);

var

S: string;

A: TStrArray;

AnzTokens, i: Integer;

begin

S := 'Ein=Text=durch=Geleichzeichen=getrennt';

AnzTokens := Explode(A, '=', S);

for i := 0to AnzTokens -1do

Memo1.Lines.Add(A[i]);

end;

Code:

{

* These 2 functions are from the programming language PHP, unite certainly well-known.

* Now one can use it also in Delphi:)

}

{...}

//* Needed type declaration

type

TExplodeArray = arrayofString;

{...}

function Implode(const cSeparator: String; const cArray: TExplodeArray): String;

var

i: Integer;

begin

Result := '';

for i := 0to Length(cArray) -1dobegin

Result := Result + cSeparator + cArray[i];

end;

System.Delete(Result, 1, Length(cSeparator));

end;

function Explode(const cSeparator, vString: String): TExplodeArray;

var

i: Integer;

S: String;

begin

S := vString;

SetLength(Result, 0);

i := 0;

while Pos(cSeparator, S) > 0dobegin

SetLength(Result, Length(Result) +1);

Result[i] := Copy(S, 1, Pos(cSeparator, S) -1);

Inc(i);

S := Copy(S, Pos(cSeparator, S) + Length(cSeparator), Length(S));

end;

SetLength(Result, Length(Result) +1);

Result[i] := Copy(S, 1, Length(S));

end;

Code:

procedure TForm1.Button1Click(Sender: TObject);

var

G: TGUID;

S: string;

i: Integer;

begin

CoCreateGuid(G);

S := '{' + IntToHex(G.D1, 8) + '-' + IntToHex(G.D2, 4) + '-' + IntToHex(G.D3, 4) + '-';

for i := 0to7do

begin

S := S + IntToHex(G.D4[i], 2);

if i = 1then S := S + '-'

end;

S := S + '}';

ShowMessage(GUIDToString(G) + #13 + S)

end;