Операции над строками

@TAVulator · Регистрация: 27.07.2009

В этой теме представлены реализации алгоритмов работы со строками.
Выкладывайте свои реализации на языке Pascal.

Содержание

1. Замена первого вхождения подстроки другой подстрокой

Pascal

Function Replace(var S:string; s1,s2:string):byte;
{Замена первого вхождения подстроки другой подстрокой.
Replace(Строка, Подстрока, На что заменить);
Результатом функции является число - на какой
позиции в строке была найдена подстрока.
Возвращается 0, если подстрока не найдена.}
 
Begin
 if ((length(S)+length(s2)-length(s1))<=255)and
    (pos(s1,S)<>0) then
  Begin
   Replace:=pos(S,s1);
   S:=copy(S,1,pos(s1,S)-1)+s2+copy(S,pos(s1,S)+length(s1),length(S));
  End else Replace:=0;
End;

Автор: TAVulator

2. Функция удаления лишних пробелов

Pascal

Function OneSpace(S:string;B:boolean):string;
{Функция удаления лишних пробелов.
OneScpace(Строка,true/false - удалять
или нет пробелы в начале и в конце строки);
Результатом функции является строка с удаленными
лишними пробелами.}
var
 T: string;
Begin
 T:=S;
 while pos('  ',T)>0 do
  delete(T,pos('  ',T),1);
 if B then
  Begin
   if T[1]=' ' then delete(T,1,1);
   if T[length(T)]=' ' then delete(T,length(T),1);
  End;
 OneSpace:=T;
End;

Автор: TAVulator

3. Функция переворачивания строки

Pascal

Function Revert(S: string):string;
var
 i: byte;
 T: string;
Begin
 T:='';
 For i:=length(S) downto 1 do
  T:=T+S[i];
 Revert:=T;
End;

Версия для Free Pascal:

Pascal

Function Revert(S: string):string;
{Функция переворачивания строки}
var
 i: byte;
Begin
 Revert:='';
 For i:=length(S) downto 1 do
  Revert:=Revert+S[i];
End;

Автор: TAVulator

4. Функция разбития строки на слова.
5. Функция переворачивания строки. Вариант 2.
6. Удаление двойных пробелов.
7. Удаление пробелов вначале и в конце строки.
8. Удаление повторяющихся пробелов без использования Delete
9. Замена первого вхождения слова другим словом.

10. Извлечение нужного слова из строки

Free Pascal

Pascal

Function GetWord(S: string; N: byte): String;
Var
 Str: string;
 i: byte;
Begin
 Str:=S+' ';
 For i:=1 to N-1 do
  delete(Str,1,pos(' ',Str));
 GetWord:=Copy(Str,1,Pos(' ',Str)-1);
End;

Автор: TAVulator

11. Перевод строки в биты
12. Удаление пробелов из строки
13. Выделение имени файла из полного пути
14. Набор функций для работы с путями и именами файлов и папок

@rangerx · 24.12.2010, 01:38

Функция разбития строки на слова.

Pascal

{Функция разбивает строку на слова и помещает их в строковый массив dest
Возвращаемое значение:  количество слов помещенных в массив.}
type DelimSet = set of char;
 
function split(var dest: array of string; const s: string; const delim: DelimSet): integer;
var
  n, i, len: integer;
begin
  n:= 0;
  i:= 1;
  len:= Length(s);
 
  while (i <= len) do begin
    if s[i] in delim then
      repeat inc(i) until (i > len) or (not (s[i] in delim))
    else begin
      dest[n]:= '';
      while (i <= len) and (not (s[i] in delim)) do begin
        dest[n]:= dest[n] + s[i];
        inc(i);
      end;
      inc(n);
    end;
  end;
  split:= n;
end;

@Inadequate · 25.12.2010, 05:41

Сообщение от TAVulator

Pascal

Function Revert(S: string):string;
var
 i: byte;
 T: string;
Begin
 T:='';
 For i:=length(S) downto 1 do
  T:=T+S[i];
 Revert:=T;
End;

Я бы написал так

Pascal

function Reverse(s: string): string;
var
  i, sLen: byte;
  tmp: char;
