Процедура очистки лишних пробелов

[Form_13]

Почему не работает, не понимаю!!

Program курсовая;

{$APPTYPE CONSOLE}

{$R *.res}

 Uses
  System.SysUtils;

Var flag:boolean;
     l:string;

Procedure prob (var s:string);
  var flag:boolean;
      i:integer;
  begin
   i:=0;
   while i<length(s) do
    begin
     inc(i);
     if not (s[i]=' ') then flag:=false;
     if s[i]=' ' then
      if flag then delete(s,i,1)
       else flag:=true;
     if (s[i]='!') or (s[i]='.') or (s[i]='?') then
      begin
       if s[i-1]=' ' then delete(s,i-1,1);
       if not (s[i+1]=' ') then delete(s,i+1,1);
      end;
    end;
  end;

begin
 l:='   Ча  ча     ча ча!';
 prob(l);
 writeln(l);
 readln;
end.

Выводит точно такую же строку, единственное что удаляет пробел до знака или после, но не если 2-3 пробела рядом.

Я так понимаю, у меня while i<length(s) не меняется по значению, то есть строка то моя увеличивается или уменьшается, а он. Хм.

Я тут попробовал её переделать, всё равно херня получилось.

Procedure prob (var s:string);
  var flag:boolean;
      i,k:integer;
      s1:string;
  begin
   i:=0; k:=0;
   s1:=s;
   while i<length(s1) do
    begin
     inc(i);
     if not (s[i]=' ') then flag:=false;
     if s1[i]=' ' then
      if flag then
       begin
        delete(s1,i,1);
        dec(i);
        continue;
       end
              else flag:=true;
     if (s1[i]='!') or (s1[i]='.') or (s1[i]='?') then
      begin
       if s1[i-1]=' ' then
        begin
         delete(s1,i-1,1);
         dec(i);
         continue;
        end;
       if not (s1[i+1]=' ') then
        begin
         delete(s1,i+1,1);
         dec(i);
         continue;
        end;
      end;
     if s1[i]='.' then
      begin
        if k=3 then
                begin
                 delete(s1,i,1);
                 dec(i);
                 continue;
                end
               else inc(k);
      end
                 else k:=0;
    end;
    s:=s1;
  end;

[evg_m]

Держи

      i:=1;
   while i<length(s)-1 do
   begin
     if s[i]=' ' then begin
       case s[i+1] of
       ' ', '?', '.', '!': Delete(s,i,1); //удаляем пробел ПЕРЕД перчисленными знаками
//После удаления индексы всех знаков после удаленного уменьшаются 
//поэтому нам снова надо проверять s[i] стало быть нельзя делать inc(i)
//иначе мы пропустим (не проверим) какой-нибудь знак.
// Это твоя основная ошибка. 
       else inc(i); // передвигаемся если не было удаления (единственный пробел)
       end;
     end
     else inc(i); //или вообще не пробел    
   end;

[Form_13]

В очередной раз убеждаюсь насколько я глуп. Благодарю за краткий и эффективный код)

Да, я уже разобрался, где именно ошибся.
Я ещё добавил:

if (s[i]=' ') or (s[i]='.') or (s[i]='!') or (s[i]='?') then  begin
       case s[i+1] of

чтобы удалял лишние точки, восклицательные знаки и вопросительные.

Program курсовая;

{$APPTYPE CONSOLE}

{$R *.res}

 Uses
  System.SysUtils;

