Слова

Быстрая функция для разбивки строки на части (слова) в один цикл

2013-08-20T16:46:58+07:00

Code:

type TDelim=setof Char;

TArrayOfString=ArrayofString;

//*******************

// Разбивает строку с разделителями на части

// и возвращает массив частей

// fcToParts

function fcToParts(sString:String;tdDelim:TDelim):TArrayOfString

var iCounter,iBegin:Integer;

begin//fc

if length(sString)>0then

begin

include(tdDelim,#0);iBegin:=1; SetLength(Result,0);

For iCounter:=1to Length(sString)+1do

begin//for

if (sString[iCounter] in tdDelim) then

begin

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

Result[Length(Result)-1]:=Copy(sString,iBegin,iCounter-iBegin);

iBegin:=iCounter+1;

end;

end;//for

end;//if

end;//fc

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

Code:

var

StrArr:TArrayOfString

StrArr:=fcToParts('строка1-строка2@строка3',['-','@']):

Автор ДЫМ

Взято с Vingrad.ruhttps://forum.vingrad

Заполнение списка словами из строки

2013-08-20T16:48:07+07:00

Code:

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

>> Заполнение списка (TargetList) словами из строки (Text),

с возможностью укзания множества разделителей

Функция заполняет список TargetList, словами (наборами символов)

из строки Text. Имеется возможность получения позиции каждого

слова в строке (ReturnWordPlaces = True); добавления в TargetList

не только слов, но и разделителей (ReturnWordDeviders = True);

указания более чем одного разделителя (все в строке WordDeviders).

Ограничением является невозможность указания разделителя,

длинной более чем 1 символ.

Result = TargetList.Count; {количество строк в TargetList}

Зависимости: sysutils, classes, system

Автор: VID, vidsnap0mail.ru, ICQ: 132234868, Махачкала

* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

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

function GetWordListFromText(Text, WordDeviders: string; TargetList: TStrings;

ReturnWordPlace, ReturnWordDeviders: Boolean): Integer;

var

X, TextLength, WP: Integer;

W: string;

begin

Result := 0;

TextLength := Length(Text);

if TextLength = 0then

Exit;

if Length(WordDeviders) = 0then

Exit;

if TargetList = nilthen

Exit;

TargetList.BeginUpdate();

TargetList.Clear;

WordDeviders := AnsiUpperCase(WordDeviders);

W := '';

X := 0;

WP := 1;

repeat

X := X + 1;

if (POS(AnsiUpperCase(Text[x]), WordDeviders) = 0) and (X <= TextLength)

then

W := W + Text[x]

else

begin

if W <> ''then

begin

case ReturnWordPlace of

True: TargetList.Add(W + '=' + Inttostr(WP));

False: TargetList.Add(W);

end;

W := '';

WP := X + 1;

if ReturnWordDeviders = true then

begin

case ReturnWordPlace of

True: TargetList.Add(Text[x] + '=' + Inttostr(x));

False: TargetList.Add(TEXT[x]);

end;

until (X > TextLength);

TargetList.EndUpdate;

Result := TargetList.Count;

end;

Как осуществить поиск слов по маске?

2013-08-20T16:23:46+07:00

Может у кого-нибудь есть готовая функция поиска(выборки) слов по маске (с использованием символов '*' и '?').

Такая функция в Дельфи есть: MatchesMask из модуля masks.

Автор ответа:MBo

Взято с Vingradhttps://forum.vingrad

Как подсчитать количество слов в строке?

2013-08-20T16:27:02+07:00

Code:

function Seps(As_Arg: Char): Boolean;

begin

Seps := As_Arg in

[#0..#$1F, ' ', '.', ',', '?', ':', ';', '(', ')', '/', '\'];

end;

function WordCount(CText: string): Longint;

var

Ix: Word;

Work_Count: Longint;

begin

Work_Count := 0;

Ix := 1;

while Ix <= Length(CText) do

begin

while (Ix <= Length(CText)) and (Seps(CText[Ix])) do

Inc(Ix);

if Ix <= Length(CText) then

begin

Inc(Work_Count);

while (Ix <= Length(CText)) and (not Seps(CText[Ix])) do

Inc(Ix);

end;

Word_Count := Work_Count;

end;

{

To count the number opf words in a TMemo Component,

call: WordCount(Memo1.Text)

}

Взято с https://delphiworld. narod

Code:

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

>> Подсчет количества слов в строке.

Возвращает количество слов в строке, границы слов определяются в

соответствие с набором разделителей.

Описание параметров:

s - строка, в которой происходит подсчет слов;

Delimiters множество, содержащее символы-разделители слов;

Возвращаемое значение - количество слов

Зависимости: SysUtils, UBPFD.WordScan

Автор: vuk, vuk@fcenter.ru

Дата: 18 апреля 2002 г.

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

function CountWords(const s: string; Delimiters: TSysCharSet): integer;

var

wStart, wLen: integer;

begin

Result := 0;

wStart := 1;

while WordScan(s, wStart, wLen, Delimiters) do

begin

inc(Result);

inc(wStart, wLen);

end;

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

WordCount := CountWords('This is a sample', [' ']);

Определить корень слова (для поиска похожих слов)

2013-08-20T16:48:56+07:00

Автор: ___Nikolay

Code:

// Поиск по корню слова

function RootOfWord(s: string): string;

label

start;

const

sGlas = 'аеёиоуыэюяaeiou'; // With english letters

sSoglas = 'бвгджзйклмнпрстфхцчшщъь';

sCompletions1 = 'й ь s';

sCompletions2 = 'ам ям ом ем ин ём ся ет ит ут ют ат ят ыв ив ев ан ян ов ев ог ег ир ер ых ок ющ ущ er ed';

sCompletions3 = 'енн овл евл ённ анн ост ест';

sAttachments1 = 'в с';

sAttachments2 = 'на за ис из до по вы во со';

sAttachments3 = 'при рас пре про под';

sAttachments4 = 'пере';

var

sResult: string;

i, iCnt, iGlasCount, iCheckCount: integer;

begin

sResult := AnsiLowerCase(Trim(s));

iCheckCount := 0;

start:

// "ся"

if Length(sResult) > 3then

if sResult[Length(sResult) - 1] + sResult[Length(sResult)] = 'ся'then

Delete(sResult, Length(sResult) - 1, 2);

(* E N G L I S H *)

// "ing"

if Length(sResult) > 4then

if sResult[Length(sResult) - 2] + sResult[Length(sResult) - 1] + sResult[Length(sResult)] = 'ing'then

Delete(sResult, Length(sResult) - 2, 3);

// --

// Гласные

if Length(sResult) > 3then

begin

iGlasCount := 0;

for i := Length(sResult) downto1do

if Pos(sResult[i], sGlas) <> 0then// Если последний символ - гласная

inc(iGlasCount)

else

break;

if iGlasCount <> 0then

begin

iGlasCount := iGlasCount - 1;

Delete(sResult, Length(sResult) - iGlasCount, iGlasCount + 1);

end;

// Окончания

if Length(sResult) > 3then

if Pos(sResult[Length(sResult)], sCompletions1) <> 0then

Delete(sResult, Length(sResult), 1);

// "ся"

if Length(sResult) > 3then

if sResult[Length(sResult) - 1] + sResult[Length(sResult)] = 'ся'then

Delete(sResult, Length(sResult) - 1, 2);

if Length(sResult) > 3then

while Pos(sResult[Length(sResult) - 2] + sResult[Length(sResult) - 1] +

sResult[Length(sResult)], sCompletions3) <> 0do

begin

if Length(sResult) > 3then

Delete(sResult, Length(sResult) - 1, 3)

else

break;

end;

if Length(sResult) > 3then

while Pos(sResult[Length(sResult) - 1] + sResult[Length(sResult)], sCompletions2) <> 0do

begin

if Length(sResult) > 3then

Delete(sResult, Length(sResult) - 1, 2)

else

break;

end;

// Гласные

if Length(sResult) > 3then

begin

iGlasCount := 0;

for i := Length(sResult) downto1do

if Pos(sResult[i], sGlas) <> 0then// Если последний символ - гласная

inc(iGlasCount)

else

break;

if iGlasCount <> 0then

begin

iGlasCount := iGlasCount - 1;

Delete(sResult, Length(sResult) - iGlasCount, iGlasCount + 1);

end;

// Приставки

iCnt := 4;

if Length(sResult) > iCnt then

if Pos(Copy(sResult, 1, iCnt), sAttachments4) <> 0then

Delete(sResult, 1, iCnt);

iCnt := 3;

if Length(sResult) > iCnt then

if Pos(Copy(sResult, 1, iCnt), sAttachments3) <> 0then

Delete(sResult, 1, iCnt);

iCnt := 2;

if Length(sResult) > iCnt then

if Pos(Copy(sResult, 1, iCnt), sAttachments2) <> 0then

Delete(sResult, 1, iCnt);

iCnt := 1;

if Length(sResult) > iCnt then

if Pos(Copy(sResult, 1, iCnt), sAttachments1) <> 0then

Delete(sResult, 1, iCnt);

inc(iCheckCount);

if iCheckCount < 2then

goto start;

Result := sResult;

end;

Поиск слов по маске

2013-08-20T16:51:25+07:00

Может у кого-нибудь есть готовая функция поиска(выборки) слов по маске (с использованием символов '*' и '?').

Такая функция в Дельфи есть: MatchesMask из модуля masks.

Автор: MBo

Получать слова нужной длины при перестановке букв в указанном слове

2013-08-20T16:50:41+07:00

Code:

{

Definition: Permutation

A permutation is an arrangement of n objects, arranged in groups of size r

without repetition where order is important.

P(n,r) = n! / (n-r)!

Example: Find all two-letter permutations of the letters "ABC"

n = ABC

r = 2

Output: AB AC BA BC CA CB

}

{

Definition: Permutation

Eine Permutation ist eine Anordnung von n Objekten ohne Wiederholung.

Dabei spielt die Reihenfolge der Elemente in den Mengen keine Rolle.

P(n,r) = n! / (n-r)!

Beispiel: Finde alle 2-Buchstaben Kombinationen von "ABC"

n = ABC

r = 2

Ergebnis: AB AC BA BC CA CB

}

{

The following is a console Program:

Choose File, New, Console Application

}

program Permute;

{$APPTYPE CONSOLE}

uses SysUtils;

var

R, Slen: Integer;

procedure P(var A: string; B: string);

var

J: Word;

C, D: string;

begin

{ P(N,N) >> R=Slen }

if Length(B) = SLen - R then

begin

Write(' {' + A + '} '); {Per++}

end

else

for J := 1to Length(B) do

begin

C := B;

D := A + C[J];

Delete(C, J, 1);

P(D, C);

end;

var

Q, S, S2: string;

begin

S := ' ';

S2 := ' ';

while (S <> '') and (S2 <> '') do

begin

Writeln('');

Write('P(N,R) N=? : ');

ReadLn(S);

SLen := Length(S);

Write('P(N,R) R=? : ');

ReadLn(S2);

if s2 <> ''then R := StrToInt(S2);

Writeln('');

Q := '';

P(Q, S);

end;

end.

Разбивка строки на слова

2013-08-20T16:28:29+07:00

Приведу несколько простых функций, позволяющих работать с отдельными словами в строке. Возможно они пригодятся вам для разбивки текстовых полей на отдельные слова (for i := 1 to NumToken do ...) с последующим сохранением их в базе данных.

Code:

function GetToken(aString, SepChar: string; TokenNum: Byte): string;

{

параметры: aString : полная строка

SepChar : единственный символ, служащий

разделителем между словами (подстроками)

TokenNum: номер требуемого слова (подстроки))

result : искомое слово или пустая строка, если количество слов

меньше значения 'TokenNum'

}

var

Token: string;

StrLen: Byte;

TNum: Byte;

TEnd: Byte;

begin

StrLen := Length(aString);

TNum := 1;

TEnd := StrLen;

while ((TNum <= TokenNum) and (TEnd <> 0)) do

begin

TEnd := Pos(SepChar, aString);

if TEnd <> 0then

begin

Token := Copy(aString, 1, TEnd - 1);

Delete(aString, 1, TEnd);

Inc(TNum);

end

else

begin

Token := aString;

end;

if TNum >= TokenNum then

begin

GetToken1 := Token;

end

else

begin

GetToken1 := '';

end;

function NumToken(aString, SepChar: string): Byte;

{

parameters: aString : полная строка

SepChar : единственный символ, служащий

разделителем между словами (подстроками)

result : количество найденных слов (подстрок)

}

var

RChar: Char;

StrLen: Byte;

TNum: Byte;

TEnd: Byte;

begin

if SepChar = '#'then

begin

RChar := '*'

end

else

begin

RChar := '#'

end;

StrLen := Length(aString);

TNum := 0;

TEnd := StrLen;

while TEnd <> 0do

begin

Inc(TNum);

TEnd := Pos(SepChar, aString);

if TEnd <> 0then

begin

aString[TEnd] := RChar;

end;

Result := TNum;

end;

// Или другое решение:

function CopyColumn(const s_string: string; c_fence: char;

i_index: integer): string;

var

i, i_left: integer;

begin

result := EmptyStr;

if i_index = 0then

begin

exit;

end;

i_left := 0;

for i := 1to Length(s_string) do

begin

if s_string[i] = c_fence then

begin

Dec(i_index);

if i_index = 0then

begin

result := Copy(s_string, i_left + 1, i - i_left - 1);

exit;

end

else

begin

i_left := i;

end;

Dec(i_index);

if i_index = 0then

begin

result := Copy(s_string, i_left + 1, Length(s_string));

end;

Я знаю что в GetToken параметр SepChar (в моем случае c_fence) строка, не символ, но комментарий гласит, что функция ожидает единственный символ в этой строке, и это очевидно, поскольку если вы пошлете более одного символа, функция попросту несработает. ( Delete(aString,1,TEnd) будет ошибкой, если Length( SepChar ) > 1 ).

Взято с https://delphiworld.narod

Code:

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

>> Разбивка строки на отдельные слова

function StringToWords(const DelimitedText: string; ResultList: TStrings;

Delimiters: TDelimiter = []): boolean - разбивает отдельную строку на

состовляющие ее слова и результат помещает в TStringList

function StringsToWords(const DelimitedStrings: TStrings; ResultList: TStrings;

Delimiters: TDelimiter = []): boolean - разбивает любое количество строк на

состовляющие их слова и все помещяет в один TStringList

Delimiters - список символов являющихся разделителями слов,

например такие как пробел, !, ? и т.д.

Зависимости: Classes

Автор: Separator, separator@mail.kz, Алматы

Дата: 13 ноября 2002 г.

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

unit spUtils;

interface

uses Classes;

type

TDelimiter = setof#0..'я' ;

const

StandartDelimiters: TDelimiter = [' ', '!', '@', '(', ')', '-', '|', '\', ';',

':', '"', '/', '?', '.', '>', ',', '<'];

//Преобразование в набор слов

function StringToWords(const DelimitedText: string; ResultList: TStrings;

Delimiters: TDelimiter = []; ListClear: boolean = true): boolean;

function StringsToWords(const DelimitedStrings: TStrings; ResultList: TStrings;

Delimiters: TDelimiter = []; ListClear: boolean = true): boolean;

implementation

function StringToWords(const DelimitedText: string; ResultList: TStrings;

Delimiters: TDelimiter = []; ListClear: boolean = true): boolean;

var

i, Len, Prev: word;

TempList: TStringList;

begin

Result := false;

if (ResultList <> nil) and (DelimitedText <> '') then

try

TempList := TStringList.Create;

if Delimiters = [] then

Delimiters := StandartDelimiters;

Len := 1;

Prev := 0;

for i := 1to Length(DelimitedText) do

begin

if Prev <> 0then

begin

if DelimitedText[i] in Delimiters then

begin

if Len = 0then

Prev := i + 1

else

begin

TempList.Add(copy(DelimitedText, Prev, Len));

Len := 0;

Prev := i + 1

end

else

Inc(Len)

end

elseifnot (DelimitedText[i] in Delimiters) then

Prev := i

end;

if Len > 0then

TempList.Add(copy(DelimitedText, Prev, Len));

if TempList.Count > 0then

begin

if ListClear then

ResultList.Assign(TempList)

else

ResultList.AddStrings(TempList);

Result := true

end;

finally

TempList.Free

end

end;

function StringsToWords(const DelimitedStrings: TStrings; ResultList: TStrings;

Delimiters: TDelimiter = []; ListClear: boolean = true): boolean;

begin

if Delimiters = [] then

Delimiters := StandartDelimiters + [#13, #10]

else

Delimiters := Delimiters + [#13, #10];

Result := StringToWords(DelimitedStrings.Text, ResultList, Delimiters,

ListClear)

end;

end.

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

StringToWords(Edit1.Text, Memo1.Lines);

StringToWords(Edit1.Text, Memo1.Lines, [' ', '.', ',']);

StringsToWords(Memo1.Lines, Memo2.Lines);

StringsToWords(Memo1.Lines, Memo2.Lines, [' ', '.', ',']);

Code:

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

>> Разбиение текста на слова + получение количества слов в тексте

T : Собственно строка, которая будет разбиваться на слова

Mode: Режим, может быть

0: получение английских и русских слов

1: только русских

2: только английских

List: Здесь хранятся найденые слова (по умолчанию = nil)

возвращаемое значение: количество слов.

P/S

По идейным соображениям специальные символы, цифры

и пробелы игнорируются.

Зависимости: Windows, Classes

Автор: 777, nix@rbcmail.ru, Архангельск

Дата: 15 июня 2002 г.

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

function StringToWords(T: string; Mode: Short; List: Tstrings = nil): integer;

var

i, z: integer;

s: string;

c: Char;

procedure Check;

begin

if (s > '') and (List <> nil) then

begin

List.Add(S);

z := z + 1;

end;

s := '';

end;

begin

i := 0;

z := 0;

s := '';

if t > ''then

begin

while i <= Length(t) + 1do

begin

c := t[i];

case Mode of

0: {русские и английские слова}

if (c in ['a'..'z']) or (c in ['A'..'Z']) or (c in ['а'..'я']) or

(c in ['А'..'Я']) and (c <> ' ') then

s := s + c

else

Check;

1: {только русские слова}

if (c in ['а'..'я']) or (c in ['А'..'Я']) and (c <> ' ') then

s := s + c

else

Check;

2: {только английские слова}

if (c in ['a'..'z']) or (c in ['A'..'Z']) and (c <> ' ') then

s := s + c

else

check;

end;

i := i + 1;

end;

result := z;

end;

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

procedure TForm1.Button1Click(Sender: TObject);

var

Source, Dest: Tstrings;

i: integer;

begin

Source := TstringList.Create;

Dest := TstringList.Create;

Source.LoadFromFile('c:\MyText.txt');

for i := 0to Source.Count - 1do

begin

StringToWords(Source[i], 2, Dest);

Application.ProcessMessages;

end;

Dest.SaveToFile('c:\MyWords.txt');

ShowMessage('Найдено ' + IntToStr(Dest.Count) + ' слов');

end;

Code:

procedure SplitTextIntoWords(const S: string; words: TstringList);

var

startpos, endpos: Integer;

begin

Assert(Assigned(words));

words.Clear;

startpos := 1;

while startpos <= Length(S) do

begin

// skip non-letters

while (startpos <= Length(S)) andnot IsCharAlpha(S[startpos]) do

Inc(startpos);

if startpos <= Length(S) then

begin

// find next non-letter

endpos := startpos + 1;

while (endpos <= Length(S)) and IsCharAlpha(S[endpos]) do

Inc(endpos);

words.Add(Copy(S, startpos, endpos - startpos));

startpos := endpos + 1;

end; { If }

end; { While }

end; { SplitTextIntoWords }

function StringMatchesMask(S, mask: string;

case_sensitive: Boolean): Boolean;

var

sIndex, maskIndex: Integer;

begin

ifnotcase_sensitive then

begin

S := AnsiUpperCase(S);

mask := AnsiUpperCase(mask);

end; { If }

Result := True; // blatant optimism

sIndex := 1;

maskIndex := 1;

while (sIndex <= Length(S)) and (maskIndex <= Length(mask)) do

begin

case mask[maskIndex] of

'?':

begin

// matches any character

Inc(sIndex);

Inc(maskIndex);

end; { case '?' }

'*':

begin

// matches 0 or more characters, so need to check for

// next character in mask

Inc(maskIndex);

if maskIndex > Length(mask) then

// * at end matches rest of string

Exit

elseif mask[maskindex] in ['*', '?'] then

raise Exception.Create('Invalid mask');

// look for mask character in S

while (sIndex <= Length(S)) and

(S[sIndex] <> mask[maskIndex]) do

Inc(sIndex);

if sIndex > Length(S) then

begin

// character not found, no match

Result := False;

Exit;

end;

{ If }

end; { Case '*' }

elseif S[sIndex] = mask[maskIndex] then

begin

Inc(sIndex);

Inc(maskIndex);

end{ If }

else

begin

// no match

Result := False;

Exit;

end;

end; { Case }

end; { While }

// if we have reached the end of both S and mask we have a complete

// match, otherwise we only have a partial match

if (sIndex <= Length(S)) or (maskIndex <= Length(mask)) then

Result := False;

end; { stringMatchesMask }

procedure FindMatchingWords(const S, mask: string;

case_sensitive: Boolean; matches: Tstrings);

var

words: TstringList;

i: Integer;

begin

Assert(Assigned(matches));

words := TstringList.Create;

try

SplitTextIntoWords(S, words);

matches.Clear;

for i := 0to words.Count - 1do

begin

if stringMatchesMask(words[i], mask, case_sensitive) then

matches.Add(words[i]);

end; { For }

finally

words.Free;

end;

{

The Form has one TMemo for the text to check, one TEdit for the mask,

one TCheckbox (check = case sensitive), one TListbox for the results,

one Tbutton

}

procedure TForm1.Button1Click(Sender: TObject);

begin

FindMatchingWords(memo1.Text, edit1.Text, checkbox1.Checked, listbox1.Items);

end;

Взято с сайта: https://www.swissdelphicenter

Расщепить строку в слова и обратно

Code:

unit StrFuncs;

interface

uses SysUtils, Classes;

function StrToArrays(str, r: string; out temp: TStrings): Boolean;

function ArrayToStr(str: TStrings; r: string): string;

implementation

function StrToArrays(str, r: string; out temp: TStrings): Boolean;

var

j: Integer;

begin

if temp <> nilthen

begin

temp.Clear;

while str <> ''do

begin

j := Pos(r, str);

if j = 0then j := Length(str) + 1;

temp.Add(Copy(Str, 1, j - 1));

Delete(Str, 1, j + Length(r) - 1);

end;

Result := True;

else

Result := False;

end;

function ArrayToStr(str: TStrings; r: string): string;

var

i: Integer;

begin

Result := '';

for i := 0to Str.Count - 1do

begin

Result := Result + Str.Strings[i] + r;

end;

end.

https://delphiworld.narod

DelphiWorld 6.0

Сканирование строки начиная с указанной позиции с целью нахождения слова

2013-08-20T16:49:57+07:00

Code:

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

>> Сканирование строки начиная с указанной позиции с целью нахождения слова.

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

определяются по разделителям.

Описание параметров:

S - строка, в которой производится поиск;

StartPos - на входе принимает позицию с которой начинается сканирование

строки, на выходе содержит позицию символа, с которого начинается слово;

WordLen - на выходе содержит длину найденного слова;

Delimiters - множество, содержащее символы-разделители слов;

Возвращаемое значение - true если слово найдено, инече false;

Зависимости: SysUtils

Автор: vuk, vuk@fcenter.ru

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

function WordScan(const S: string; var StartPos, WordLen: integer;

Delimiters: TSysCharSet): boolean;

var

i, l: integer;

begin

Result := false;

WordLen := 0;

i := StartPos;

l := length(s);

StartPos := 0;

while i <= l do

if s[i] in Delimiters then

inc(i)

else

begin

StartPos := i;

break;

end;

while i <= l do

ifnot (s[i] in Delimiters) then

begin

inc(i);

inc(WordLen);

end

else

break;

Result := WordLen <> 0;

end;

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

//Консольная программа, выводящая на экран слова из заданной строки.

program Project1;

{$APPTYPE CONSOLE}

uses SysUtils;

var

s: string;

wStart, wLen: integer;

begin

s := 'This is a test string. String contains delimiters.';

wStart := 1;

wLen := 0;

while WordScan(s, wStart, wLen, [' ', '.', ',']) do

begin

writeln(copy(s, wStart, wLen));

inc(wStart, wLen);

end;

readln;

end.

Словарь уникальных слов.

2013-08-20T16:42:35+07:00

Словарь уникальных слов.

Алгоритм составления словаря всех уникальных слов встречающихся в текстовом файле.
По результатам тестирования: обработка файла объемом 3 Мб (уникальных слов ~63 тысячи)
занимает около 3 секунд. (Можно, конечно, и еще ускорить, но уж лениво сильно ;)

Демо пример:

Unit1.pas

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls, Dictionary;

type
TForm1 = class(TForm)
Button1: TButton;
ProgressBar1: TProgressBar;
Button2: TButton;
Edit1: TEdit;
Label1: TLabel;
CheckBox1: TCheckBox;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
end;

var
Form1: TForm1;

implementation

uses ComObj;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
SH: TDictionaryFounder;
S: TStringList;
M: TMemoryStream;
I: Integer;
Start: Cardinal;
begin
S := TStringList.Create;
try
S.LoadFromFile('c:\1.txt');
ProgressBar1.Position := 0;
ProgressBar1.Max := S.Count;
SH := TDictionaryFounder.Create;
try
Start := GetTickCount;
for I := 0 to S.Count - 1 do
begin
SH.AddData(S.Strings[I]);
ProgressBar1.Position := I;
end;
ShowMessage('Время составления словаря: ' + IntToStr(GetTickCount - Start));
M := TMemoryStream.Create;
try
SH.SaveToStream(M);
M.SaveToFile('c:\2.txt');
ProgressBar1.Position := 0;
Button2.Enabled := True;
finally
M.Free;
end;
finally
SH.Free;
end;
finally
S.Free;
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
S: TDictionaryFinder;
M: TMemoryStream;
begin
S := TDictionaryFinder.Create;
try
M := TMemoryStream.Create;
try
M.LoadFromFile('c:\2.txt');
S.LoadFromStream(M);
if S.Find(Edit1.Text, CheckBox1.Checked) then
ShowMessage('Элемент найден')
else
ShowMessage('Элемент не найден');
finally
M.Free;
end;
finally
S.Free;
end;
end;

end.

Unit1.dfm

object Form1: TForm1
Left = 196
Top = 110
BorderIcons = [biSystemMenu]
BorderStyle = bsSingle
Caption = 'Dictionary demo'
ClientHeight = 168
ClientWidth = 227
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
Position = poScreenCenter
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 24
Top = 72
Width = 136
Height = 13
Caption = #1042#1074#1077#1076#1080#1090#1077' '#1090#1077#1082#1089#1090' '#1076#1083#1103' '#1087#1086#1080#1089#1082#1072':'
end
object Button1: TButton
Left = 24
Top = 32
Width = 185
Height = 25
Caption = #1057#1086#1079#1076#1072#1090#1100' '#1089#1083#1086#1074#1072#1088#1100
TabOrder = 0
OnClick = Button1Click
end
object ProgressBar1: TProgressBar
Left = 8
Top = 8
Width = 209
Height = 17
TabOrder = 1
end
object Button2: TButton
Left = 136
Top = 136
Width = 75
Height = 25
Caption = #1055#1086#1080#1089#1082
Enabled = False
TabOrder = 2
OnClick = Button2Click
end
object Edit1: TEdit
Left = 24
Top = 88
Width = 185
Height = 21
TabOrder = 3
end
object CheckBox1: TCheckBox
Left = 24
Top = 112
Width = 185
Height = 17
Caption = #1048#1089#1082#1072#1090#1100' '#1074#1085#1091#1090#1088#1080' '#1089#1083#1086#1074
TabOrder = 4
end
end

Project2.dpr

program Project2;

uses
Forms,
Unit1 in 'Unit1.pas' {Form1},
Dictionary in 'Dictionary.pas';

{$R *.res}

begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

Dictionary.pas

////////////////////////////////////////////////////////////////////////////////
//
// ****************************************************************************
// * Unit Name : Dictionary
// * Purpose : Набор классов для работы с индексированным списком поиска
// * Author : Александр Багель
// * Copyright : Центр Гранд 2001 - 2004 г.
// * Version : 1.00
// ****************************************************************************
//

unit Dictionary;

interface

uses
Windows, Classes, SysUtils{, FullTextGetter};

type
// Класс отвечающий за создание словаря уникальных слов
TDictionaryFounder = class
private
FDict: TList;
FDictMem: array of String;
FDictMemCount: Integer;
protected
function GetPos(const Value: String): Integer; virtual;
procedure Insert(Value: String; Position: Integer); virtual;
function Prepare(const Value: String): String; virtual;
public
constructor Create;
destructor Destroy; override;
procedure AddData(Value: String); //overload;
// procedure AddData(ObjText: IFullTextGetter); overload;
procedure SaveToStream(var AStream: TMemoryStream);
end;

// Класс осуществляющий поиск в словаре
// полученном от TDictionaryFounder
TDictionaryFinder = class
private
FDict: array of ShortString;
FDictLength: Cardinal;
protected
function GetPos(const Value: ShortString;
const SubStr: Boolean = False): Boolean; virtual;
public
destructor Destroy; override;
procedure LoadFromStream(const AStream: TMemoryStream);
function Find(const Value: String;
const SubStr: Boolean = False): Boolean;
end;

implementation

{ TDictionaryFounder }

//
// Добавление информации для построения массива индексов
// =============================================================================
procedure TDictionaryFounder.AddData(Value: String);
var
Tmp: String;
Position, I: Integer;
S: TStringList;
begin
Value := Prepare(Value);
S := TStringList.Create;
try
S.Text := Value;
for I := 0 to S.Count - 1 do
begin
Tmp := S[I];
if Tmp = '' then Continue;
if FDict.Count = 0 then
Insert(Tmp, 0)
else
begin
Position := GetPos(Tmp);
if (Position >= 0) then
if FDict.Count > Position then
begin
if String(FDict.Items[Position]) <> Tmp then
Insert(Tmp, Position);
end
else
Insert(Tmp, Position);
end;
end;
finally
S.Free;
end;
end;

//
// Добавление информации для построения массива индексов
// Информация приходит из интерфейса
// =============================================================================
{procedure TDictionaryFounder.AddData(ObjText: IFullTextGetter);
var
S: String;
begin
if ObjText = nil then
raise Exception.Create('IFullTextGetter is empty.');
S := ObjText.GetText;
AddData(S);
end; }

constructor TDictionaryFounder.Create;
begin
FDict := TList.Create;
end;

destructor TDictionaryFounder.Destroy;
begin
FDict.Free;
FDictMemCount := 0;
SetLength(FDictMem, FDictMemCount);
inherited;
end;

//
// Возвращает номер позиции где находится слово, или должно находится...
// Поиск методом половинного деления...
// =============================================================================
function TDictionaryFounder.GetPos(const Value: String): Integer;
var
FLeft, FRight, FCurrent: Cardinal;
begin
if FDict.Count = 0 then
begin
Result := 0;
Exit;
end;
FLeft := 0;
FRight := FDict.Count - 1;
FCurrent := (FRight + FLeft) div 2;
if String(FDict.Items[FLeft]) > Value then
begin
Result := 0;
Exit;
end;
if String(FDict.Items[FRight]) < Value then
begin
Result := FRight + 1;
Exit;
end;
repeat
if String(FDict.Items[FCurrent]) = Value then
begin
Result := FCurrent;
Exit;
end;
if String(FDict.Items[FCurrent]) < Value then
FLeft := FCurrent
else
FRight := FCurrent;
FCurrent := (FRight + FLeft) div 2;
until FLeft = FCurrent;
if String(FDict.Items[FCurrent]) < Value then Inc(FCurrent);
Result := FCurrent;
end;

//
// Добавление нового индекса в массив индексов
// =============================================================================
procedure TDictionaryFounder.Insert(Value: String; Position: Integer);
begin
if FDictMemCount < FDict.Count + 1 then
begin
Inc(FDictMemCount, FDict.Count + 1);
SetLength(FDictMem, FDictMemCount);
end;
FDictMem[FDict.Count] := Value;
FDict.Insert(Position, @FDictMem[FDict.Count][1]);
end;

//
// Сохранение массива индексов в поток
// =============================================================================
procedure TDictionaryFounder.SaveToStream(var AStream: TMemoryStream);
var
I: Integer;
S: PChar;
TmpS: TStringList;
begin
if AStream = nil then Exit;
TmpS := TStringList.Create;
try
for I := 0 to FDict.Count - 1 do
begin
S := FDict.Items[I];
TmpS.Add(S);
end;
AStream.Position := 0;
AStream.Size := Length(TmpS.Text);
AStream.Write(TmpS.Text[1], Length(TmpS.Text));
AStream.Position := 0;
finally
TmpS.Free;
end;
end;

//
// Подготовка данных к обработке...
// Удаляются все не буквенные символы, каждое слово начинется с новой строки...
// =============================================================================
function TDictionaryFounder.Prepare(const Value: String): String;
var
I: Integer;
Len: Cardinal;
C: PAnsiChar;
LastEnter: Boolean;
begin
SetLength(Result, Length(Value) * 2);
Len := 0;
LastEnter := False;
for I := 1 to Length(Value) do
begin
C := CharLower(@Value[I]);
if C^ in ['a'..'z', 'а'..'я'] then
begin
Inc(Len);
Result[Len] := C^;
LastEnter := False;
end
else
if not LastEnter then
begin
Inc(Len);
Result[Len] := #13;
Inc(Len);
Result[Len] := #10;
LastEnter := True;
end;
end;
SetLength(Result, Len);
end;

{ TDictionaryFinder }

destructor TDictionaryFinder.Destroy;
begin
FDictLength := 0;
SetLength(FDict, FDictLength);
inherited;
end;

//
// Поиск введенных слов...
// =============================================================================
function TDictionaryFinder.Find(const Value: String;
const SubStr: Boolean = False): Boolean;
var
S: TStringList;
I: Integer;
begin
Result := False;
if Value = '' then Exit;
S := TStringList.Create;
try
S.Text := StringReplace(Value, ' ', #13#10, [rfReplaceAll]);
S.Text := AnsiLowerCase(S.Text);
if S.Count = 0 then Exit;
for I := 0 to S.Count - 1 do
begin
Result := GetPos(S.Strings[I], SubStr);
if not Result then Exit;
end;
finally
S.Free;
end;
end;

//
// Поиск каждого слова в массиве индексов
// =============================================================================
function TDictionaryFinder.GetPos(const Value: ShortString;
const SubStr: Boolean = False): Boolean;
var
FLeft, FRight, FCurrent, I: Cardinal;
begin
Result := False;
if SubStr then
begin
for I := 0 to FDictLength - 1 do
if Pos(Value, FDict[I]) > 0 then
begin
Result := True;
Exit;
end;
end
else
begin
if FDictLength = 0 then Exit;
FLeft := 0;
FRight := FDictLength - 1;
FCurrent := (FRight + FLeft) div 2;
if FDict[FLeft] > Value then Exit;
if FDict[FRight] < Value then Exit;
if FDict[FLeft] = Value then
begin
Result := True;
Exit;
end;
if FDict[FRight] = Value then
begin
Result := True;
Exit;
end;
repeat
if FDict[FCurrent] = Value then
begin
Result := True;
Exit;
end;
if FDict[FCurrent] < Value then
FLeft := FCurrent
else
FRight := FCurrent;
FCurrent := (FRight + FLeft) div 2;
until FLeft = FCurrent;
end;
end;

//
// Загрузка массива индексов из потока
// =============================================================================
procedure TDictionaryFinder.LoadFromStream(const AStream: TMemoryStream);
var
S: TStringList;
I: Integer;
begin
S := TStringList.Create;
try
AStream.Position := 0;
S.LoadFromStream(AStream);
FDictLength := S.Count;
if FDictLength = 0 then Exit;
SetLength(FDict, FDictLength);
for I := 0 to FDictLength - 1 do
FDict[I] := S.Strings[I];
finally
S.Free;
end;
end;

end.

Функция возвращающая N-ое слово в строке

2013-08-20T16:30:02+07:00

Code:

//Функция возвращающая N-ое слово в строке

//Если N=0, то функция возвращает подстоку начиная с первого разделителя

function GetWord(str:string;n:word;sep:char):string;

var i,space,l,j:integer;

buf:string;

begin

l:=length(str);

if n=0thenbegin//особый параметр

j:=pos(GetWord(str,2,sep),str);

GetWord:=copy(str,j,l-j+1);

exit

end;

space:=0;

i:=0;

while (space<>(n-1))and(i<=l) do

begin

i:=i+1;

if str[i]=sep then space:=space+1

end;

i:=i+1;

buf:='';

while (i<=l)and(str[i]<>sep) do

begin

buf:=buf+str[i];

i:=i+1

end;

GetWord:=buf;

end;

Автор: TP@MB@Y

Взято с Vingrad ruhttps://forum.vingrad

Code:

function GetToken(aString, SepChar: string; TokenNum: Byte): string;

{

параметры: aString : полная строка

SepChar : единственный символ, служащий

разделителем между словами (подстроками)

TokenNum: номер требуемого слова (подстроки))

result : искомое слово или пустая строка, если количество слов

меньше значения 'TokenNum'

}

var

Token: string;

StrLen: Byte;

TNum: Byte;

TEnd: Byte;

begin

StrLen := Length(aString);

TNum := 1;

TEnd := StrLen;

while ((TNum <= TokenNum) and (TEnd <> 0)) do

begin

TEnd := Pos(SepChar, aString);

if TEnd <> 0then

begin

Token := Copy(aString, 1, TEnd - 1);

Delete(aString, 1, TEnd);

Inc(TNum);

end

else

begin

Token := aString;

end;

if TNum >= TokenNum then

begin

GetToken1 := Token;

end

else

begin

GetToken1 := '';

end;

function NumToken(aString, SepChar: string): Byte;

{

parameters: aString : полная строка

SepChar : единственный символ, служащий

разделителем между словами (подстроками)

result : количество найденных слов (подстрок)

}

var

RChar: Char;

StrLen: Byte;

TNum: Byte;

TEnd: Byte;

begin

if SepChar = '#'then

begin

RChar := '*'

end

else

begin

RChar := '#'

end;

StrLen := Length(aString);

TNum := 0;

TEnd := StrLen;

while TEnd <> 0do

begin

Inc(TNum);

TEnd := Pos(SepChar, aString);

if TEnd <> 0then

begin

aString[TEnd] := RChar;

end;

Result := TNum;

end;

https://delphiworld.narod

DelphiWorld 6.0

Code:

function CopyColumn(const s_string: string; c_fence: char; i_index: integer):

string;

var

i, i_left: integer;

begin

result := EmptyStr;

if i_index = 0then

begin

exit;

end;

i_left := 0;

for i := 1to Length(s_string) do

begin

if s_string[i] = c_fence then

begin

Dec(i_index);

if i_index = 0then

begin

result := Copy(s_string, i_left + 1, i - i_left - 1);

exit;

end

else

begin

i_left := i;

end;

Dec(i_index);

if i_index = 0then

begin

result := Copy(s_string, i_left + 1, Length(s_string));

end;

https://delphiworld.narod

DelphiWorld 6.0

Code:

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

>> Получение N-го слова из строки

Зависимости: System

Автор: Gua, fbsdd@ukr.net, ICQ:141585495, Simferopol

Дата: 02 мая 2002 г.

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

{

Str: Строка

Smb: Разгранечительный символ

WordNmbr: Номер нужного сова

}

function GetWord(Str, Smb: string; WordNmbr: Byte): string;

var

SWord: string;

StrLen, N: Byte;

begin

StrLen := SizeOf(Str);

N := 1;

while ((WordNmbr >= N) and (StrLen <> 0)) do

begin

StrLen := Pos(Smb, str);

if StrLen <> 0then

begin

SWord := Copy(Str, 1, StrLen - 1);

Delete(Str, 1, StrLen);

Inc(N);

end

else

SWord := Str;

end;

if WordNmbr <= N then

Result := SWord

else

Result := '';

end;

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

GetWord('Здесь ваш текст',' ',3); // Возвращает -> 'текст'