begin
  sLen := Length(s);
  for i := 1 to sLen div 2 do
  begin
    tmp := s[i];
    s[i] := s[sLen - i + 1];
    s[sLen - i + 1] := tmp;
  end;
  Reverse := s;
end;

Теперь удаление двойных пробелов и удаление их вначале и в конце строки... Не хочу мешать в одну кучу, поэтому разобью на две отдельные функции

Pascal

function DeleteDoubleS(s: string): string;
var
  i: byte;
begin
  for i := Length(s) - 1 downto 1 do
    if (s[i] = ' ') and (s[i + 1] = ' ') then
      Delete(s, i, 1);
  DeleteDoubleS := s;
end;

Pascal

function MyTrim(const s: string): string;
var
  i,sLen: byte;
begin
  sLen := Length(s);
  i := 1;
  while (s[i] = ' ') and (i <= sLen) do
    Inc(i);
  if i > sLen then
    MyTrim := ''
  else
  begin
    while s[sLen] = ' ' do
      Dec(sLen);
    MyTrim := Copy(s, i, sLen - i + 1);
  end;
end;

Ну и теперь функция замены слова... Вчера, видимо, сильно хотел спать, потому как не очень внимательно посмотрел эту функцию. Она работает неправильно, ну или выполняет совсем не то, что заявлено в описании. Хотя после приколов Free Pascal наверное не буду спешить с определениями. Скажем так, на ABC, TP7, Console (Delphi) будет выводить не то, что нужно. Для того, чтобы убедиться в этом достаточно попробовать заменить в строке, скажем "you need to see all" слово "ee". Если речь идет именно о замене слов, а не части строки, то я бы написал так

Pascal

function Replace(const s,wF,wR: string): string;
const
  Dividers = [' ', '.', ',', ':', '-', ';'];
var
  i,sLen: byte;
  tmp: string;
begin
  sLen := Length(s);
  tmp := '';
  for i := 1 to sLen do
  begin
    if not (s[i] in Dividers) then
      tmp := tmp + s[i];
    if (s[i] in Dividers) or (i = sLen) then
      if tmp = wF then
      begin
        if (i = sLen) and not (s[i] in Dividers) then
          Replace := Copy(s, 1, i - Length(wF)) + wR + Copy(s, i + 1, 255)
        else
          Replace := Copy(s, 1, i - Length(wF) - 1) + wR + Copy(s, i, 255);
        exit;
      end
      else
        tmp := '';
  end;
  Replace := s;
end;

Условие на строке 17 добавил для совместимости. Конечно можно было все лихо сделать с помощью Ord(boolean), но не везде такое прокатит. Вполне возможно, что допустил где-то ошибки, глаза уже слипаются... Буду признателен, если укажут на их присутствие.

@Somebody · 25.12.2010, 15:45

В удалении повторяющихся пробелов использование Delete неоптимально. Как вариант:
TP

Pascal

function RemoveExtraSpaces(s: string): string;
var
  src, dst: Byte;
begin
  src := 1;
  dst := 1;
  while src <= Length(s) do
  begin
    s[dst] := s[src];
    inc(dst);
    if s[src] <> ' ' then
      inc(src)
    else
      repeat
        inc(src);
      until (src <= Length(s)) and (s[src] <> ' ');
  end;
  s[0] := Char(Byte(dst) - 1);
  RemoveExtraSpaces := s;
end;

Delphi/FP для длинных строк

Delphi

function RemoveExtraSpaces(s: string): string;
var
  src, dst: Integer;
begin
  src := 1;
  dst := 1;
  while src <= Length(s) do
  begin
    s[dst] := s[src];
    inc(dst);
    if s[src] <> ' ' then
      inc(src)
    else
      repeat
        inc(src);
      until s[src] <> ' ';
  end;
  SetLength(s, dst - 1);
  RemoveExtraSpaces := s;
end;

@sergey93 · 07.04.2011, 19:12

Удаление пробелов из строки

Pascal

program prob;
var
  s:string;
  i,k:integer;
begin
 readln(s);
   for i:=1 to length(s) do
     begin
      k:=pos(' ',s);
      if k>0 then delete(s,k,1)
     end;
 write(s);
end.

