Работа со строками
Code: |
{ **** UBPFD *********** by delphibase.endimus **** >> Функция для "разворачивания" строк
Входные параметры: Input - входная строка, которую необходимо представить в "развернутом виде"
на входе: 1,3,5-10,15 на выходе: 1,3,5,6,7,8,9,10,15
Зависимости: стандартный набор включаемых модулей Автор: Ru, DiVo_Ru @ rambler.ru, Одесса Copyright: DiVo 2002, creator Ru
***************************************************** }
function DecStr(Input: string): string; var i, j, t: integer; s: string; begin if pos('-', Input) <> 0then begin while length(Input) <> 0do begin if Input[1] = ','then begin i := strtoint(s); delete(Input, 1, 1); result := result + s + ','; s := ''; end else begin if Input[1] = '-'then begin i := strtoint(s); delete(Input, 1, 1); t := pos(',', Input); result := result + s + ','; s := ''; if t = 0then begin j := strtoint(Input); Input := ''; end else begin j := strtoint(copy(Input, 1, t - 1)); delete(Input, 1, t); end; inc(i); while i < j + 1do begin result := result + inttostr(i) + ','; inc(i); end; end else begin s := s + Input[1]; delete(Input, 1, 1); end; end; end; end else result := Input; if s <> ''then result := result + s; end;
|
- Подробности
- Родительская категория: Работа со строками
- Категория: Разбор строки, выделение элементов, поиск
Автор: Дмитрий Кузан
Недавно в поисках информации по интеллектуальным алгоритмам сравнения я нашел такой алгоритм — алгоритм сравнения (совпадения) двух строк, Так как он был написан на VBA, я под свои нужды переписал его на Delphi
Уважаемые пользователи проекта DelphiWorld, я думаю данная функция пригодится тем, кто часто пишет функции поиска, особенно когда поиск приблизителен. То есть, например, в БД забито "Иванав Иван" - с ошибкой при наборе, а ищется "Иванов". Так вот, данный алгоритм может вам найти "Иванав" при вводе "Иванов",а также при "Иван Иванов" - даже наоборот с определенной степенью релевантности при сравнении. А используя сравнение в процентном отношении, вы можете производить поиск по неточным данным с более-менее степенью похожести.
Еще раз повторяю, алгоритм не мой, я только его портировал на Delphi.
А метод был предложен Владимиром Кива, за что ему огромное спасибо.
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; |
https://delphiworld.narod
DelphiWorld 6.0
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; |
Взято с сайта: https://www.swissdelphicenter
- Подробности
- Родительская категория: Работа со строками
- Категория: Разбор строки, выделение элементов, поиск
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);
|
- Подробности
- Родительская категория: Работа со строками
- Категория: Разные вопросы
// 1. ...............................................
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; |
// How to use it:
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; |
// 2. ...............................................
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; |
Взято с сайтаhttps://www.swissdelphicente
- Подробности
- Родительская категория: Работа со строками
- Категория: Разные вопросы
Как в Run-time сгененрировать строку типа
'{821AB2C7-559D-48E0-A3EE-6DD50E83234C}'
Типа как в среде при нажатии Ctrl-Shift-G. Функция CoCreateGuid выводит значение типа TGUID, я нигде не нашёл функции конвертации TGUID -> String. Может кто знает такую функцию?
Автор:Vit
Взято с Vingrad ruhttps://forum.vingrad
Есть такая функция. Как ни странно называется она GUIDToString, и живет в SysUtils.
Автор:Fantasist
Взято с Vingrad ruhttps://forum.vingrad
Можно GUIDToString написать и вручную, будет выглядеть примерно так:
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; |
Автор:Jin X
- Подробности
- Родительская категория: Работа со строками
- Категория: Разные вопросы
Страница 14 из 21