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

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

Студворк — интернет-сервис помощи студентам

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

Содержание

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

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
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
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
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
1
2
3
4
5
6
7
8
9
10
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
1
2
3
4
5
6
7
8
9
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
1
2
3
4
5
6
7
8
9
10
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
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
{Функция разбивает строку на слова и помещает их в строковый массив 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
1
2
3
4
5
6
7
8
9
10
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
1
2
3
4
5
6
7
8
9
10
11
12
13
14
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
1
2
3
4
5
6
7
8
9
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
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
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
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
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
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
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
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
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
1
2
3
4
5
6
7
8
9
10
11
12
13
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
1
2
3
4
5
6
7
8
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
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
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
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
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
1
2
3
4
5
6
7
8
9
10
11
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
1
2
3
4
5
6
7
8
9
10
11
12
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
1
2
3
4
5
6
7
8
9
10
11
12
13
14
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
1
2
3
4
5
6
7
8
9
10
11
12
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
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
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
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
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
1
2
3
4
5
6
7
8
9
10
11
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
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
{Функция разбивает строку на слова и помещает их в строковый массив 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
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
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
1
2
3
4
5
6
7
8
9
10
11
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
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
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
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
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.

Новые блоги и статьи Все статьи Все блоги /
Мысли в слух kumehtar 07.11.2025 Заметил среди людей, что по-настоящему верная дружба бывает между теми, с кем нечего делить.	Новая зверюга volvo 07.11.2025 Подарок на Хеллоуин, и теперь у нас кроме Tuxedo Cat есть еще и щенок далматинца: Хочу еще Симбу взять, очень нравится. . .	Инференс ML моделей в Java: TensorFlow, DL4J и DJL Javaican 05.11.2025 Python захватил мир машинного обучения - это факт. Но когда дело доходит до продакшена, ситуация не так однозначна. Помню проект в крупном банке три года назад: команда data science натренировала. . .	Mapped types (отображённые типы) в TypeScript Reangularity 03.11.2025 Mapped types работают как конвейер - берут существующую структуру и производят новую по заданным правилам. Меняют модификаторы свойств, трансформируют значения, фильтруют ключи. Один раз описал. . .	Адаптивная случайность в Unity: динамические вероятности для улучшения игрового дизайна GameUnited 02.11.2025 Мой знакомый геймдизайнер потерял двадцать процентов активной аудитории за неделю. А виновником оказался обычный генератор псевдослучайных чисел. Казалось бы - добавил в карточную игру случайное. . .
Протоколы в Python py-thonny 31.10.2025 Традиционная утиная типизация работает просто: попробовал вызвать метод, получилось - отлично, не получилось - упал с ошибкой в рантайме. Протоколы добавляют сюда проверку на этапе статического. . .	C++26: Read-copy-update (RCU) bytestream 30.10.2025 Прошло почти двадцать лет с тех пор, как производители процессоров отказались от гонки мегагерц и перешли на многоядерность. И знаете что? Мы до сих пор спотыкаемся о те же грабли. Каждый раз, когда. . .	Изображения webp на старых x32 ОС Windows XP и Windows 7 Argus19 30.10.2025 Изображения webp на старых x32 ОС Windows XP и Windows 7 Чтобы решить задачу, использовал интернет: поисковики Google и Yandex, а также подсказки Deep Seek. Как оказалось, чтобы создать. . .	Passkey в ASP.NET Core identity stackOverflow 29.10.2025 Пароли мертвы. Нет, серьезно - я повторяю это уже лет пять, но теперь впервые за это время чувствую, что это не просто красивые слова. В . NET 10 команда Microsoft внедрила поддержку Passkey прямо в. . .	Последние результаты исследования от команды MCM (октябрь 2025 г.) Programma_Boinc 29.10.2025 Последние результаты исследования от команды MCM (октябрь 2025 г. ) Поскольку мы продолжаем изучать гены, которые играют ведущую роль в развитии рака, в рамках проекта "Картирование раковых. . .

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