@TAVulator · 07.04.2011, 19:50 **[ТС]**

Сообщение от sergey93

Удаление пробелов из строки

как на счет такого варианта:

Pascal

var
 S: string;
Begin
 S:=' fgf hh yy   hy  rf g'; {строка}
 while pos(' ',S)<>0 do delete(S,pos(' ',S),1);
 writeln(S);
 readln;
end.

@S9 · 08.04.2011, 12:29

Как то писал функцию перевода строки в биты(т.е. не совсем биты, а строка состоящая из 0 и 1)
Может кому пригодится

Pascal

Function StrToBin(TextValue:String):String;
 
    Function DecToBin(Int:Longint):String;{Перевод из 10 системы в 2 систему}
        Var
        StringConst:String[2];
        Res:String;
    Begin
        StringConst:='01';
        Res:='';
    Repeat
        Res:=StringConst[(Int Mod 2)+1] + Res;
        Int:=Int Div 2;
    Until Int=0;
        DecToBin:=Res;
    End;
 
Var
    TempString:String;
    OctString:String;
    BinString:String;
    i,k:Integer;
Begin
    For i:=1 To Length(TextValue) Do 
Begin
    TempString:=DecToBin(Ord(TextValue[i]));
    OctString:='';
If Length(TempString)<8 Then 
    Begin
        For k:=1 To 8-Length(TempString) Do 
            Begin
            OctString:=OctString+'0';
            End;
        End;
        TempString:=OctString+TempString;
        BinString:=BinString+TempString;
        StrToBin:=BinString;
    End;
End;

@S9 · 09.04.2011, 08:43

В дополнении хотел добавить ещё одну функцию, которая выделяет из полного пути к файлу
имя файла с расширением или без него(задается в параметрах).
З.Ы.Если есть стандартные функции делающие то-же самое то просьба меня извинить, я их не знаю

Pascal

Function InWayFileName(Way:String;Expansion:Boolean):String;
    Var
        Name:String;{Если Expansion = True тогда результат функции имя файла с расширением, если False то выводится}
        i,j,k:Integer;{просто имя файла(без расширения)}
    Begin
        k:=0;
        j:=0;
        Name:='';
    For i:=1 To Length(Way) Do 
        Begin{Находим последний слеш в пути}
            k:=k+1;
            If Way[i]='\' Then j:=k;
        End;
    If Expansion = True Then 
        Begin
            For i:=j+1 To Pos('.',Way)-1 Do
                Name:=Name+Way[i];
        End Else
            For i:=j+1 To Length(Way) Do
                Name:=Name+Way[i];
    InWayFileName:=Name;
End;

@SuPeR XaKer · 09.04.2011, 11:22

S9
уж больно сложно.Это и так можно сделать.

Pascal

Function Filename(Var str:string;f:boolean):string;
var
 s:string;
 i:byte;
begin
 for i:=length(str) downto 1 do
 if str[i]<>'\' then s:=str[i]+s
 else break;
 if f then Filename:=copy(s,1,pos('.',s)-1)
 else Filename:=s
end;

да и следует учесть то что может быть задан путь к каталогу а не к определённому файлу:

Pascal

Function Filename(Var str:string;f:boolean):string;
var
 s:string;
 i:byte;
begin
 for i:=length(str) downto 1 do
 if str[i]<>'\' then s:=str[i]+s
 else break;
 if pos('.',s)=0 then writeln('Êàòàëîãè,ôàéëà íåò')
 else if f then Filename:=copy(s,1,pos('.',s)-1)
 else Filename:=s
end;

22.06.2011, 15:04

может кто-нибудь организует все операции в процедуры? думаю будет полезным и удобным.
как вот здесь:
Сортировки

@Jaguar · 25.08.2011, 02:03

Я бы написал так

Pascal

function Reverse(s: string): string;
var
  i, sLen: byte;
  tmp: char;
begin
  sLen := Length(s);
  for i := 1 to sLen div 2 do
  begin
    tmp := s[i];
    s[i] := s[sLen - i + 1];
    s[sLen - i + 1] := tmp;
  end;
  Reverse := s;
end;

Можно еще такс:

Pascal

function Reverse( s: string):string;
var
  i, sLen:Byte;
