IPB
ЛогинПароль:

> Внимание! Действует предмодерация

Подраздел FAQ (ЧАВО, ЧАстые ВОпросы) предназначен для размещения готовых рабочих программ, реализаций алгоритмов. Это нечто вроде справочника, он наполнялся в течение 2000х годов. Ваши вопросы, особенно просьбы решить задачу, не пройдут предмодерацию. Те, кто наполнял раздел, уже не заходят на форум, а с теми, кто на форуме сейчас, лучше начинать общение в других разделах. В частности, решение задач — здесь.

 
 Ответить  Открыть новую тему 
> Разбиение на слова. Все способы.
сообщение
Сообщение #1


Ищущий истину
******

Группа: Пользователи
Сообщений: 4 825
Пол: Мужской
Реальное имя: Олег

Репутация: -  45  +


Предлагаю в теме собрать все способы разбиения строки на слова.
(рекурсивные, итерационные, с использованием массивов, без использования массивов, с ДСД, с чем-то еще... вобщем программы и алгоритмы преобразования предложения в набор слов )

СОБИРАЕМ! good.gif


--------------------
Помогая друг другу, мы справимся с любыми трудностями!
"Не опускать крылья!" (С)
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #2


Гость






Пожалуй, самый извращенный способ - используется реализация динамического массива (из FAQ) с ООП:

function pos(var p: byte;
substr, s: string): boolean;
begin
p := system.pos(substr, s);
pos := (p > 0)
end;


const
word_len = 100;
max_words = 100;

type
titerator = set of char;

const
str_singlespace = #32;
str_doublespace = #32#32;

