Технический форум
Вернуться   Технический форум > Программирование > Форум программистов > Помощь студентам


Ответ
 
Опции темы Опции просмотра
Старый 06.04.2019, 18:33   #11 (permalink)
Vladimir_S
Специалист
 
Регистрация: 27.08.2008
Адрес: Санкт-Петербург
Сообщений: 27,807
Сказал(а) спасибо: 340
Поблагодарили 583 раз(а) в 208 сообщениях
Репутация: 113184
По умолчанию

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

Старый 06.04.2019, 18:33
Helpmaster
Member
 
Аватар для Helpmaster
 
Регистрация: 08.03.2016
Сообщений: 0

Обязательно обратите внимание на аналогичные топики

Групповая политика, нужена подсказка
ТП-60-10 нужна подсказка
Нужна подсказка
нужна подсказка знающих
Нужна подсказка по светодиодам

Старый 07.04.2019, 13:59   #12 (permalink)
Vladimir_S
Специалист
 
Регистрация: 27.08.2008
Адрес: Санкт-Петербург
Сообщений: 27,807
Сказал(а) спасибо: 340
Поблагодарили 583 раз(а) в 208 сообщениях
Репутация: 113184
По умолчанию

Уж не знаю, актуально ещё или нет, но я это дело таки добил! Уф, ну задачка...
Значит, так.
Во-первых, никаких строк! Сочетание строк с типизированным файлом это, как оказалось, гремучая смесь: постоянно вылезают заморочки с нумерацией, обработкой служебных символов и т.п. Поэтому работаем с исходным файлом, как он есть, никаких преобразований в формат "строка-слово". Исходный текст должен быть в файле 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.
inp.jpg
sss01.jpg
outp.jpg
Vladimir_S вне форума   Ответить с цитированием
Старый 08.04.2019, 12:13   #13 (permalink)
Maria_Meri
Новичок
 
Регистрация: 31.03.2019
Сообщений: 7
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Репутация: 10
По умолчанию

Vladimir_S, Вау, Вы смогли ее добить! Оказывается надо просто работать с исходным файлом, а я Вам какие-то преобразования "строка-слово"навязала Спасибо Вам огромное-преогромное!
Maria_Meri вне форума   Ответить с цитированием
Старый 08.04.2019, 14:10   #14 (permalink)
Vladimir_S
Специалист
 
Регистрация: 27.08.2008
Адрес: Санкт-Петербург
Сообщений: 27,807
Сказал(а) спасибо: 340
Поблагодарили 583 раз(а) в 208 сообщениях
Репутация: 113184
По умолчанию

Цитата:
Сообщение от Maria_Meri Посмотреть сообщение
Спасибо Вам огромное-преогромное!
Да пожалуйста, обращайтесь, если что. А с этой задачкой — самого зацепило и не отпускало, пока не добил.
Vladimir_S вне форума   Ответить с цитированием
Старый 20.04.2019, 00:27   #15 (permalink)
-Polina-
Новичок
 
Регистрация: 20.04.2019
Сообщений: 2
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Репутация: 10
По умолчанию Дополнительные вопросы

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.
-Polina- вне форума   Ответить с цитированием
Ads

Яндекс

Member
 
Регистрация: 31.10.2006
Сообщений: 40200
Записей в дневнике: 0
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Репутация: 55070
Старый 20.04.2019, 09:19   #16 (permalink)
Vladimir_S
Специалист
 
Регистрация: 27.08.2008
Адрес: Санкт-Петербург
Сообщений: 27,807
Сказал(а) спасибо: 340
Поблагодарили 583 раз(а) в 208 сообщениях
Репутация: 113184
По умолчанию

