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

Code:

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

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

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

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

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

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

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

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

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

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

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

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

Автор: vuk, Этот адрес электронной почты защищён от спам-ботов. У вас должен быть включен JavaScript для просмотра.

Copyright: Алексей Вуколов

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

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.

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;

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;

end;

if TNum >= TokenNum then

begin

GetToken1 := Token;

end

else

begin

GetToken1 := '';

end;

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;

end;

Result := TNum;

end;

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;

end;

end;

Dec(i_index);

if i_index = 0then

begin

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

end;

end;

Code:

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

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

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

Автор: Gua, Этот адрес электронной почты защищён от спам-ботов. У вас должен быть включен JavaScript для просмотра., ICQ:141585495, Simferopol

Copyright: Gua

Дата: 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); // Возвращает -> 'текст'

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.

Code:

unit StreamFile;

interface

uses SysUtils;

procedure AssignStreamFile(var F: Text; Filename: string);

implementation

const

BufferSize = 128;

type

TStreamBuffer = array[1..High(Integer)] of Char;

TStreamBufferPointer = ^TStreamBuffer;

TStreamFileRecord = record

case Integer of

1:

(

Filehandle: Integer;

Buffer: TStreamBufferPointer;

BufferOffset: Integer;

ReadCount: Integer;

);

2:

(

Dummy: array[1..32] of Char

)

end;

function StreamFileOpen(var F: TTextRec): Integer;

var

Status: Integer;

begin

with TStreamFileRecord(F.UserData) do

begin

GetMem(Buffer, BufferSize);

case F.Mode of

fmInput:

FileHandle := FileOpen(StrPas(F.Name), fmShareDenyNone);

fmOutput:

FileHandle := FileCreate(StrPas(F.Name));

fmInOut:

begin

FileHandle := FileOpen(StrPas(F.Name), fmShareDenyNone or

fmOpenWrite or fmOpenRead);

if FileHandle <> -1then

status := FileSeek(FileHandle, 0, 2); { Перемещаемся в конец файла. }

F.Mode := fmOutput;

end;

end;

BufferOffset := 0;

ReadCount := 0;

F.BufEnd := 0; { В этом месте подразумеваем что мы достигли конца файла (eof). }

if FileHandle = -1then

Result := -1

else

Result := 0;

end;

end;

function StreamFileInOut(var F: TTextRec): Integer;

procedureRead(var Data: TStreamFileRecord);

procedure CopyData;

begin

while (F.BufEnd < Sizeof(F.Buffer) - 2)

and (Data.BufferOffset <= Data.ReadCount)

and (Data.Buffer[Data.BufferOffset] <> #10) do

begin

F.Buffer[F.BufEnd] := Data.Buffer^[Data.BufferOffset];

Inc(Data.BufferOffset);

Inc(F.BufEnd);

end;

if Data.Buffer[Data.BufferOffset] = #10then

begin

F.Buffer[F.BufEnd] := #13;

Inc(F.BufEnd);

F.Buffer[F.BufEnd] := #10;

Inc(F.BufEnd);

Inc(Data.BufferOffset);

end;

end;

begin

F.BufEnd := 0;

F.BufPos := 0;

F.Buffer := '';

repeat

begin

if (Data.ReadCount = 0) or (Data.BufferOffset > Data.ReadCount) then

begin

Data.BufferOffset := 1;

Data.ReadCount := FileRead(Data.FileHandle, Data.Buffer^, BufferSize);

end;

CopyData;

enduntil (Data.ReadCount = 0)

or (F.BufEnd >= Sizeof(F.Buffer) - 2);

Result := 0;

end;

procedureWrite(var Data: TStreamFileRecord);

var

Status: Integer;

Destination: Integer;

II: Integer;

begin

with TStreamFileRecord(F.UserData) do

begin

Destination := 0;

for II := 0to F.BufPos - 1do

begin

if F.Buffer[II] <> #13then

begin

Inc(Destination);

Buffer^[Destination] := F.Buffer[II];

end;

end;

Status := FileWrite(FileHandle, Buffer^, Destination);

F.BufPos := 0;

Result := 0;

end;

end;

begin

case F.Mode of

fmInput:

Read(TStreamFileRecord(F.UserData));

fmOutput:

Write(TStreamFileRecord(F.UserData));

end;

end;

function StreamFileFlush(var F: TTextRec): Integer;

begin

Result := 0;

end;

function StreamFileClose(var F: TTextRec): Integer;

begin

with TStreamFileRecord(F.UserData) do

begin

FreeMem(Buffer);

FileClose(FileHandle);

end;

Result := 0;

end;

procedure AssignStreamFile(var F: Text; Filename: string);

begin

with TTextRec(F) do

begin

Mode := fmClosed;

BufPtr := @Buffer;

BufSize := Sizeof(Buffer);

OpenFunc := @StreamFileOpen;

InOutFunc := @StreamFileInOut;

FlushFunc := @StreamFileFlush;

CloseFunc := @StreamFileClose;

StrPLCopy(Name, FileName, Sizeof(Name) - 1);

end;

end;

end.