//односвязный список
 Type
  p=^elem;
  elem = record
         data:string;
         sled:p;
         end;
 Var ykaz:p;
     flag:boolean;
     l:string;

 //процедура чтения файла в динамический список
 Procedure read;
  var next:p;
      F:textfile;
  begin
   Assign(F,'text.txt');
   Reset(F);
   next:=ykaz;                           //делаем временный указатель, для прохождения по списку
   while not EoF(F)  do                 //пока, не конец файла
    begin
     readln(F,next^.data);              //читаем строку в поле data
     if next^.data='' then              //если файл пустой, то...
      begin
       flag:=true;                      //...запоминает это, и..
       exit;                            //...выходим из подпрограммы.
      end;
     new(next^.sled);                   //если всё хорошо, выделяем память под следущий элемент списка
     next:=next^.sled;                  //переходим на него (присваиваем его основному указателю)
    end;
   close(F);                            //прекращаем работу с файлом
  end;
 //процедура записи в файл из динамического массива
 Procedure write;
  var F:textfile;
      yk,l:p;
  begin
   if flag then exit;                    //если мы выяснили при чтении, что файл пустой, выходим из подпрограммы
   Assign(F,'text.txt');
   Rewrite(F);
   yk:=ykaz;
   while (yk<>nil) do   //если текущий указатель имеет непустое значение, то..
    begin
     Writeln(F,yk^.data);     //записываем в файл строку, и ..
     l:=yk^.sled;
     dispose(yk);       //уничтожаем текущий элемент списка
     yk:=l;            //переходим на следущий указатель
    end;
   close(F);                  //закрываем файл.
  end;
 //процедура чистки лишних пробелов
 Procedure prob (var s:string);
  var i:integer;
  begin
   i:=1;
   while i<length(s)-1 do
   begin
     if (s[i]=' ') or (s[i]='.') or (s[i]='?') or (s[i]='!')then begin
       case s[i+1] of
       ' ', '?', '.', '!': Delete(s,i,1); //удаляем пробел перед перчисленными знаками
       else inc(i); // передвигаемся если не было удаления (единственный пробел)
       end;
     end
     else inc(i); //или вообще не пробел
   end;
  end;
 //процедура поиска и замены слов
 Procedure main;
  var yk:p;
  begin
   yk:=ykaz;
   while (yk<>nil) do
    begin
     prob(yk^.data);
     yk:=yk^.sled;
    end;
  end;

begin
 new(ykaz);
 read;
 main;
 write;
end.

Вот я воткнул процедуру свою основную программу, но почему-то в файл записываются неизменённые значения.

По-моему он не записывает, то есть до prob(yk^.data); - всё нормально. Он не меняет внутри списка ничего, или не записывает даже, я не знаю.

Нашёл косяк. Где была проверка пустой строки, ведь последняя строка всегда пустая, и видимо он её проверяет, а потом процедуре записи подаётся сигнал, что весь файл пустой. Как бы сделать проверку пустого файла, но чтоб проверял до текста, а не после.

Сделал так:

while not EoF(F)  do                 //пока, не конец файла
    begin
     readln(F,next^.data);              //читаем строку в поле data
     if not (next^.data='') then flag1:=true;
     if (next^.data='') and (not (flag1)) then              //если файл пустой, то...
      begin
       flag:=true;                      //...запоминает это, и..
       exit;                            //...выходим из подпрограммы.
      end;
     new(next^.sled);                   //если всё хорошо, выделяем память под следущий элемент списка
     next:=next^.sled;                  //переходим на него (присваиваем его основному указателю)
    end;

Procedure prob (var s:string);
  var i:integer;
  begin
   i:=1;
   while i<length(s) do
   begin
     if (s[i]=' ') or (s[i]='.') or (s[i]='?') or (s[i]='!') or (s[i]=',') then
      begin
       case s[i+1] of
       ' ', '?', '.', '!':
        begin
         Delete(s,i,1);
         if not (s[i+2]=' ') then
                              begin
                              insert(' ',s,i+2);
                              dec(i);
                              end;
        end;  //удаляем пробел перед перчисленными знаками
       else inc(i); // передвигаемся если не было удаления (единственный пробел)
       end;
      end
     else inc(i); //или вообще не пробел
   end;
  end;

я вставил в процедуру, проверку пробела перед новым предложением, лагнуло. посмотри ещё раз.

[Johnson]

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

while Pos('  ',S)>0 do StringReplace(S, '  ', ' ');

Да, этот код процентов на 20% медленнее предыдущего. Но, проще и эффективнее. Небось, не на 8086 процссорах работаем...

Кстати, возможно цикл даже и не нужен. Сейчас под рукой нет компилятора, но вроде бы, в StringReplace тоже есть цикл. Надо его исходники глядеть.



Есть ещё такой вариант. Написан на коленке за минуту, могут быть ошибки.

for I:=length(S) downto 1 do begin
	if (S[I]=' ') then if (I=1) or ((I>1)and(S[I-1]<>' ') ) then Delete(S,I,1);
	// Сдесь такие же конструкции для других символов
end;