Цитата:
Сообщение от -Polina- Посмотреть сообщение
Vladimir_S, здравствуйте.
Здравствуйте, Полина!
Цитата:
Сообщение от -Polina- Посмотреть сообщение
У меня несколько вопросов к реализуемой Вами программе.
"Реализуемой"?!! Нет-нет, никакой торговли, я только за спасибо!
Цитата:
Сообщение от -Polina- Посмотреть сообщение
При большом объеме текста, программа выдает ошибку о нехвате памяти
Что крайне странно. На службе я на своём убогом DOS Free Pascal работаю с гигабайтными файлами. Текстовыми, правда.
Цитата:
Сообщение от -Polina- Посмотреть сообщение
Хотела бы узнать, как реализовать более эффективно.
Тут, скорее, Вам карты в руки: я использую динамические переменные редко и знаю эту кухню, скажем так, нетвёрдо. Так что оптимизации мне не по зубам.
Цитата:
Сообщение от -Polina- Посмотреть сообщение
Мой второй вопрос: допустим у нас предложение: "it is his brother". Так как программа реализует проверку по посимвольному сдвигу, то после удаления слова "is", у нас останется "it h brother". Так и нужно? Ведь слова "his" и "is" это разные слова.
Совершенно верно: отслеживаются лишь цепочки символов. Вроде как Марию-Мери это устроило. Но мне кажется, что можно довольно легко расширить программу, чтобы она работала именно по словам. Для этого нужно, как это сделано в варианте из поста #9, ввести множество символов – знаков препинания (включая пробел), а потом, при отборе, для включения в массивы е1 и е2 поставить дополнительное условие: чтобы предшествующий рассматриваемой цепочке символ был пробелом (кроме самой первой цепочки – но она и так рассматривается отдельно), а последующий символ входил в указанное множество (либо появился признак конца файла).
Vladimir_S вне форума   Ответить с цитированием
Старый 21.04.2019, 12:45   #17 (permalink)
Vladimir_S
Специалист
 
Регистрация: 27.08.2008
Адрес: Санкт-Петербург
Сообщений: 27,807
Сказал(а) спасибо: 340
Поблагодарили 583 раз(а) в 208 сообщениях
Репутация: 113184
По умолчанию

Так, ну, дорогие барышни, достали вы меня окончательно (в хорошем смысле ). Короче говоря, поколдовал я ещё с этой программкой, ну, надеюсь, теперь уже окончательно! Исправления:
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, то ищите сами, какие у него есть расширенные целочисленные форматы. Я не в теме.
Vladimir_S вне форума   Ответить с цитированием
Старый 21.04.2019, 12:58   #18 (permalink)
prima
Member
 
Регистрация: 31.08.2015
Сообщений: 19,433
Сказал(а) спасибо: 283
Поблагодарили 213 раз(а) в 96 сообщениях
Репутация: 80884
По умолчанию

Браво, Владимир Игоревич!
__________________
Пожалуйста не предлагайте мне дружбу. Не хочу отказывать, но у меня другие понятия, поэтому просто не отвечу.
prima вне форума   Ответить с цитированием
Старый 21.04.2019, 13:21   #19 (permalink)
Vladimir_S
Специалист
 
Регистрация: 27.08.2008
Адрес: Санкт-Петербург
Сообщений: 27,807
Сказал(а) спасибо: 340
Поблагодарили 583 раз(а) в 208 сообщениях
Репутация: 113184
По умолчанию

Цитата:
Сообщение от prima Посмотреть сообщение
Браво, Владимир Игоревич!
Vladimir_S вне форума   Ответить с цитированием
Старый 24.04.2019, 09:15   #20 (permalink)
-Polina-
Новичок
 
Регистрация: 20.04.2019
Сообщений: 2
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Репутация: 10
По умолчанию

Vladimir_S, Владимир Игоревич, Вы лучший!re:" class="inlineimg" />
-Polina- вне форума   Ответить с цитированием
Ads

Яндекс

Member
 
Регистрация: 31.10.2006
Сообщений: 40200
Записей в дневнике: 0
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Репутация: 55070
Ответ


Ваши права в разделе
Вы не можете создавать новые темы
Вы не можете отвечать в темах
Вы не можете прикреплять вложения
Вы не можете редактировать свои сообщения

BB коды Вкл.
Смайлы Вкл.
[IMG] код Выкл.
HTML код Выкл.
Trackbacks are Вкл.
Pingbacks are Вкл.
Refbacks are Выкл.




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

Powered by vBulletin® Version 6.2.5.
Copyright ©2000 - 2014, Jelsoft Enterprises Ltd.