Технический форум

Технический форум (http://www.tehnari.ru/)
-   Помощь студентам (http://www.tehnari.ru/f41/)
-   -   Небольшая подсказка (http://www.tehnari.ru/f41/t263644/)

Maria_Meri 31.03.2019 19:38
Небольшая подсказка
 
Подскажите, как сделать программу для удаления из текста каждое N-ое вхождение в него заданного слова.
При этом:
Данные записываются в файл прямого доступа (если входные данные символы, то сначала нужно перевести их в коды, а потом записать в файл);
обработать данные (использовать прямой доступ к компонентам файла) и записать результат в текстовый файл.
После обработки файла создать его копию путем записи его содержимого в другой файл с использованием механизма «бестиповых файлов».

НЕ ОБРАЩАЙТЕ ВНИМАНИЕ ПРО PHP, просто так код более читабельный
PHP код:
Uses crt;
type
matr = array[1..5]of integer;
tFile = file of integer;

//Вывожу на экран, что есть в файле
procedure show(var f:text);
var s:string;
begin
  Assign(f, 'input.txt');
  reset(f);
  while not eof(f) do
  begin
    readln(f, s);
    writeln(s);
  end;
  Close(f);
  end;

//Перевожу символы в ascii-коды
(здесь пользователь вводит слово, которое надо удалить)
procedure input(var a:matr; var delword:string);
var i:integer;
   begin
  readln(delword);
  for i:=1 to length(delword) do
   begin
   a[i]:=ord(delword[i]);
   end;
   end;

//Перевожу все символы в ascii-коды
(здесь слова, которые были в файле)
procedure transfer(var f:text; var f3:tFile);
var s:string; i,k:integer;
begin
  reset(f);
  assign(f3, 'ascii');
  rewrite(f3);
  while not eof(f) do
   begin
   readln(f,s);
   for i:=1 to length(s) do
    begin
     k:=ord(s[i]);
     write(f3,k);
    end;
    write(f3,10);
   end;
   close(f3);
end;  

//Неудачная попытка удалить   
procedure process (var f3:tFile; var f2:text;a:matr;delword:string);
var k,i,p, time, count:integer; flag:boolean;
begin
flag:=false;
readln(time);
count :=0;
 reset(f3);
   Assign(f2, 'output.txt');
   rewrite(f2);
  while not eof(f3) do
  begin
    read(f3, k);
    for i:= 1 to length(delword) do
     begin
      if a[i] = k then
      begin
      inc(count);
      if count mod time = 0 then 
      k:=32;
      end
      else
      if k = 10 then writeln(f2, '');
      if k <> 10 then
      write(f2,chr(k));
      write(chr(k));

      end;
    end;
  close(f2);
  close(f3);
 end;
 
 
var
  f, f2: text;
  f3:tFile;
  delword: string;
  a:matr; time:integer;
begin
clrscr;
show(f);
input(a, delword);
transfer(f, f3);
process(f3, f2, a, delword);
end. 
У меня каждый символ в слове, котором пользователь ввел сравнивается с каждым символом слова, которые есть в файле. Поэтому вывод неправильный. Получается один и тот же символ выводится несколько раз.

Подскажите, как можно это реализовать(алгоритм) сравнение для удаления.
Спасибо.

Maria_Meri 31.03.2019 19:49
Язык - Turbo Pascal 7.0

Vladimir_S 01.04.2019 11:26
Да... хороша себе "небольшая подсказка"!
Исправил кучу ошибок, причесал, отладил, протестировал. Работает.
Код:
Uses crt;
Type
 matr = array[1..5] of integer;
 tFile = file of integer;

//Вывожу на экран, что есть в файле
procedure show(var f:text);
var s:string;
begin
 Assign(f, 'input.txt');
 reset(f);
 while not eof(f) do
  begin
  readln(f,s);
  writeln(s);
  end;
 Close(f);
end;

//Перевожу символы в ascii-коды
//(здесь пользователь вводит слово, которое надо удалить)
procedure input(var a:matr; var delword:string; var L:integer);
var i:integer;
begin
 writeln('Enter delword:');
 readln(delword);
 L:=Length(delword);
 for i:=1 to length(delword) do a[i]:=ord(delword[i]);
end;

//Перевожу все символы в ascii-коды
//(здесь слова, которые были в файле)
procedure transfer(var f:text; var f3:tFile);
var s:string; i,k:integer;
begin
 reset(f);
 assign(f3, 'ascii');
 rewrite(f3);
 while not eof(f) do
  begin
  readln(f,s);
  for i:=1 to length(s) do
    begin
    k:=ord(s[i]);
    write(f3,k);
    end;
  k:=10;
  write(f3,k);
  end;
 close(f);
 close(f3);
end;

//Удачная попытка удалить
procedure process (var f3:tFile; var f2:text; a:matr; L:integer);
var
 k,i,p,time,count:integer;
 flag,flag1,flag2:boolean;
 b:array[1..30] of integer;
begin
 writeln('Enter time:');
 readln(time);
 count :=0;
 reset(f3);
 Assign(f2, 'output.txt');
 rewrite(f2);
 while not eof(f3) do
  begin
  p:=0;
  repeat
    inc(p);
    read(f3, k);
    b[p]:=k;
  until (k=10) or eof(f3);
  if k=10 then dec(p);
  if p=L then
    begin
    i:=0;
    flag2:=true;
    repeat
      inc(i);
      flag1:=b[i]=a[i];
    until (flag1=false) or (i=L);
    if flag1 then
      begin
      inc(count);
      if count mod time = 0 then flag2:=false;
      end;
    flag:=flag2;
    end else flag:=true;
  if flag then
    begin
    for i:=1 to p do write(f2,chr(b[i]));
    writeln(f2);
    for i:=1 to p do write(chr(b[i]));
    writeln;
    end;
  end;
 Readln;
 close(f2);
 close(f3);
end;


var
  f,f2: text;
  f3:tFile;
  delword: string;
  a:matr;
  time,L:integer;
begin
 clrscr;
 show(f);
 input(a, delword,L);
 transfer(f, f3);
 process(f3, f2, a, L);
end.
Замечу, например, что если велено работать с кодами, то в процедуре Process строковой переменной Delword делать нечего: пользовательское слово мы в процедуре Input перевели в кодовый массив, вот с ним и надлежит работать. Ну и ещё много чего по мелочи.
И ещё парочка пожеланий (необязательных).
1. При использовании форматирования листинга очень желательно, чтобы горизонтальные отступы сопряженных begin и end были строго одинаковыми (как у меня). Это позволяет сразу увидеть вложенность операторов.
2. Использование одинаковых идентификаторов в качестве параметров подпрограмм и глобальных переменных хоть и не запрещено, но крайне нежелательно, поскольку снижает читабельность. Я уж исправлять не стал, но если будете ещё программировать, учтите этот момент.

P.S. И ещё. В своей программе Вы (и я вслед за Вами) исходите из того, что в исходном файле каждое слово расположено в своей отдельной строке. Это так в задании оговорено или Вы "упростили"? Потому что если это не так, то требуется довольно муторная процедура выделения отдельных слов.

Maria_Meri 03.04.2019 20:30
Vladimir_S, я для тестирования сама себе такое "упрощение" сделала. И как я поняла, в моем способе(который Вы реализовали) есть недостаток, что при time = 1, удаляется все потому что любое число делится на 1 без остатка.
Спасибо Вам за помощь и советы. Постараюсь попробовать реализовать процедуру выделения отдельных слов.

Maria_Meri 03.04.2019 20:35
Например,
Код:
one
two
one
three
one
four
Введем слово: one
Time = 1
Выведется:
Код:
two
three
four

Vladimir_S 04.04.2019 09:43
Цитата:
Сообщение от Maria_Meri (Сообщение 2640271)
есть недостаток, что при time = 1, удаляется все потому что любое число делится на 1 без остатка
Какой же это недостаток? Наоборот, полностью соответствует условию задачи. "Убрать каждое первое" и значит убрать все. Всё правильно.
Цитата:
Сообщение от Maria_Meri (Сообщение 2640271)
Постараюсь попробовать реализовать процедуру выделения отдельных слов.
Успехов! Подскажу: пожалуй, проще всего организовать другой входной файл и в него перекатать содержимое исходного по следующему алгоритму:
1. Читаем символы исходного файла, пока не наткнемся на символ, отличный от пробела.
2. Копируем символы в новый файл до того, как появится очередной пробел или EoF.
3. Если "не EoF", то переводим строку в новом файле.
4. Возвращаемся к п.1.
Далее работаем с новым файлом по существующей программе.
Я бы так действовал.

Maria_Meri 05.04.2019 10:31
подскажите, что я сделала не так? Или я не так поняла Вашу мысль? Потому что я создала еще file of integer и начала к нему перекатывать символы.
Код:
Uses crt;

type
  matr = array[1..5] of integer;
  tFile = file of integer;

procedure show(var f: text);
var
  s: string;
begin
  Assign(f, 'input.txt');
  reset(f);
  while not eof(f) do
  begin
    readln(f, s);
    writeln(s);
  end;
  Close(f);
end;

procedure input(var a: matr; var delword: string; var L: integer);
var
  i: integer;
begin
  writeln('Enter delword:');
  readln(delword);
  L := Length(delword);
  for i := 1 to length(delword) do a[i] := ord(delword[i]);
end;

procedure transfer(var f: text; var f3: tFile);
var
  s: string; i, k: integer;
begin
  reset(f);
  assign(f3, 'ascii');
  rewrite(f3);
  while not eof(f) do
  begin
    readln(f, s);
    for i := 1 to length(s) do
    begin
      k := ord(s[i]);
      write(f3, k);
    end;
  end;
  close(f);
  close(f3);
end;

//подскажите, где я не так поняла Вашу мысль
procedure preprocess(var f3: tFile; var f4: tFile);
var
  k: integer;
begin
  reset(f3);
  assign(f4, 'preoutput');
  rewrite(f4);
  while not eof(f3) do
  begin
    repeat
      read(f3, k);
      write(f4, k);
    until (k = 32) or eof(f3);
    if not eof(f3) then writeln(f3);
  end;
  close(f3);
  close(f4);
end;

procedure process(var f4: tFile; var f2: text; a: matr; L: integer);
var
  k, i, p, time, count: integer;
  flag, flag1, flag2: boolean;
  b: array[1..30] of integer;
begin
  writeln('Enter time:');
  readln(time);
  count := 0;
  reset(f4);
  Assign(f2, 'output.txt');
  rewrite(f2);
  while not eof(f4) do
  begin
    p := 0;
    repeat
      inc(p);
      read(f4, k);
      b[p] := k;
    until (k = 10) or eof(f4);
    if k = 10 then dec(p);
    if p = L then
    begin
      i := 0;
      flag2 := true;
      repeat
        inc(i);
        flag1 := b[i] = a[i];
      until (flag1 = false) or (i = L);
      if flag1 then
      begin
        inc(count);
        if count mod time = 0 then flag2 := false;
      end;
      flag := flag2;
    end else flag := true;
    if flag then
    begin
      for i := 1 to p do write(f2, chr(b[i]));
      writeln(f2);
      for i := 1 to p do write(chr(b[i]));
      writeln;
    end;
  end;
  Readln;
  close(f2);
  close(f4);
end;


var
  f, f2: text;
  f3, f4: tFile;
  delword: string;
  a: matr;
  time, L: integer;

begin
  clrscr;
  show(f);
  input(a, delword, L);
  transfer(f, f3);
  preprocess(f3, f4);
  process(f4, f2, a, L);
end.
Для пример я взяла такой файл. Я добавила знаки препинания, но думаю, что если вводимое слово не будет стоять рядом с (, . ? !), то все будет нормально
Код:
one five, six, please!
two seven? No, it can do it.
one eight! Thank you very much.
three read.
one
four

Vladimir_S 05.04.2019 10:47
Цитата:
Сообщение от Maria_Meri (Сообщение 2640593)
подскажите, что я сделала не так? Или я не так поняла Вашу мысль? Потому что я создала еще file of integer и начала к нему перекатывать символы.
Нет-нет, я имел в виду совсем другое: вспомогательный ТЕКСТОВЫЙ файл, в котором слова из исходного расположатся каждое в своей строке.
Цитата:
Сообщение от Maria_Meri (Сообщение 2640593)
Я добавила знаки препинания
О, Боже!.. Вот это поворот... Ладно, поразмыслим.

Vladimir_S 05.04.2019 14:27
Так, ну, вроде, что-то такое слепилось и даже работает. Совсем голову сломал с этими символами 10 и 13 (не спрашивайте, что такое 13: боролся с ним эмпирически). Отличия от предыдущего варианта:
1. Исходный текст нужно поместить в файл preinput.txt. Файл input.txt, в котором каждое слово (со знаком препинания, если есть) занимает свою строку, сгенерит сама программа.
2. Понимает знаки препинания. Если после искомого пользовательского слова стоит, например, запятая, то она учитываться не будет.

Теперь так. В выводном файле каждое слово занимает свою строку. Не, ну можно, конечно, запомнить структуру исходного файла а потом выходной файл отформатировать в соответствии с этой структурой, но мне кажется, это уже будет перебор.
Код:
Uses crt;
Const
 CC:Set of Char=['!',',','.','?',':',';'];

Type
 matr = array[1..30] of integer;
 tFile = file of integer;

Procedure Inp_file(var g1:Text;var g2:Text);
var C:Char;
begin
 Assign(g1,'preinput.txt');
 Reset(g1);
 Assign(g2,'input.txt');
 Rewrite(g2);
 Repeat
  repeat
  Read(g1,C);
  until C<>' ';
  if (Ord(C)<>10) and (Ord(C)<>13) then Write(g2,C);
  repeat
  Read(g1,C);
  if (C<>' ') and (Ord(C)<>10) and (Ord(C)<>13) then Write(g2,C);
  until (C=' ') or (EoLn(g1));
  Writeln(g2);
 Until EoF(g1);
 Close(g1);
 Close(g2);
end;
//Вывожу на экран, что есть в файле
procedure show(var f:text);
var s:string;
begin
 Assign(f, 'input.txt');
 reset(f);
 while not eof(f) do
  begin
  readln(f,s);
  writeln(s);
  end;
 Close(f);
end;

//Перевожу символы в ascii-коды
//(здесь пользователь вводит слово, которое надо удалить)
procedure input(var a:matr; var delword:string; var L:integer);
var i:integer;
begin
 writeln('Enter delword:');
 readln(delword);
 L:=Length(delword);
 for i:=1 to length(delword) do a[i]:=ord(delword[i]);
end;

//Перевожу все символы в ascii-коды
//(здесь слова, которые были в файле)
procedure transfer(var f:text; var f3:tFile);
var s:string; i,k:integer;
begin
 reset(f);
 assign(f3, 'ascii');
 rewrite(f3);
 while not eof(f) do
  begin
  readln(f,s);
  for i:=1 to length(s) do
    begin
    k:=ord(s[i]);
    write(f3,k);
    end;
  k:=10;
  write(f3,k);
  end;
 close(f);
 close(f3);
end;

//Удачная попытка удалить
procedure process (var f3:tFile; var f2:text; a:matr; L:integer);
var
 k,i,p,p1,time,count:integer;
 flag,flag1,flag2:boolean;
 b:matr;
begin
 writeln('Enter time:');
 readln(time);
 count :=0;
 reset(f3);
 Assign(f2, 'output.txt');
 rewrite(f2);
 while not eof(f3) do
  begin
  p:=0;
  repeat
    inc(p);
    read(f3, k);
    b[p]:=k;
  until (k=10) or EoF(f3);
  repeat
    if (b[p]=10) or (b[p]=13) then dec(p);
  until (b[p]<>10) and (b[p]<>13);
  if Chr(b[p]) in CC then p1:=p-1 else p1:=p;
  if p1=L then
    begin
    i:=0;
    flag2:=true;
    repeat
      inc(i);
      flag1:=b[i]=a[i];
    until (flag1=false) or (i=L);
    if flag1 then
      begin
      inc(count);
      if count mod time = 0 then flag2:=false;
      end;
    flag:=flag2;
    end else flag:=true;
  if (flag=false) and (Chr(b[p]) in CC) then
    begin
    Writeln(f2,Chr(b[p]));
    Writeln(Chr(b[p]));
    end;
  if flag then
    begin
    for i:=1 to p do
      if (b[i]<>10) and (b[i]<>13) then write(f2,chr(b[i]));
    writeln(f2);
    for i:=1 to p do
      if (b[i]<>10) and (b[i]<>13) then write(chr(b[i]));
    writeln;
    end;
  end;
 Readln;
 close(f2);
 close(f3);
end;


var
  f0,f,f2: text;
  f3:tFile;
  delword: string;
  a:matr;
  time,L:integer;
begin
 clrscr;
 Inp_file(f0,f);
 show(f);
 input(a, delword,L);
 transfer(f, f3);
 process(f3, f2, a, L);
end.

Maria_Meri 06.04.2019 00:47
Vladimir_S, Ааааа, вот что вы имели ввиду. Но я всё-таки думаю, что нужно отформатировать. Так как в задание написано удалить текст, я вывела на экран файл "preinpur.txt". На выводе я бы вывела в таком же формате, только без удаленных слов. Было бы странно, если вместо текста пользователь получает строки с одним словом.
Попробую отформатировать(додуматься бы только, ведь наша программасчитывает по одному слову, игнорируя строки). Можно ли просто в конце каждого предложения поставить
Код:
 
  k:=10;
  write(f3,k);
как мы уже делали, считывать слово (словом будет являться все символы до пробела, до встречи с 32). Сравниваем по длине и буквам. А после 10 переходить на новую строку?
Спасибо Вам огромное!

Vladimir_S 06.04.2019 18:33
Да-аа, дорогая Мария-Мэри, ну Вы и обеспечили меня головной болью! Продираюсь потихоньку. Там та-акие подводные камни вылезают (особенно в преобразовании текстового файла в типизированный ЧЕРЕЗ СТРОКИ), что только держись! И не подозревал. Не зря я в практической работе всегда старался держаться от типизированных файлов подальше (не всегда, правда, удавалось), обходясь текстовыми, с которыми всё ясно и понятно.
Надеюсь, что скоро "добью".
Но задачка чертовски интересная. Это не поиск максимального элемента массива и пр., с которыми, в основном, лоботрясы сюда и обращаются.

Vladimir_S 07.04.2019 13:59
Вложений: 3
Уж не знаю, актуально ещё или нет, но я это дело таки добил! Уф, ну задачка...
Значит, так.
Во-первых, никаких строк! Сочетание строк с типизированным файлом это, как оказалось, гремучая смесь: постоянно вылезают заморочки с нумерацией, обработкой служебных символов и т.п. Поэтому работаем с исходным файлом, как он есть, никаких преобразований в формат "строка-слово". Исходный текст должен быть в файле input.txt. Единственное место, где оставлена строка, это считывание пользовательского слова. Всё!
Во-вторых, убраны все экранные выводы. Ни к чему они там.
В-третьих, процедура process построена совершенно иначе по сравнению с предыдущими вариантами. Суть: проходится файл ascii и формируются два массива е1 и е2 порядковых номеров начал (е1) и концов (е2) цепочек символов, подлежащих удалению. Дальше вновь проходится файл ascii и в файл output.txt отправляются только символы, не входящие в указанные цепочки. Таким образом, структура файла сохраняется.
Код:
Uses crt;

Type
 matr = array[1..30] of integer;
 tFile = file of integer;


//Перевожу символы в ascii-коды
//(здесь пользователь вводит слово, которое надо удалить)
procedure input(var a:matr; var L:integer; var T:integer);
var
 i:integer;
 delword:string;
begin
 write(' Enter delword: ');
 readln(delword);
 L:=Length(delword);
 for i:=1 to length(delword) do a[i]:=ord(delword[i]);
 write(' Enter time: ');
 readln(T);
end;

//Перевожу все символы в ascii-коды
//(здесь слова, которые были в файле)
procedure transfer(var f:text; var f3:tFile);
var
 C:Char;
 k:integer;
begin
 Assign(f,'input.txt');
 reset(f);
 Assign(f3, 'ascii');
 rewrite(f3);
 repeat
  Read(f,C);
  k:=Ord(C);
  Write(f3,k);
 until EoF(f);
 Close(f);
 Close(f3);
end;

function Compare(a,b:matr; L:integer):boolean;
var
 i:integer;
 bb:boolean;
begin
 i:=0;
 repeat
  Inc(i);
  bb:=a[i]=b[i];
 until (bb=false) or (i=L);
 Compare:=bb;
end;

//Удачная попытка удалить
procedure process (var f3:tFile; var f2:text; a:matr; L:integer; T:integer);
var
 k,i,j,m,count,n:integer;
 b,e1,e2:matr;
begin
 count :=0;
 Assign(f3,'ascii');
 reset(f3);
 Assign(f2, 'output.txt');
 rewrite(f2);
 n:=0;
 j:=0;
 for i:=1 to L do
  begin
  read(f3,k);
  b[i]:=k;
  Inc(j);
  end;
 if Compare(a,b,L) then Inc(count);
 if (count mod T)=0 then
  begin
  Inc(n);
  e1[1]:=1;
  e2[1]:=L;
  end;
 Repeat
  if Not(EoF(f3)) then
  begin
    Inc(j);
    for i:=2 to L do b[i-1]:=b[i];
    read(f3,k);
    b[L]:=k;
    if Compare(a,b,L) then Inc(count);
    if Compare(a,b,L) and ((count mod T)=0) then
    begin
      Inc(n);
      e1[n]:=j-(L-1);
      e2[n]:=j;
    end;
  end;
 Until EoF(f3);

 Reset(f3);
 if e1[1]>1 then
  for i:=1 to e1[1]-1 do
  begin
    Read(f3,k);
    Write(f2,Chr(k));
  end;
 for m:=1 to n do
  begin
  for i:=e1[m] to e2[m] do Read(f3,k);
  if m<n then
    for i:=e2[m]+1 to e1[m+1]-1 do
    begin
      Read(f3,k);
      Write(f2,Chr(k));
    end;
  end;
  While Not(EoF(f3)) do
  begin
    Read(f3,k);
    Write(f2, Chr(k));
  end;
 Close(f3);
 Close(f2)
end;

var
  f0,f,f2: text;
  f3:tFile;
  delword: string;
  a:matr;
  time,L:integer;
Begin
 clrscr;
 input(a, L, time);
 transfer(f, f3);
 process(f3, f2, a, L, time);
End.
Вложение 436590
Вложение 436591
Вложение 436592

Maria_Meri 08.04.2019 12:13
Vladimir_S, Вау, Вы смогли ее добить!:lupoglaz: Оказывается надо просто работать с исходным файлом, а я Вам какие-то преобразования "строка-слово"навязалаtehno003 Спасибо Вам огромное-преогромное!tehno003

Vladimir_S 08.04.2019 14:10
Цитата:
Сообщение от Maria_Meri (Сообщение 2641285)
Спасибо Вам огромное-преогромное!
Да пожалуйста, обращайтесь, если что. А с этой задачкой — самого зацепило и не отпускало, пока не добил. :D

-Polina- 20.04.2019 00:27
Дополнительные вопросы
 
Vladimir_S, здравствуйте. У меня несколько вопросов к реализуемой Вами программе.
Мой первый вопрос: При большом объеме текста, программа выдает ошибку о нехвате памяти, поэтому я попробовала реализовать через динамические переменные, а именно FreeMem, GetMem. Но как-то получается, что сначала я ищу количество совпадений, выделяю память, а потом только по массиву делею перепись. Хотела бы узнать, как реализовать более эффективно.
Мой второй вопрос: допустим у нас предложение: "it is his brother". Так как программа реализует проверку по посимвольному сдвигу, то после удаления слова "is", у нас останется "it h brother". Так и нужно? Ведь слова "his" и "is" это разные слова.
Спасибо Вам за ответы.
Код:
Uses crt;

type
  mas_int=^TTmas;
  TTmas=array[1..1] of integer;
  tFile = file of integer;
{$R-}
procedure show(var f: text);
var
  s: string;
begin
  Assign(f, 'input.txt');
  reset(f);
  while not eof(f) do
  begin
    readln(f, s);
    writeln(s);
  end;
  Close(f);
end;

procedure input(var a: mas_int; var L: integer; var T: integer);
var
  i: integer;
  delword: string;
begin
  write(' Enter delword: ');
  readln(delword);
  L := Length(delword);
  getmem (a, sizeof(mas_int)*L);
  for i := 1 to L do a^[i] := ord(delword[i]);
  write(' Enter time: ');
  readln(T);
end;


procedure transfer(var f: text; var f3: tFile);
var
  C: Char;
  k: integer;
begin
  Assign(f, 'input.txt');
  reset(f);
  Assign(f3, 'ascii');
  rewrite(f3);
  repeat
    Read(f, C);
    k := Ord(C);
    Write(f3, k);
  until EoF(f);
  Close(f);
  Close(f3);
end;

function Compare(a, b: mas_int; L: integer): boolean; {$F+}
var
  i: integer;
  bb: boolean;
begin
  i := 0;
  repeat
    Inc(i);
    bb := a^[i] = b^[i];
  until (bb = false) or (i = L);
  Compare := bb;
end;


procedure process(var f3: tFile; var f2: text; a: mas_int; L: integer; T: integer);
var
  k, i, j, m, count, n,p: integer;
  b, e1, e2: mas_int;
begin
  count := 0;
  Assign(f3, 'ascii');
  reset(f3);
  Assign(f2, 'output.txt');
  rewrite(f2);
  n := 0;
  j := 0;
  getmem (b, sizeof(integer)*L);
  for i := 1 to L do
  begin
    read(f3, k);
    b^[i] := k;
    Inc(j);
  end;

  if Compare(a, b, L) then Inc(count);
  if (count mod T) = 0 then
  begin
    Inc(n);
  end;

  repeat
    if not (EoF(f3)) then
    begin
      Inc(j);
      for i := 2 to L do b^[i - 1] := b^[i];
      read(f3, k);
      b^[L] := k;
      if Compare(a, b, L) then Inc(count);
      if Compare(a, b, L) and ((count mod T) = 0) then
      begin
        Inc(n);
      end;
    end;
  until EoF(f3);
  close(f3);
  getmem (e1, sizeof(integer)*n);
  getmem (e2, sizeof(integer)*n);

  reset(f3);
  j:=0;
  n:=0;
  count:=0;
  if Compare(a, b, L) then Inc(count);
  if (count mod T) = 0 then
  begin
    inc(n);
    e1^[1] := 1;
    e2^[1] := L;
  end;

  repeat
    if not (EoF(f3)) then
    begin
      Inc(j);
      for i := 2 to L do b^[i - 1] := b^[i];
      read(f3, k);
      b^[L] := k;
      if Compare(a, b, L) then Inc(count);
      if Compare(a, b, L) and ((count mod T) = 0) then
      begin
        inc(n);
        e1^[n] := j - (L - 1);
        e2^[n] := j;
      end;
    end;
  until EoF(f3);
  close(f3);

  Reset(f3);
  if e1^[1] > 1 then
    for i := 1 to e1^[1] - 1 do
    begin
      Read(f3, k);
      Write(f2, Chr(k));
    end;
  for m := 1 to n do
  begin
    for i := e1^[m] to e2^[m] do Read(f3, k);
    if m < n then
      for i := e2^[m] + 1 to e1^[m + 1] - 1 do
      begin
        Read(f3, k);
        Write(f2, Chr(k));
      end;
  end;
  while not (EoF(f3)) do
  begin
    Read(f3, k);
    Write(f2, Chr(k));
  end;
  Close(f3);
  Close(f2)
end;

var
  f0, f, f2: text;
  f3: tFile;
  delword: string;
  a: mas_int;
  time, L: integer;

begin
  clrscr;
  show(f);
  input(a, L, time);
  transfer(f, f3);
  process(f3, f2, a, L, time);
end.

Vladimir_S 20.04.2019 09:19
Цитата:
Сообщение от -Polina- (Сообщение 2643437)
Vladimir_S, здравствуйте.
Здравствуйте, Полина!
Цитата:
Сообщение от -Polina- (Сообщение 2643437)
У меня несколько вопросов к реализуемой Вами программе.
"Реализуемой"?!! Нет-нет, никакой торговли, я только за спасибо! :)
Цитата:
Сообщение от -Polina- (Сообщение 2643437)
При большом объеме текста, программа выдает ошибку о нехвате памяти
Что крайне странно. На службе я на своём убогом DOS Free Pascal работаю с гигабайтными файлами. Текстовыми, правда.
Цитата:
Сообщение от -Polina- (Сообщение 2643437)
Хотела бы узнать, как реализовать более эффективно.
Тут, скорее, Вам карты в руки: я использую динамические переменные редко и знаю эту кухню, скажем так, нетвёрдо. Так что оптимизации мне не по зубам.
Цитата:
Сообщение от -Polina- (Сообщение 2643437)
Мой второй вопрос: допустим у нас предложение: "it is his brother". Так как программа реализует проверку по посимвольному сдвигу, то после удаления слова "is", у нас останется "it h brother". Так и нужно? Ведь слова "his" и "is" это разные слова.
Совершенно верно: отслеживаются лишь цепочки символов. Вроде как Марию-Мери это устроило. Но мне кажется, что можно довольно легко расширить программу, чтобы она работала именно по словам. Для этого нужно, как это сделано в варианте из поста #9, ввести множество символов – знаков препинания (включая пробел), а потом, при отборе, для включения в массивы е1 и е2 поставить дополнительное условие: чтобы предшествующий рассматриваемой цепочке символ был пробелом (кроме самой первой цепочки – но она и так рассматривается отдельно), а последующий символ входил в указанное множество (либо появился признак конца файла).

Vladimir_S 21.04.2019 12:45
Так, ну, дорогие барышни, достали вы меня окончательно (в хорошем смысле :) ). Короче говоря, поколдовал я ещё с этой программкой, ну, надеюсь, теперь уже окончательно! Исправления:
1. Исправлен небольшой ляп (мой, признаЮ), вследствие которого сглатывались первые L символов, если они не соответствовали исключаемому слову.
2. Теперь работает только по СЛОВАМ, даже окружённым знаками препинания или признаком конца строки. Если искомое слово является ЧАСТЬЮ более длинного, то такие вставки исключаются из рассмотрения.
Код:
Uses CRT;

Const
 CC:Set of Char=[' ','.',',','!','?',':',';',')','"'];

Type
 matr = array[1..30] of integer;
 tFile = file of integer;


//Перевожу символы в ascii-коды
//(здесь пользователь вводит слово, которое надо удалить)
procedure input(var a:matr; var L:integer; var T:integer);
var
 i:integer;
 delword:string;
begin
 write(' Enter delword: ');
 readln(delword);
 L:=Length(delword);
 for i:=1 to length(delword) do a[i]:=ord(delword[i]);
 write(' Enter time: ');
 readln(T);
end;

//Перевожу все символы в ascii-коды
//(здесь слова, которые были в файле)
procedure transfer(var f:text; var f3:tFile);
var
 C:Char;
 k:integer;
begin
 Assign(f,'D:\input.txt');
 reset(f);
 Assign(f3, 'D:\ascii');
 rewrite(f3);
 repeat
  Read(f,C);
  k:=Ord(C);
  Write(f3,k);
 until EoF(f);
 Close(f);
 Close(f3);
end;

function Compare(a,b:matr; L:integer):boolean;
var
 i:integer;
 bb:boolean;
begin
 i:=0;
 repeat
  Inc(i);
  bb:=a[i]=b[i];
 until (bb=false) or (i=L);
 Compare:=bb;
end;

//Удачная попытка удалить
procedure process (var f3:tFile; var f2:text; a:matr; L:integer; T:integer);
var
 k,i,j,m,count,n:integer;
 b,e1,e2:matr;
 bb1,bb2:boolean;
 C_bef:Char;
begin
 count:=0;
 Assign(f3,'D:\ascii');
 reset(f3);
 Assign(f2, 'D:\output.txt');
 rewrite(f2);
 n:=0;
 j:=0;
 bb1:=false;
 bb2:=false;
 for i:=1 to L do
  begin
  read(f3,k);
  b[i]:=k;
  Inc(j);
  end;
 if Compare(a,b,L) then
  begin
  bb1:=true;
  Inc(count);
  if ((count mod T)=0) then
    begin
    bb2:=true;
    n:=1;
    e1[1]:=1;
    e2[1]:=L;
    end;
  end;

 While Not(EoF(f3)) do
  begin
  Inc(j);
  C_bef:=Chr(b[1]);
  for i:=2 to L do b[i-1]:=b[i];
  read(f3,k);
  b[L]:=k;
  if Not(Chr(b[L]) in CC) and Not(k=13) and Not(k=39) then
    begin
    if bb1 then Dec(count);
    if bb2 then Dec(n);
    end;
  bb1:=false;
  bb2:=false;
  if ((C_bef=' ') or (C_bef='(') or (C_bef='"') or (C_bef=Chr(39)) or (C_bef=Chr(10))) then
    begin
    if Compare(a,b,L) then
      begin
      bb1:=true;
      Inc(count);
      if (count mod T)=0 then
        begin
        bb2:=true;
        Inc(n);
        e1[n]:=j-(L-1);
        e2[n]:=j;
        end;
      end;
    end;
  end;

 Reset(f3);
 if e1[1]>1 then
  for i:=1 to e1[1]-1 do
  begin
    Read(f3,k);
    Write(f2,Chr(k));
  end;
 for m:=1 to n do
  begin
  for i:=e1[m] to e2[m] do Read(f3,k);
  if m<n then
    for i:=e2[m]+1 to e1[m+1]-1 do
    begin
      Read(f3,k);
      Write(f2,Chr(k));
    end;
  end;
  While Not(EoF(f3)) do
  begin
    Read(f3,k);
    Write(f2, Chr(k));
  end;
 Close(f3);
 Close(f2);
end;

var
  f0,f,f2: text;
  f3:tFile;
  delword: string;
  a:matr;
  time,L:integer;
Begin
 clrscr;
 input(a, L, time);
 transfer(f, f3);
 process(f3, f2, a, L, time);
End.
Теперь, Полина, касательно переполнения памяти. Кажется, понял я, "откуда ноги растут". Дело в том, что в процедуре Process есть такая переменная j, которая считает ВСЕ символы ascii-файла. Ну и конечно, если файл большой, то их количество может превзойти лимит формата Integer, и тогда система заругается. Возникает вопрос — что делать (вариант с переходом на динамическую адресацию я не рассматриваю)? Ответ зависит от того, какой у Вас Паскаль (к сожалению, об этом Вы не пишете): либо это нормальный Turbo или Free, либо этот (не будь к ночи помянут) ABC. В первом случае задача решается изменением типа переменной j с Integer на либо знаковые LongInt (4 Byte), Int64 (8 Byte), либо, что предпочтительнее, беззнаковые Cardinal (4 Byte) или QWorg (8 Byte). Восьмибайтовых должно хватить на все случаи жизни. А если у Вас этот... ну... ABC, то ищите сами, какие у него есть расширенные целочисленные форматы. Я не в теме.

prima 21.04.2019 12:58
Браво, Владимир Игоревич!

Vladimir_S 21.04.2019 13:21
Цитата:
Сообщение от prima (Сообщение 2643632)
Браво, Владимир Игоревич!
tehno022tehno022tehno022

-Polina- 24.04.2019 09:15
Vladimir_S, Владимир Игоревич, Вы лучший!:pre:


Часовой пояс GMT +4, время: 23:53.

Powered by vBulletin® Version 4.5.3
Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.