Begin
  sLen:=length(s);
  for i:=1 to sLen do 
begin
   Insert(s[sLen], s, i);
   Delete(s, sLen+1, sLen);
end;
 Reverse:=s;
End;

@Mawrat · 18.09.2011, 05:43

Предлагаю набор функций для работы с путями и именами файлов и папок в среде Borland и Turbo Pascal.
Выполнил в виде модуля:

Pascal

unit FnUtils;
 
interface
 
(*Получить полное имя файла.*)
function GetFullFileName(const aFileName : String) : String;
(*Получить имя файла с расширением без пути.*)
function GetFileName(const aFileName : String) : String;
(*Получить имя файла без пути и без расширения.*)
function GetShortFileName(const aFileName : String) : String;
(*Получить расширение файла.*)
function GetFileExt(const aFileName : String) : String;
(*Получить полный путь к папке, в которой расположен заданный файл.*)
function GetFilePath(const aFileName : String) : String;
(*Получить полное имя исполняемого файла программы.*)
function GetExeName : String;
(*Получить полный путь к папке, в которой расположен исполняемый файл программы.*)
function GetExePath : String;
 
implementation
 
uses
  Dos;
 
(*
Получить полное имя файла.
---
Пример1:
Текущая папка   = 'D:\Bp\Projects\'
aFileName       = '0001\File1.txt'
GetFullFileName = 'D:\Bp\Projects\0001\File1.txt'
---
Пример2:
Текущая папка   = 'D:\Bp\Projects\0001\'
aFileName       = '..\0002\File1.txt'
GetFullFileName = 'D:\Bp\Projects\0002\File1.txt'
---
Пример3:
aFileName       = 'D:\Bp\Projects\0001\File1.txt'
GetFullFileName = 'D:\Bp\Projects\0001\File1.txt'
*)
function GetFullFileName(const aFileName : String) : String;
begin
  GetFullFileName := FExpand(aFileName);
end;
 
(*
Получить имя файла с расширением без пути.
---
Пример1:
aFileName   = 'D:\Bp\Projects\0001\File1.txt'
GetFileName = 'File1.txt'
*)
function GetFileName(const aFileName : String) : String;
var
  (*Путь к файлу без имени самого файла.*)
  FDir : DirStr;
  (*Имя файла без пути и без расширения.*)
  FName : NameStr;
  (*Расширение файла.*)
  FExt : ExtStr;
begin
  FSplit(aFileName, FDir, FName, FExt);
  GetFileName := FName + FExt;
end;
 
(*
Получить имя файла без пути и без расширения.
---
Пример1:
aFileName        = 'D:\Bp\Projects\0001\File1.txt'
GetShortFileName = 'File1'
*)
function GetShortFileName(const aFileName : String) : String;
var
  FDir : DirStr;
  FName : NameStr;
  FExt : ExtStr;
begin
  FSplit(aFileName, FDir, FName, FExt);
  GetShortFileName := FName;
end;
 
(*Получить расширение файла.
---
Пример1:
aFileName  = 'D:\Bp\Projects\0001\File1.txt'
GetFileExt = '.txt'
---
Пример2:
aFileName  = 'File1'
GetFileExt = ''
*)
function GetFileExt(const aFileName : String) : String;
var
  FDir : DirStr;
  FName : NameStr;
  FExt : ExtStr;
begin
  FSplit(aFileName, FDir, FName, FExt);
  GetFileExt := FExt;
end;
 
(*
Получить полный путь к папке, в которой расположен заданный файл.
---
Пример1:
Текущая папка = 'D:\Bp\Projects\'
aFileName     = '0001\File1.txt'
GetFilePath   = 'D:\Bp\Projects\0001\'
---
Пример2:
Текущая папка = 'D:\Bp\Projects\0001\'
aFileName     = '..\0002\File1.txt'
GetFilePath   = 'D:\Bp\Projects\0002\'
---
Пример3:
Текущая папка - нет зависимости от текущей папки.
aFileName     = 'D:\Bp\Projects\0001\File1.txt'
GetFilePath   = 'D:\Bp\Projects\0001\'
*)
function GetFilePath(const aFileName : String) : String;
var
  (*Полное имя файла - состоит из полного пути и имени файла с расширением.*)
  FullFileName : String;
  (*Путь к файлу без имени самого файла.*)
  FDir : DirStr;
  (*Имя файла без пути и без расширения.*)
  FName : NameStr;
  (*Расширение файла.*)
  FExt : ExtStr;
