Разбиение на слова. Все способы. Опции

[Altair]

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

СОБИРАЕМ!

[volvo]

Пожалуй, самый извращенный способ - используется реализация динамического массива (из 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 килобайт ) Кол-во скачиваний: 1688

[volvo]

Этот - немного попроще, здесь реализован список слов:

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.

[Altair]

Функция с дополнительными возможностями.

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 килобайт ) Кол-во скачиваний: 1697


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

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

[Altair]

Эмулирование стандартных классов в 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. Результат функции - количество найденных слов.

[volvo]

Это - довольно простой способ (информация о найденных словах хранится в массиве, но НЕ в виде самих слов, а в виде <начало слова в строке, длина слова>):

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.

[klem4]

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

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 - 18.11.2005 8:34

[kornet]

Еще один способ разбивки строки на слова (похож на метод в сообщении № 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 - 19.08.2007 11:01