str_space: titerator = [#32];
str_punct: titerator = ['.', ',', ':', ';', '?', '!'];

type
ptwordstr = ^twordstr;
twordstr = string[word_len];

ttype = twordstr;

{$i array.pas}

type
twordlist = object(tarray)
constructor init(s: string;
iterator: titerator);
destructor done;

{ Iterator }
function last: integer;
{ Iterator }

private
count: integer;

procedure find(s: string;
iterator: titerator);
procedure append(s: string);
end;

constructor twordlist.init(s: string;
iterator: titerator);
begin
inherited init(max_words);
count := 0;

find(s, iterator)
end;

destructor twordlist.done;
begin
inherited done
end;

procedure twordlist.append(s: string);
begin
inc(count);
if not put(count, s) then
begin
dec(count);
writeln('max_words limit exceeded !')
end
end;


function twordlist.last: integer;
begin last := count end;


function copy_delete(var s: string;
index, count: integer): string;
begin
copy_delete := copy(s, index, count);
delete(s, index, succ(count))
end;

procedure twordlist.find(s: string;
iterator: titerator);
var i, ps: Byte;
Begin
for i := 1 to length(s) do
if s[i] in iterator then s[i] := #32;

repeat
if pos(ps, str_doublespace, s)
then delete(s, ps, 1)
until ps = 0;

If s[1] = ' ' Then Delete(s, 1, 1);
If s[Length(s)] = ' ' Then
Delete(s, Length(s), 1);

i := 0;
repeat
if pos(ps, str_singlespace, s) then
append(copy_delete(s, 1, pred(ps)))
else append(s)
until ps = 0
End;

var
i, count: Word;
words: twordlist;

const
s: string = ' That,is all:folks ';
begin
words.init(s, str_punct);

writeln('the_test:');
for i := words.first to words.last do
writeln(words.get(i)^);
words.done
end.

файл array.pas прилагается: Прикрепленный файл  ARRAY.PAS ( 6.35 килобайт ) Кол-во скачиваний: 1177
 К началу страницы 
+ Ответить 
сообщение
Сообщение #3


Гость






Этот - немного попроще, здесь реализован список слов:
type
TWordStr = string[100];
TDelimiter = set of Char;

{ Опишем структуру для хранения списка слов }
PTItem = ^TItem;
TItem = record
Data: TWordStr;
next: PTItem;
end;
TWordList = record
first, last: PTItem;
end;

{
Эта процедура добавляет переданную ей строку к списку L
}
procedure InsertWord(var L: TWordList; s: string);
var p: PTItem;
begin
New(p);
p^.Data := s;
p^.next := nil;

if L.first = nil then L.first := p
else L.last^.next := p;
L.last := p
end;

{
Функция разбиения строки на слова
}
function GetWords(s: string; var L: TWordList; delimiters: TDelimiter): Byte;
var i, p: Byte;
begin
for i := 1 to Length(s) do
if s[i] In delimiters then s[i] := #32;

{ Удаляем лишние пробелы }
repeat
p := Pos(' ', s);
if p > 0 then Delete(s, p, 1)
until p = 0;
{ Удаляем пробел из начала строки (если есть) }
if s[1] = ' ' then Delete(s, 1, 1);
{ Удаляем замыкающий пробел (если есть) }
if s[Length(s)] = ' ' then Delete(s, Length(s), 1);

i := 0;
repeat
p := Pos(' ', s); Inc(i);
if p > 0 then begin
InsertWord(L, Copy(s, 1, Pred(p)));
Delete(s, 1, p)
end
else InsertWord(L, s)
until p = 0;
GetWords := i
end;

var
i, count: Word;
L: TWordList;

const
s: string = ' That is - all folks;;. ';
var
p: ptitem;

begin
Count := GetWords(s, L, ['-', ';', '.']);
WriteLn(Count, ' words found ...');

p := L.first;
while p <> nil do begin
WriteLn(p^.Data);
p := p^.next;
end;
end.
 К началу страницы 
+ Ответить 
сообщение
Сообщение #4


Ищущий истину
******

Группа: Пользователи
Сообщений: 4 825
Пол: Мужской
Реальное имя: Олег

Репутация: -  45  +


Функция с дополнительными возможностями.
function SepWord(s,Alf:string):tlist;

Функция вовзращает указатель на структуру вида:

TElem = string;
TList = ^TNode;
TNode = record
Info: TElem;
Next: TList
end;


Проще говоря, на односвязный, динамический список:
Прикрепленное изображение

Параметры вызова функции
s (string) - строка, подлежащая разбиению на слова.
Alf (string) - пользовательский алфавит.
описание
Если первый символ $, то alf интерплитируется как алфавит.
Пример
alf='$1234567890';
тогда алфавит = {'1','2','3','4','5','6','7','8','9','0'}
То есть таким образом можно легко распознавать например только числа в строке с мусором.
Если первый символ # то далее идущие символы интерплитируются как разделители.
Если первый символ другой, то alf - имя файла из которого считывается алфавит (символы - НЕ разделители).

Код функции


function SepWord(s,Alf:string):tlist;
procedure AddLast(var L: TList; E: TElem);
var
N, P: TList;
Begin
new(N);
N^.Info :=E; N^.Next :=nil;
if L= nil then L:=N else begin
P:=L;
while P^.Next <> nil do P:=P^.Next;
P^.Next:=N
end
End;
const
i:integer=1;
r:set of char = [chr(0)..chr(255)]-['A'..'Z','a'..'z','1'..'9','0'];
var
SL:boolean; L: TList; ss:string;f:file of byte;b:byte;
begin
if Alf<>'' then begin
if (alf[1]<>'#') and (alf[1]<>'$') then begin
assign(f,alf); {$I-} reset(f); {$I+}
if IOresult=0 then begin
while not eof(f) do begin
read(f,b);
include(r,chr(b));
end;
r:= [chr(0)..chr(255)]-r;
close(f)
end
end else begin
r:=[];
if alf[1]='#' then for i:=2 to length(alf) do include(r,alf[i]);
if alf[1]='$' then begin
for i:=2 to length(alf) do include(r,alf[i]) ;
r:= [chr(0)..chr(255)]-r;
end;
end;
end;
sl:=false; L:=nil; ss:='' ; i:=1;
while i<=length(s) do begin
if ((not(s[i] in r)) and (sl=false)) then sl:=true;
if (not(s[i] in r)) and (sl=true) then ss:=ss+s[i];
if ((s[i] in r)or(i=length(s))) and (sl=true) then
begin
AddLast(L,ss); ss:=''; sl:=false;
end;
inc(i)
end;
SepWord:=L;
end;


Пример программы:Прикрепленный файл  test.pas ( 1.91 килобайт ) Кол-во скачиваний: 1252


Используемый алгоритм

Просматриваем строку.
Изначально полагаем что мы не просматриваем слово.
Далее если встречаем НЕ разделитель , а признак просмотра слова ложь, меняем признак на ИСТИНУ.
Далее если встречаем символ не разделитель и признак слова не ложь то прибавляем символ к временнйо строке.
Если стретили символ разделитель и признак слова истина, то
добавляем слово из временнйо строку в список слов.
обнуляем временную строку.
признак слова в ложь
переходим к следующему символу.


--------------------
Помогая друг другу, мы справимся с любыми трудностями!
"Не опускать крылья!" (С)
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #5


Ищущий истину
******

Группа: Пользователи
Сообщений: 4 825
Пол: Мужской
Реальное имя: Олег

Репутация: -  45  +


Эмулирование стандартных классов в Delphi
Еще один вариант с ООП и ДСД (односвязные списки).
Процедура очень легко портируется на Delphi с использованием класса Tstrings
smile.gif

const
Delimiters:set of char = [',', ';', ':', ' '];
Type
TElem = string;
TList = ^TNode;
TNode = record
Info: TElem;
Next: TList
end;
TStrings = Object
private
data:tlist;
public
count:integer;
procedure INIT;
procedure ADD(e:String);
procedure print;
procedure Clear;
End;
procedure Tstrings.INIT;
begin
data:=nil;
end;


Procedure Tstrings.ADD(e:string);
var
N: TList;
P: TList;
Begin
new(N);
N^.Info :=E;
N^.Next :=nil;
if data= nil then data:=N else
begin
P:=data;
while P^.Next <> nil do P:=P^.Next;
P^.Next:=N
end; inc(count);
End;

Procedure Tstrings.print;
begin
write('[ ');
while data <> nil DO
begin
write( data^.Info );
If data^.Next <> nil then write(' | ');
data := data^.Next
end;
writeln(' ]')
end;

procedure TStrings.clear;
var
N: TList;
begin
while data <> nil do
begin
N :=data;
data:=data^.Next;
dispose(N)
end
end;



function GetWords(const S: string; var L: TStrings): integer;
var len, idx1, idx2: integer;
begin
Result := 0;
if Length(S) = 0 then Exit;
L.clear;
len := Length(S);
idx2 := 1;
repeat
while (idx2 <= len) and (S[idx2] in Delimiters) do inc(idx2);
idx1 := idx2;
if (idx2 <= len) and not (S[idx2] in Delimiters) then
while (idx2 <= len) and not(S[idx2] in Delimiters) do inc(idx2);
if idx1 < idx2 then
L.Add(Copy(S, idx1, idx2-idx1));
until idx2 > len;
Result := L.Count;

end;

var S: string;
L:TStrings;
begin
S := 'str1,str2;str3;;: str4,,,,,';
L.INIT;
writeln(GetWords(S, L));
L.print;
L.clear;

reADLN;
end.

Функция разбивает строку S на слова, используя набор символов Delimiters в качестве разделителей и заносит их в список L. Результат функции - количество найденных слов.


--------------------
Помогая друг другу, мы справимся с любыми трудностями!
"Не опускать крылья!" (С)
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #6


Гость






Это - довольно простой способ (информация о найденных словах хранится в массиве, но НЕ в виде самих слов, а в виде <начало слова в строке, длина слова>):
const
delimiter = [#32, ',', '.', '!', ':'];
type
wrd_info = record
start, len: byte;
end;

function get_words(s: string;
var words: array of wrd_info): integer;
var
count: integer;

i, curr_len: byte;

begin
count := -1; i := 1;
while i <= length(s) do begin

while (s[i] in delimiter) and (i <= length(s)) do inc(i);

curr_len := 0;
while not (s[i] in delimiter) and (i <= length(s)) do begin
inc(i); inc(curr_len);
end;

if curr_len > 0 then begin
inc(count);
with words[count] do begin
start := i - curr_len;
len := curr_len
end;
end;

end;
get_words := count + 1;
end;


const
max_word = 255;
var
words: array[1 .. max_word] of wrd_info;
i, n: integer;

const
s: string = 'thats,,, all :: folks !!! bye...';

begin
n := get_words(s, words);
writeln('words:');
for i := 1 to n do
writeln(copy(s, words[i].start, words[i].len));
end.
 К началу страницы 
+ Ответить 
сообщение
Сообщение #7


Perl. Just code it!
******

Группа: Пользователи
Сообщений: 4 100
Пол: Мужской
Реальное имя: Андрей

Репутация: -  44  +


я вот это использую всегда :

const

limits = [#0..#32,'.',',',':',';','!','?','"'];
type

TWords = array[1..40] of string;

var
text : string;
words : TWords;

function GetWords(s : string; var w : TWords) : byte;
var
i,back,n : byte;
begin
i := 1;
n := 0;
while(i<=length(s)) do begin
while(i<=length(s)) and (s[i] in limits) do
inc(i);
if i<=length(s) then begin
back := i;
while(i<=length(s)) and not(s[i] in limits) do
inc(i);
inc(n);
w[n] := copy(s, back, i-back);
end;
end;

GetWords := n;
end;


Сообщение отредактировано: klem4 -


--------------------
perl -e 'print for (map{chr(hex)}("4861707079204E6577205965617221"=~/(.{2})/g)), "\n";'
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #8


Новичок
*

Группа: Пользователи
Сообщений: 11
Пол: Мужской
Реальное имя: Юлиан

Репутация: -  -1  +


Еще один способ разбивки строки на слова (похож на метод в сообщении № 3).
Алгоритм таков:
1) Заменяем все знаки пунктуации на пробелы (так же как и в методе в сообщении № 3).)
2) Удаляем все лишние пробелы (так же как и в методе сообщении № 3) и добавим последний пробел, если его нет.
3) Находим кол-во пробелов, в нашем случае оно будет равняться кол-ву слов, так как мы заранее добавили последний пробел.
Заносим местоположение пробелов в байтовый массив
4) Ориентируясь на местоположение в строке пробелов, которое хранится в массиве, копируем слова в динамический список.
В методе, представленном volvo в сообщении № 3, находится первый пробел во время цикла с помощью функции Pos, затем копируется часть строки с начала строки до первого пробела (слово) в динамический список, затем строка обрезается и поиск начинается сначала, и так до тех пор, пока в строке ничего не останется.
В представленном мной методе сперва находятся все пробелы, а затем в соответствии с их местоположением копируются слова в динамический массив, строка при этом не обрезается (за начало каждого слова отвечает переменная start, которой перед циклом присваивается значение 1 (начало первого слова), затем её значение равно местоположению очередного пробела + 1: start := x[i3] + 1, длина слова определяется разностью между местоположением пробела и переменной start: x[i3] - start )
program cuxtstringpr;