begin
  FullFileName := FExpand(aFileName);
  FSplit(FullFileName, FDir, FName, FExt);
  GetFilePath := FDir;
end;
 
(*
Получить полное имя исполняемого файла программы. - Т. е., полный путь
с именем файла и с расширением.
---
Пример1:
Текущая папка = 'D:\Bp\Projects\'
ParamStr(0)   = '0001\PROJECT1.EXE'
GetExeName    = 'D:\BP\PROJECTS\0001\PROJECT1.EXE'
*)
function GetExeName : String;
begin
  GetExeName := FExpand( ParamStr(0) );
end;
 
(*
Получить полный путь к папке, в которой расположен исполняемый файл
программы.
---
Пример1:
Текущая папка = 'D:\Bp\Projects\'
ParamStr(0)   = '0001\PROJECT1.EXE'
GetExePath    = 'D:\BP\PROJECTS\0001\'
*)
function GetExePath : String;
var
  FullFileName : String;
  FDir : DirStr;
  FName : NameStr;
  FExt : ExtStr;
begin
  FullFileName := FExpand( ParamStr(0) );
  FSplit(FullFileName, FDir, FName, FExt);
  GetExePath := FDir;
end;
 
end.

Пример использования на примере задачи: "Скопировать файл в папку, в которой расположен исполняемый файл программы. При этом, файл переименовать".

Pascal

program Project1;
 
uses
  FnUtils;
 
const
  (*Размер буфера в байтах для копирования данных.*)
  Size = 10000;
var
  (*Файловые переменные.*)
  F1, F2 : File;
  (*Имена файлов.*)
  Fn1, Fn2 : String;
  (*Указатель на буфер в памяти.*)
  PBuff : Pointer;
  (*Количество прочитанных байт из файла.*)
  Cnt : Integer;
  S : String;
begin
  repeat
    Writeln('Задайте путь и имя исходного файла:');
    Readln(Fn1);
    Assign(F1, Fn1);
    (*Попытка открыть файл. Установка режима доступа с минимальным
    блоком в 1 байт.*)
    {$I-}
    Reset(F1, 1);
    {$I+}
    if IOResult <> 0 then begin
      Writeln('Не удалось открыть указанный файл. Действие отменено.');
      Writeln('Повторить - Enter. Выход - любой символ + Enter.');
      Readln(S);
      Continue;
    end;
 
    (*Формируем полное имя целевого файла на основе имени исходного файла.*)
    Fn2 := GetExePath + Copy(GetShortFileName(Fn1), 1, 5) + '_cp' + GetFileExt(Fn1);
 
    Assign(F2, Fn2);
    (*Создание файла и открытие его в режиме доступа с минимальным
    блоком в 1 байт.*)
    Rewrite(F2, 1);
    (*Выделяем память для буфера и получаем указатель на первый байт
    выделенной памяти.*)
    GetMem(PBuff, Size);
    (*Копирование всего содержимого исходного файла в целевой файл.*)
    while not Eof(F1) do begin
      BlockRead(F1, PBuff^, Size, Cnt);
      BlockWrite(F2, PBuff^, Cnt);
    end;
 
    (*Освобождение памяти буфера.*)
    FreeMem(PBuff, Size);
    (*Закрытие файлов.*)
    Close(F1);
    Close(F2);
 
    Writeln('Файл:');
    Writeln(Fn1);
    Writeln('Скопирован под именем:');
    Writeln(Fn2);
 
    Writeln('Повторить - Enter. Выход - любой символ + Enter.');
    Readln(S);
  until S <> '';
end.

@BakhtiyarZ · 23.12.2011, 14:51

Сообщение от Incred

может кто-нибудь организует все операции в процедуры? думаю будет полезным и удобным.
как вот здесь:
Сортировки

Было бы еще лучше если бы каждая переменная описывалась для чего она необходима.
И не могли бы вы добавить процедуру удваивания каждого символа в предложении.

