Форум программистов, компьютерный форум, киберфорум
Наши страницы

Pascal (Паскаль)

Войти
Регистрация
Восстановить пароль
 
 
Рейтинг: Рейтинг темы: голосов - 368, средняя оценка - 4.71
TAVulator
3950 / 1109 / 72
Регистрация: 27.07.2009
Сообщений: 3,457
#1

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

14.12.2010, 15:22. Просмотров 48868. Ответов 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
Я подобрал для вас темы с готовыми решениями и ответами на вопрос Операции над строками (Pascal):

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

Операции над строками. - Pascal
Заданна строка символов. Напечатать все слова предварительно преобразовав их следующим образом: Удалить из слова 1-ое вхождение...

Прграммы имитирующие операции над строками - Pascal
Помогите найти ошибки: program task; uses crt; function Pos_ (s1,s2:string):integer; var result: integer; i, j:...

Операции над множествами - Pascal
Даны три множества X1, X2, X3, содержащие целые числа из диапазона 100...200. Известно, что мощность каждого из этих множеств равна 10....

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

Операции над числами - Pascal
Какая операция над двумя числами А и В (сложение,умножение,деление) даёт наибольший результат?

18
rangerx
1941 / 1550 / 141
Регистрация: 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
7708 / 2541 / 184
Регистрация: 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
2798 / 1609 / 149
Регистрация: 03.12.2007
Сообщений: 4,204
Завершенные тесты: 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 / 3
Регистрация: 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
3950 / 1109 / 72
Регистрация: 27.07.2009
Сообщений: 3,457
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
Волшебник
647 / 250 / 38
Регистрация: 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
Волшебник
647 / 250 / 38
Регистрация: 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
2843 / 1972 / 377
Регистрация: 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
392 / 278 / 20
Регистрация: 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
12815 / 5723 / 675
Регистрация: 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 / 0
Регистрация: 25.04.2011
Сообщений: 125
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
3950 / 1109 / 72
Регистрация: 27.07.2009
Сообщений: 3,457
24.12.2011, 09:19  [ТС] #14
Цитата Сообщение от BakhtiyarZ Посмотреть сообщение
Было бы еще лучше если бы каждая переменная описывалась для чего она необходима.
не вижу в этом смысла
0
suiseiseki
1 / 1 / 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
01.12.2012, 19:48
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
01.12.2012, 19:48
Привет! Вот еще темы с ответами:

Операции над массивами. - Pascal
Найти минимумы нечетных столбцов матрицы. uses crt; var i,j,n,min:integer; a:array of integer;...

Операции над записями - Pascal
В данную программу сделать так: У кого средний бал больше 4.0 того выводит на экран. Program KK; const N=3; //количество...

Программирование операций над строками и текстовыми файлами... - Pascal
Доброго времени суток, уважаемые! Необходимо написать програмку, которая считывает текст из файла и выводит на экран сначала...

Программирование операций над строками и текстовыми файлами - Pascal
В каждой строке текстового файла найти наиболее длинную последовательность цифр. Значение ее длины преобразовать в строку, которую записать...


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

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

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