06.04.2019, 18:33 | #11 (permalink) |
Специалист
Регистрация: 27.08.2008
Адрес: Санкт-Петербург
Сообщений: 27,807
Сказал(а) спасибо: 340
Поблагодарили 583 раз(а) в 208 сообщениях
Репутация: 113184
|
Надеюсь, что скоро "добью". Но задачка чертовски интересная. Это не поиск максимального элемента массива и пр., с которыми, в основном, лоботрясы сюда и обращаются. |
06.04.2019, 18:33 | |
Helpmaster
Member
Регистрация: 08.03.2016
Сообщений: 0
|
Обязательно обратите внимание на аналогичные топики Групповая политика, нужена подсказка ТП-60-10 нужна подсказка Нужна подсказка нужна подсказка знающих Нужна подсказка по светодиодам |
07.04.2019, 13:59 | #12 (permalink) |
Специалист
Регистрация: 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. |
08.04.2019, 12:13 | #13 (permalink) |
Новичок
Регистрация: 31.03.2019
Сообщений: 7
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Репутация: 10
|
Vladimir_S, Вау, Вы смогли ее добить! Оказывается надо просто работать с исходным файлом, а я Вам какие-то преобразования "строка-слово"навязала Спасибо Вам огромное-преогромное!
|
20.04.2019, 00:27 | #15 (permalink) |
Новичок
Регистрация: 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. |
Ads | |
Member
Регистрация: 31.10.2006
Сообщений: 40200
Записей в дневнике: 0
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Репутация: 55070
|
20.04.2019, 09:19 | #16 (permalink) |
Специалист
Регистрация: 27.08.2008
Адрес: Санкт-Петербург
Сообщений: 27,807
Сказал(а) спасибо: 340
Поблагодарили 583 раз(а) в 208 сообщениях
Репутация: 113184
|
Здравствуйте, Полина!"Реализуемой"?!! Нет-нет, никакой торговли, я только за спасибо! Что крайне странно. На службе я на своём убогом DOS Free Pascal работаю с гигабайтными файлами. Текстовыми, правда. Тут, скорее, Вам карты в руки: я использую динамические переменные редко и знаю эту кухню, скажем так, нетвёрдо. Так что оптимизации мне не по зубам.Совершенно верно: отслеживаются лишь цепочки символов. Вроде как Марию-Мери это устроило. Но мне кажется, что можно довольно легко расширить программу, чтобы она работала именно по словам. Для этого нужно, как это сделано в варианте из поста #9, ввести множество символов – знаков препинания (включая пробел), а потом, при отборе, для включения в массивы е1 и е2 поставить дополнительное условие: чтобы предшествующий рассматриваемой цепочке символ был пробелом (кроме самой первой цепочки – но она и так рассматривается отдельно), а последующий символ входил в указанное множество (либо появился признак конца файла).
|
21.04.2019, 12:45 | #17 (permalink) |
Специалист
Регистрация: 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. |
21.04.2019, 12:58 | #18 (permalink) |
Member
Регистрация: 31.08.2015
Сообщений: 19,433
Сказал(а) спасибо: 283
Поблагодарили 213 раз(а) в 96 сообщениях
Репутация: 80884
|
Браво, Владимир Игоревич!
__________________
Пожалуйста не предлагайте мне дружбу. Не хочу отказывать, но у меня другие понятия, поэтому просто не отвечу. |
24.04.2019, 09:15 | #20 (permalink) |
Новичок
Регистрация: 20.04.2019
Сообщений: 2
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Репутация: 10
|
Vladimir_S, Владимир Игоревич, Вы лучший!re:" class="inlineimg" />
|
Ads | |
Member
Регистрация: 31.10.2006
Сообщений: 40200
Записей в дневнике: 0
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Репутация: 55070
|
|
|