Комментарий модератора

BakhtiyarZ, здесь, видимо, нет смысла по этой задаче размещать отдельный пост. Поэтому напишу прямо в твоём сообщении:

Удвоение каждого символа в строке:

Pascal

var
  S : String;
  i : Integer;
begin
  Writeln('Задайте строку:');
  Readln(S);
  for i := Length(S) downto 1 do Insert(S[i], S, i);
  Writeln('Строка после обработки:');
  Writeln(S);
  Readln;
end.

Так как при вставках символов длина строки изменяется, поэтому применён цикл for downto. - Таким образом, при проходе строки от конца - к началу алгоритм становится не зависящим от изменений длины строки.

@TAVulator · 24.12.2011, 09:19 **[ТС]**

Сообщение от BakhtiyarZ

Было бы еще лучше если бы каждая переменная описывалась для чего она необходима.

не вижу в этом смысла

@suiseiseki · 01.12.2012, 19:48

Сообщение от rangerx

Функция разбития строки на слова.

Pascal

{Функция разбивает строку на слова и помещает их в строковый массив dest
Возвращаемое значение:  количество слов помещенных в массив.}
type DelimSet = set of char;
 
function split(var dest: array of string; const s: string; const delim: DelimSet): integer;
var
  n, i, len: integer;
begin
  n:= 0;
  i:= 1;
  len:= Length(s);
 
  while (i <= len) do begin
    if s[i] in delim then
      repeat inc(i) until (i > len) or (not (s[i] in delim))
    else begin
      dest[n]:= '';
      while (i <= len) and (not (s[i] in delim)) do begin
        dest[n]:= dest[n] + s[i];
        inc(i);
      end;
      inc(n);
    end;
  end;
  split:= n;
end;

Пример использования этого можно? Что за параметр такой - dest? Как понимаю, этому массиву надо самостоятельно задавать размер. А если длина заранее неизвестна? А если надо экономить память и не выделять ее слишком много?

Pascal

program main;
type DelimSet = set of char;
 
function split(var dest: array of string; const s: string; const delim: DelimSet): integer;
var
  n, i, len: integer;
begin
  n:= 0;
  i:= 1;
  len:= Length(s);
 
  while (i <= len) do begin
    if s[i] in delim then
      repeat inc(i) until (i > len) or (not (s[i] in delim))
    else begin
      dest[n]:= '';
      while (i <= len) and (not (s[i] in delim)) do begin
        dest[n]:= dest[n] + s[i];
        inc(i);
      end;
      inc(n);
    end;
  end;
  split:= n;
end;
 
var i, amount:Integer;
    s:String;
    dest:array of string;
    const delimeter=[' ','*','/'];
begin
  writeln('Enter s string: ');
  read(s);
  writeln;
  amount:=split(dest,s,delimeter);
  for i:=1 to length(s) do
    write(dest[i]);
end.

Вот это крашится при запуске. С dest:array[1..10] of string; даже не компилируется.

@rangerx · 01.12.2012, 20:54

Сообщение от suiseiseki

Пример использования этого можно? Что за параметр такой - dest?

Вариант с dest: array[1..10] of string; должен компилироваться как во Free Pascal так и в Turbo Pascal. Насчёт остальных компиляторов без понятия.

Pascal

var i, amount:Integer;
    s:String;
    dest: array[1..10] of string;
    const delimeter=[' ','*','/'];
begin
  writeln('Enter s string: ');
  readln(s);
  amount:=split(dest,s,delimeter);
  for i:=1 to amount do
    write(dest[i]);
end.

Сообщение от suiseiseki

Как понимаю, этому массиву надо самостоятельно задавать размер. А если длина заранее неизвестна? А если надо экономить память и не выделять ее слишком много?

Это просто пример алгоритма. Естественно, вместо массива лучше использовать какую-нибудь динамически расширяемую структуру, например список.

Сообщение от suiseiseki

Вот это крашится при запуске.

Под такие массивы память выделяется с помощью SetLength

Pascal

1	SetLength(dest, 10);

и индексируются они с 0, а не с 1.

@suiseiseki · 01.12.2012, 21:44

