Форум программистов, компьютерный форум, киберфорум
Наши страницы
Pascal (Паскаль)
Войти
Регистрация
Восстановить пароль
 
Рейтинг 4.76/273: Рейтинг темы: голосов - 273, средняя оценка - 4.76
TAVulator
Эксперт Pascal/Delphi
3996 / 1140 / 179
Регистрация: 27.07.2009
Сообщений: 3,553
1

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

14.12.2010, 15:22. Просмотров 49857. Ответов 18

В этой теме представлены реализации алгоритмов работы со строками.
Выкладывайте свои реализации на языке 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. Набор функций для работы с путями и именами файлов и папок
18
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
14.12.2010, 15:22
Ответы с готовыми решениями:

Операции над строками
Ребят помогите пожалуйста составить программу, я уже не знаю что и делать....

Операции над строками.
Заданна строка символов. Напечатать все слова предварительно преобразовав их...

Прграммы имитирующие операции над строками
Помогите найти ошибки: program task; uses crt; function Pos_...

Операции над записями
В данную программу сделать так: У кого средний бал больше 4.0 того выводит на...

Операции над массивами.
Найти минимумы нечетных столбцов матрицы. uses crt; var ...

18
rangerx
1944 / 1553 / 478
Регистрация: 31.05.2009
Сообщений: 2,913
24.12.2010, 01:38 2
Функция разбития строки на слова.

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;
11
Inadequate
Retired
7710 / 2543 / 670
Регистрация: 17.10.2009
Сообщений: 5,100
25.12.2010, 05:41 3
Цитата Сообщение от 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), но не везде такое прокатит. Вполне возможно, что допустил где-то ошибки, глаза уже слипаются... Буду признателен, если укажут на их присутствие.
8
Somebody
2802 / 1613 / 251
Регистрация: 03.12.2007
Сообщений: 4,215
Завершенные тесты: 3
25.12.2010, 15:45 4
В удалении повторяющихся пробелов использование 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;
10
sergey93
8 / 8 / 7
Регистрация: 07.04.2011
Сообщений: 19
07.04.2011, 19:12 5
Удаление пробелов из строки
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.
3
TAVulator
Эксперт Pascal/Delphi
3996 / 1140 / 179
Регистрация: 27.07.2009
Сообщений: 3,553
07.04.2011, 19:50  [ТС] 6
Цитата Сообщение от 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.
4
S9
Волшебник
649 / 252 / 87
Регистрация: 18.12.2010
Сообщений: 541
08.04.2011, 12:29 7
Как то писал функцию перевода строки в биты(т.е. не совсем биты, а строка состоящая из 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;
8
Вложения
Тип файла: rar Пример использования.rar (3.1 Кб, 111 просмотров)
S9
Волшебник
649 / 252 / 87
Регистрация: 18.12.2010
Сообщений: 541
09.04.2011, 08:43 8
В дополнении хотел добавить ещё одну функцию, которая выделяет из полного пути к файлу
имя файла с расширением или без него(задается в параметрах).
З.Ы.Если есть стандартные функции делающие то-же самое то просьба меня извинить, я их не знаю
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;
8
SuPeR XaKer
2844 / 1973 / 788
Регистрация: 23.09.2010
Сообщений: 4,877
09.04.2011, 11:22 9
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;
8
incred
0 / 0 / 0
Регистрация: 08.02.2016
22.06.2011, 15:04 10
может кто-нибудь организует все операции в процедуры? думаю будет полезным и удобным.
как вот здесь:
Сортировки
0
Jaguar
393 / 279 / 38
Регистрация: 06.08.2010
Сообщений: 834
25.08.2011, 02:03 11
Я бы написал так
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;
0
Mawrat
12833 / 5741 / 1700
Регистрация: 19.09.2009
Сообщений: 8,807
18.09.2011, 05:43 12
Предлагаю набор функций для работы с путями и именами файлов и папок в среде 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.
5
BakhtiyarZ
2 / 2 / 3
Регистрация: 25.04.2011
Сообщений: 122
23.12.2011, 14:51 13
Цитата Сообщение от 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. - Таким образом, при проходе строки от конца - к началу алгоритм становится не зависящим от изменений длины строки.
0
TAVulator
Эксперт Pascal/Delphi
3996 / 1140 / 179
Регистрация: 27.07.2009
Сообщений: 3,553
24.12.2011, 09:19  [ТС] 14
Цитата Сообщение от BakhtiyarZ Посмотреть сообщение
Было бы еще лучше если бы каждая переменная описывалась для чего она необходима.
не вижу в этом смысла
0
suiseiseki
2 / 2 / 1
Регистрация: 23.09.2012
Сообщений: 34
01.12.2012, 19:48 15
Цитата Сообщение от 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; даже не компилируется.
0
rangerx
1944 / 1553 / 478
Регистрация: 31.05.2009
Сообщений: 2,913
01.12.2012, 20:54 16
Цитата Сообщение от 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.
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
ПерС
431 / 356 / 322
Регистрация: 05.11.2013
Сообщений: 1,008
Записей в блоге: 6
Завершенные тесты: 1
28.11.2013, 15:47 18
Самый простой разбор на слова

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

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.
0
Mawrat
12833 / 5741 / 1700
Регистрация: 19.09.2009
Сообщений: 8,807
28.11.2013, 18:19 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.
1
28.11.2013, 18:19
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
28.11.2013, 18:19

Операции над множествами
Даны три множества X1, X2, X3, содержащие целые числа из диапазона 100...200....

Операции над числами
Какая операция над двумя числами А и В (сложение,умножение,деление) даёт...

Операции над множествами
Выполнить операции над заданными множествами (A Δ B) ∩ C, где A Δ B = (A U...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
19
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2018, vBulletin Solutions, Inc.
Рейтинг@Mail.ru