const delimeters : set of char = [',','.',':',';','-', '!', '?'];

type Spisok = ^spisoks;
spisoks = record
words : string;
link : spisok;
end;

spsrecord = record
First, Last : spisok;
end;

spsarray = array [1..128] of byte;

var s : string;
p : spisok;
sps : spsrecord;

function changetosps (s : string) : string; {заменим все разделители пробелами}
var i : byte;
begin
for i := 1 to length(s) do
if s[i] in delimeters then
s[i] := #32;

changetosps := s
end;

function clearsps (s : string) : string; {удалим лишние пробелы}
var x : byte;
begin
repeat
x := pos (#32#32, s);
if x <> 0 then
delete (s, x, 1)
until x = 0;

if s[1] = #32 then
delete (s, 1, 1);
if s[length(s)] <> #32 then
s := s + ' ';

clearsps := s
end;

procedure cutstring (var sps : spsrecord; s : string);
var i, i2, i3, start : byte;
x : spsarray;
numwords : byte;

procedure addsps (var sps : spsrecord; s : string); {добавить в список}
var p : spisok;
begin
with sps do begin
if first = nil then begin
new (last);
first := last
end else begin
new (last^.link);
last := last^.link
end;
last^.words := s;
last^.link := nil
end

end;

begin
{инициализация}
sps.first := nil;
sps.last := nil;
numwords := 0; {кол-во слов - 0}

s := clearsps (changetosps(s)); {очистим строку от мусора}

{найдем кол-во пробелов и добавим их расположение
в массив}

i2 := 0; {длина заполненного массива}
for i := 1 to length (s) do
if s[i] = #32 then begin
inc (numwords);
inc (i2);
x[i2] := i
end;

{добавляем слова в список}
start := 1;
for i3 := 1 to i2 do begin
addsps (sps, copy (s, start, x[i3] - start));
start := x[i3] + 1
end
end;

begin
s := 'Hello, Mike! How are you, my dear friend:??';
cutstring (sps, s);
p := sps.first;
while p <> nil do begin
writeln (p^.words);
p := p^.link
end;
readln
end.



Сообщение отредактировано: kornet -
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 

 Ответить  Открыть новую тему 
1 чел. читают эту тему (гостей: 1, скрытых пользователей: 0)
Пользователей: 0

 




- Текстовая версия 18.01.2018 8:45
Хостинг предоставлен компанией "Веб Сервис Центр" при поддержке компании "ДокЛаб"