Сообщение от rangerx

Вариант с dest: array[1..10] of string; должен компилироваться как во Free Pascal так и в Turbo Pascal. Насчёт остальных компиляторов без понятия.

Только в PascalABC появляется ошибка strings.pas(35) : Неправильный тип параметров подпрограммы, а во фри паскале программа компилируется, но при запуске крашится.

@ПерС · 28.11.2013, 15:47

Самый простой разбор на слова

Заметил, что огромное число вопросов по Паскалю - разобрать строку на слова. Если ткнуть в хороший, годный код - число вопросов удваивается ("а как это работает?")
Приведённый ниже самый простой, "школьный" код, воспринимается оптимистичней. Если было - сорри.

s - исходная строка, предполагается, что слова разделены хотя бы одним пробелом, "посторонние" знаки в конце слов (запятые, точки и т.п.) не учитываются. Программа не сохраняет строку s.
w - очередное слово. Его можно обрабатывать (вместо вывода в отдельную строку консоли, как в примере)
p - позиция очередного пробела, если пробела нет, принимает значение 0 после вызова стандартной функции pos.
len - длина очередного слова
count - количество слов

Pascal

var s,w:string;
 p,len,count:integer;
begin
 write ('Введите строку: '); readln (s);
 p:=1;
 while p>0 do begin
  p:=pos(' ',s);  {ищем очередной пробел}
  if p>0 then w:=copy(s,1,p-1) {если есть - копируем в переменную "слово" символы до пробела}
  else w:=s; {если нет, то вся оставшееся строка - это одно слово}
  delete (s,1,p); {удаляем переписанное в w слово вместе с пробелом }
  len:=length(w); {находим длину слово}
  if len>0 then begin {"пустые" слова - лишние пробелы - не учитываем}
   inc(count); {Увеличиваем счетчик слов}
   writeln (w); {Просто выводим очередное слово -
                 вставьте сюда свой код}
  end;
 end;
 writeln ('Всего слов: ',count);
 write ('Нажмите ENTER для выхода');
 readln;
end.

@Mawrat · 28.11.2013, 18:19

Я разбивку на слова выполняю так:

Pascal

const
  //Разделители слов.
  D = ['.', ',', ':', ';', '!', '?', '-', ' ', #9, #10, #13];
var
  S : String;
  i, Len, LenW, Cnt : Integer;
begin
  Writeln('Задайте текст:');
  Readln(S);
 
  Writeln('Выделенные из текста слова:');
  Len := Length(S);
  Cnt := 0; //Количество найденных слов.
  LenW := 0; //Длина очередного слова.
  for i := 1 to Len do
    if not (S[i] in D) then begin //Если символ не разделитель, значит он принадлежит слову.
      Inc(LenW); //Учитываем очередной символ в длине слова.
      if (i = Len) or (S[i + 1] in D) then begin //Отслеживаем конец слова.
        Inc(Cnt); //Подсчёт слова.
        Writeln(Copy(S, i - LenW + 1, LenW)); //Распечатка слова.
        LenW := 0; //Сброс длины слова.
      end;
    end;
  
  Writeln('Количество слов в заданном тексте = ', Cnt);
  Readln;
end.

Incred
	22.06.2011, 15:04	10
	может кто-нибудь организует все операции в процедуры? думаю будет полезным и удобным. как вот здесь: Сортировки

@TAVulator ⚽ 4163 / 1266 / 228 Регистрация: 27.07.2009 Сообщений: 3,939
	24.12.2011, 09:19 [ТС]	14
	Сообщение от BakhtiyarZ Было бы еще лучше если бы каждая переменная описывалась для чего она необходима. не вижу в этом смысла 0

@suiseiseki 2 / 2 / 1 Регистрация: 23.09.2012 Сообщений: 34
	01.12.2012, 21:44	17
	Сообщение от rangerx Вариант с dest: array[1..10] of string; должен компилироваться как во Free Pascal так и в Turbo Pascal. Насчёт остальных компиляторов без понятия. Только в PascalABC появляется ошибка strings.pas(35) : Неправильный тип параметров подпрограммы, а во фри паскале программа компилируется, но при запуске крашится. 0