Удаление лишних пробелов. Ввод/вывод в файл.

[Иван 883]

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

program lab15;
uses crt;

procedure InputData;
var FileIn:text;
    S,NameFile:string;
begin
  write('Введите имя файла ');
  read(NameFile);
  assign(FileIn,NameFile);
  reset(FileIn);
end;

function Pos(Substr:string; var S:string):byte;
begin
  while Pos(' ',S)>0 do S[Pos(' ',S)]:='0';
  writeln(S);
end;

procedure Delete(S:string; Index:integer; Count:integer);
begin
  Delete(S,Pos(' ',S),1);
end;

procedure OutputData;
var S:string;
    FileOut:text;
    NameFile:string;
begin
  write('Введите имя файла ');
  read(NameFile);
  {$I-}
  assign(FileOut,NameFile);
  {$I+}
  rewrite(FileOut);
end;

var FileIn,FileOut:text;
    S,Substr:string;
    Index,Count:integer;
begin
  clrscr;
  InputData;
  Pos(Substr,S);
  Delete(S,Index,Count);
  Close(FileIn);
  OutputData;
  Close(FileOut);
end.

Ошибка выходит на функции Pos-переполнение стека. Помогите плз. Заранее большое спасибо!!!

[Dj_smart]

Оо удивили))
Сами же переопределили функцию pos?)
Теперже она вызывает сама себя) Вот вам и причина трабла.

function Pos(Substr:string; var S:string):byte;
begin
  while Pos(' ',S)>0 do S[Pos(' ',S)]:='0';
  writeln(S);
end;

Преименуйта, скежем в MyPos:

program lab15;
uses crt;

procedure InputData;
var FileIn:text;
    S,NameFile:string;
begin
  write('Введите имя файла ');
  read(NameFile);
  assign(FileIn,NameFile);
  reset(FileIn);
end;

function MyPos(Substr:string; var S:string):byte;
begin
  while Pos(' ',S)>0 do S[Pos(' ',S)]:='0';
  writeln(S);
end;

procedure MyDelete(S:string; Index:integer; Count:integer);
begin
  Delete(S,Pos(' ',S),1);
end;

procedure OutputData;
var S:string;
    FileOut:text;
    NameFile:string;
begin
  write('Введите имя файла ');
  read(NameFile);
  {$I-}
  assign(FileOut,NameFile);
  {$I+}
  rewrite(FileOut);
end;

var FileIn,FileOut:text;
    S,Substr:string;
    Index,Count:integer;
begin
  clrscr;
  InputData;
  MyPos(Substr,S); // я так понял вы используете переопределённую функцию?
  MyDelete(S,Index,Count); // и тут?
  Close(FileIn);
  OutputData;
  Close(FileOut);
end.

[Иван 883]

Спасибо, но теперь ругается на строки Close(FIleIn) и Close(FileOut) Пишет что файлы не были открыты

[Dj_smart]

Потому что вы используете файловые переменные внутри процедур

program lab15;
uses crt;
var FileIn,FileOut:text;

procedure InputData;
var S,NameFile:string;
begin
  write('Введите имя файла ');
  read(NameFile);
  assign(FileIn,NameFile);
  reset(FileIn);
end;

function MyPos(Substr:string; var S:string):byte;
begin
  while Pos(' ',S)>0 do S[Pos(' ',S)]:='0';
  writeln(S);
end;

procedure MyDelete(S:string; Index:integer; Count:integer);
begin
  Delete(S,Pos(' ',S),1);
end;

procedure OutputData;
var S:string;
    NameFile:string;
begin
  write('Введите имя файла ');
  read(NameFile);
  {$I-}
  assign(FileOut,NameFile);
  {$I+}
  rewrite(FileOut);
end;

var FileIn,FileOut:text;
    S,Substr:string;
    Index,Count:integer;
begin
  clrscr;
  InputData;
  MyPos(Substr,S); // я так понял вы используете переопределённую функцию?
  MyDelete(S,Index,Count); // и тут?
  Close(FileIn);
  OutputData;
  Close(FileOut);
end.

Т.е. нужно так:

Да, нужно так

[Иван 883]

вы используете файловые переменные внутри процедур

Т.е. нужно так:

function MyPos(Substr:string; var S:string):byte;
begin
  while Pos(' ',S)>0 do S[Pos(' ',S)]:='0';
  writeln(S);
end;

procedure MyDelete(S:string; Index:integer; Count:integer);
begin
  Delete(S,Pos(' ',S),1);
end;

var FileIn,FileOut:text;
    S,Substr,NameFile,NameFile1:string;
    Index,Count:integer;
begin
  write('Введите имя файла ');
  read(NameFile);
  assign(FileIn,NameFile);
  reset(FileIn);
  MyPos(Substr,S);
  MyDelete(S,Index,Count);
  Close(FileIn);
  write('Введите имя файла ');
  read(NameFile1);
  {$I-}
  assign(FileOut,NameFile1);
  {$I+}
  rewrite(FileOut);
  Close(FileOut);
end.

Если так то программа запрашивает имя входного файла, а затем завершает работу

[bag]

Иван 883, ты все напутал. Вот объясни мне, чем занимается твоя функция MyPos? Проще написать заново:

uses crt;

procedure del(var s:string);
var
  n:integer;
begin
  repeat
    n:=pos('  ',s);
    if n>0 then
      delete(s,n,1);
  until n=0;
end;
var
  fin:text;
  fout:text;
  s:string;
begin
  write('Input filename:');
  readln(s);
  assign(fin,s);
  {$I-}
  reset(fin);
  {$I+}
  if IOResult<>0 then
  begin
    writeln('ERROR! File ',s,' not found!');
    readkey;
    exit;
  end;
  write('Output filename:');
  readln(s);
  assign(fout,s);
  rewrite(fout);
  while not eof(fin) do
  begin
    readln(fin,s);
    del(s);
    writeln(fout,s);
  end;
  close(fin);
  close(fout);
end.

А так устроит?

[Иван 883]

Иван 883, ты все напутал

Где я напутал?
По идее функция myPos преобразовывает пробелы в нули. ЗЫ ее я брал из Help'а в Pascal'еСпасибо за программу, но мне нужно именно через процедуры и функции иначе препод не принимает

[bag]

Сообщение от Иван 883

Где я напутал?
По идее функция myPos преобразовывает пробелы в нули.

А тебе че, лишние пробелы нулями заменять надо?

[Иван 883]

А так устроит?

Устроит Ток у меня возникла пара вопросов. Для чего в программе переменная n, и IOresult?

А тебе че, лишние пробелы нулями заменять надо?

Нет не надо, просто по моему так легче их отследить

[bag]

В n хранится позиция текущей пары пробелов (чтобы кучу раз pos() не вызывать), а в IOResult хранится код ошибки при выполнении операции reset(fin). Если IOResult=0, то ошибок не было.