Подраздел FAQ (ЧАВО, ЧАстые ВОпросы) предназначен для размещения готовых рабочих программ, реализаций алгоритмов. Это нечто вроде справочника, он наполнялся в течение 2000х годов. Ваши вопросы, особенно просьбы решить задачу, не пройдут предмодерацию. Те, кто наполнял раздел, уже не заходят на форум, а с теми, кто на форуме сейчас, лучше начинать общение в других разделах. В частности, решение задач — здесь.
Предлагаю в теме собрать все способы разбиения строки на слова. (рекурсивные, итерационные, с использованием массивов, без использования массивов, с ДСД, с чем-то еще... вобщем программы и алгоритмы преобразования предложения в набор слов )
СОБИРАЕМ!
--------------------
Помогая друг другу, мы справимся с любыми трудностями! "Не опускать крылья!" (С)
Этот - немного попроще, здесь реализован список слов:
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.
Проще говоря, на односвязный, динамический список:
Параметры вызова функции 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 килобайт )
Кол-во скачиваний: 1926
Используемый алгоритм
Просматриваем строку. Изначально полагаем что мы не просматриваем слово. Далее если встречаем НЕ разделитель , а признак просмотра слова ложь, меняем признак на ИСТИНУ. Далее если встречаем символ не разделитель и признак слова не ложь то прибавляем символ к временнйо строке. Если стретили символ разделитель и признак слова истина, то добавляем слово из временнйо строку в список слов. обнуляем временную строку. признак слова в ложь переходим к следующему символу.
--------------------
Помогая друг другу, мы справимся с любыми трудностями! "Не опускать крылья!" (С)
Эмулирование стандартных классов в Delphi Еще один вариант с ООП и ДСД (односвязные списки). Процедура очень легко портируется на Delphi с использованием класса Tstrings
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. Результат функции - количество найденных слов.
--------------------
Помогая друг другу, мы справимся с любыми трудностями! "Не опускать крылья!" (С)
Это - довольно простой способ (информация о найденных словах хранится в массиве, но НЕ в виде самих слов, а в виде <начало слова в строке, длина слова>):
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.
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";'
Еще один способ разбивки строки на слова (похож на метод в сообщении № 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.