IPB
ЛогинПароль:

> Прочтите прежде чем задавать вопрос!

1. Заголовок темы должен быть информативным. В противном случае тема удаляется ...
2. Все тексты программ должны помещаться в теги [code=pas] ... [/code], либо быть опубликованы на нашем PasteBin в режиме вечного хранения.
3. Прежде чем задавать вопрос, см. "FAQ", если там не нашли ответа, воспользуйтесь ПОИСКОМ, возможно такую задачу уже решали!
4. Не предлагайте свои решения на других языках, кроме Паскаля (исключение - только с согласия модератора).
5. НЕ используйте форум для личного общения, все что не относится к обсуждению темы - на PM!
6. Одна тема - один вопрос (задача)
7. Проверяйте программы перед тем, как разместить их на форуме!!!
8. Спрашивайте и отвечайте четко и по существу!!!

 
 Ответить  Открыть новую тему 
> Удалить слово, Из текстового файла
сообщение
Сообщение #1


Гость






дан текстовый файл... Пользователь вводит слово. Если оно есть в файле, то прога удаляет его. Напишите, плиз, основную процедуру удаления. А то, что только не делал, и слова отделял, и сравнивал - не пашет...

Код
program ex1;
uses crt;
procedure deleting(infile,outfile, word:string);
var f_,v:text; st,wt:string; chars:set of char;i:byte;
begin
chars:=['a'..'z'];
assign(f_,infile);
reset(f_);
assign(v,outfile);
rewrite(v);
while not eof(f_) do begin
readln(f_,st);
i:=1;
repeat
while not (st[i] in chars) and (i<=length(st)) do inc(i);
wt:='';
while (st[i] in chars) and (i<=length(st)) do
begin
wt:=wt+st[i];
inc(i);
end;
if length(wt)<>0 then writeln(v,wt);
until (i>length(st))
end;
close(f_);
close(v);
reset(v);
while not eof(v) do
begin
readln(v,st);
if st=word then delete(st,1,length(word));
end;
close(v);
reset(v);
end;
var word1,st1,filename:string; f:text;
begin
write('word: ');
readln(word1);
writeln('from <f>ile?');
if (readkey='f') then
begin
write('filename: ');
readln(filename)
end else
begin
assign(f,'d:\bin\b.dat');
rewrite(f);
writeln('input text');
repeat
readln(st1);
if st1<>'' then writeln(f,st1);
until st1='';
close(f);
filename:='d:\bin\b.dat';
end;
deleting(filename,'d:\bin\res.dat',word1);
assign(f,'d:\bin\res.dat');
reset(f);
while not eof(f) do
begin
readln(f,st1);
writeln(st1);
end;

end.


Код ставим в теги...
 К началу страницы 
+ Ответить 
сообщение
Сообщение #2


Гость






Wait
А зачем такие сложности? Все, по-моему, гораздо проще. Пишем функцию:
Код
function del_word(myword, str: string): string;
 begin
   p := pos(myword, str);
   if p <> 0 then
     delete(str, p, length(myword));
   del_word := str;
 end;


И теперь в основной программе читаем из исходного файла строку за строкой, но в результирующий файл пишем строку, на которой отработала вышеописанная функция:
Код

var f_in, f_out: text;
...
while not eof(f_in) do
 begin
   readln(f_in, s);
   writeln(f_out, del_word(word_to_delete, s));
 end;

здесь word_to_delete - то слово, которое нужно удалить...
 К началу страницы 
+ Ответить 
сообщение
Сообщение #3


Гость






Большое спасибо, но програма удаляет не только слова, а, например, если надо удалить "ттт", то в строке "рррттт" она удаляет "ттт", хотя это не является словом. ПОМОГИТЕ!!!!!!!!! Нужно еще, наверно, провеить на наличие пробелов или знаков до и после слова. Как это сделать? Очень прошу, помогите. Заранее благодарен
 К началу страницы 
+ Ответить 
сообщение
Сообщение #4


Гость






Ну тогда вот так (приведенная здесь функция isLetter проверяет, является ли символ латинской буквой; для работы с кириллицей нужно немного изменить функцию, поищите по форуму, она выкладывалась...):
Код
function isLetter(ch: char): boolean;
 begin
   isLetter := upcase(ch) in ['A' .. 'Z']
 end;

(* Теперь функция del_word удаляет только те последовательности,
справа и слева от которых стоят символы, не являющиеся буквами *)
function del_word(myword, str: string): string;
 var p: byte;
 begin
   p := pos(myword, str);
   if p <> 0 then
     if ( (p > 1) and (not isLetter(str[pred(p)])) ) and
        (
          (p + length(myword) < length(str)) and
          (not isLetter( str[ succ(p + length(myword)) ] ))
        )
        then delete(str, p, length(myword));
   del_word := str;
end;
 К началу страницы 
+ Ответить 
сообщение
Сообщение #5


Гость






Очень извиняюсь, но теперь она не удаляет просто слова, не входящего ни в какие слова, а то, что я просил, она выполняет. Здесь что-то не так, наверно, проверьте, пожалуйста еще раз, если не трудно.Вообще, моя задача звучит так: написать программу, которая содержит процедуру, которая удаляет слово в файле. Возможно, что-то в проге не так, но я все проверил.

Код
undefinedprogram ex1;
uses crt;
procedure del(infile,outfile,w:string);
var f_in,f_out,f_:text;word,s,wt:string;chars:set of char; i:byte;
function letter(ch:char):boolean;
begin
letter:=ch in ['a'..'z']
end;
function del_word(str,myword:string):string;
var p:byte;
begin
p:=pos(myword,str);
if p<>0 then
if ((p>1)and(not letter(str[pred(p)])))
and((p+length(myword)<length(str))and(not letter(str[succ(p+length(myword))])))
then
delete(str,p,length(myword));
del_word:=str;
end;
begin
chars:=['a'..'z'];
assign(f_in,'b.dat');
reset(f_in);
assign(f_out,'res.dat');
rewrite(f_out);
assign(f_,'res1.dat');
rewrite(f_);
while not eof(f_in) do begin
readln(f_in,s);
i:=1;
repeat
while not(s[i] in chars) and (i<=length(s)) do inc(i);
wt:='';
while (s[i] in chars) and (i<=length(s)) do
begin
wt:=wt+s[i];
inc(i);
end;
if length(wt)<>0 then writeln(f_out,wt);
until(i>length(s))
end;
close(f_in);
close(f_out);
reset(f_out);
while not eof(f_out) do begin
readln(f_out,s);
writeln(f_,del_word(s,w));
end;
close(f_);
close(f_out);
end;
var f:text; word1,s1:string;
begin
writeln('vvedite slovo');
readln(word1);
assign(f,'b.dat');
rewrite(f);
writeln('input text');
repeat
readln(s1);
if s1<>'' then writeln(f,s1);
until s1='';
close(f);
writeln('---------------');
del('res.dat','res1.dat',word1);
assign(f,'res1.dat');
reset(f);
while not eof(f) do
begin
readln(f,s1);
writeln(s1);
end;
readkey
end.






 К началу страницы 
+ Ответить 
сообщение
Сообщение #6


Гость






Цитата(volvo @ 1.03.05 20:57)
(приведенная здесь функция isLetter проверяет, является ли символ латинской буквой; для работы с кириллицей нужно немного изменить функцию, поищите по форуму, она выкладывалась...)

У Вас же наверняка работа с кириллицей !!! Внимательнее читайте ответы. Моя функция удаляет из строк отдельно стоящие слова (не являющиеся частью других слов)... Замените функцию Letter и она будет работать с кириллицей тоже.
 К началу страницы 
+ Ответить 
сообщение
Сообщение #7


Гость






я прочитал ваш ответ, что-то заменил,но не понимаю, как ее правильно заменить. Если вам не трудно, пожалуйста, напишите, как должна выглядеть моя функция, а то уже не понимаю :molitva: :molitva: :molitva: sad.gif unsure.gif lol.gif

Добавлено (2.03.05, 01:14 PM):
я с латинскими буквами работаю
 К началу страницы 
+ Ответить 
сообщение
Сообщение #8


Гость






Да, я понял в чем проблема... Раньше просто не обратил на это внимание... rolleyes.gif Вот эта процедура del_word должна сработать (вставьте ее в свою программу). Кстети, можете погонять всю мою программу, изменяя входную строку, может быть еще какие-то комбинации не отрабатывают :

Код
function isLetter(ch: char): boolean;
 begin
   isLetter := upcase(ch) in ['A' .. 'Z', '0' .. '9']
 end;

function del_word(myword, str: string): string;

 var p, last: byte;
     to_delete: boolean;
     first, start: integer;

 function FirstLetter: boolean;
   begin
     FirstLetter := (first > 0) and (isLetter(str[first]))
   end;
 function LastLetter: boolean;
   begin
     LastLetter := (last < length(str) + 1) and (isLetter(str[last]))
   end;

 begin
   start := 1;
   Repeat
     p := Pos(myWord, Copy(str, start, 255));
     Inc(p, Byte(p > 0) * Pred(start));

     Last := p + length(myword);
     First := Pred(p);

     If p > 0 Then
       Begin
         to_delete := true;
         if (
              (first = 0) and LastLetter
            )
            or
            (
              (last = length(str) + 1) and FirstLetter
            )
            or
            (
              FirstLetter or LastLetter
            )
           then to_delete := false;
         if to_delete then
           delete(str, p, length(myword))
         else start := last
       end;

   until p = 0;
   del_word := str;
end;



begin
 writeln( del_word('start',
   'starts11 jj stop, start begin start starts 22begin ') )
end.
 К началу страницы 
+ Ответить 
сообщение
Сообщение #9


Гость






Гигантское спасибо!!!!!!!!!!!!!!!!!!!!!!!!!!
Только объясните, пожалуйста, если я вам еще не надоел, что означает
byte(p>0)???
очень интересно...
да и надо мне знать, что ответить, если спросят на защите :flowers: :rose: :thanks: :thanks: :thanks: ...............
а вообще, моей благодарности нет пределов
 К началу страницы 
+ Ответить 
сообщение
Сообщение #10


Гость






Код
Inc(p, Byte(p > 0) * Pred(start));

можно заменить на вот это:
Код
If p > 0 Then
 Inc(p, Pred(start));
 К началу страницы 
+ Ответить 
сообщение
Сообщение #11


Гость






thanks
в подарок могу написать стих
Ничего из прошлого

Как трудно ничего из прошлого
Не вспоминать, не выносить,
Забыть все недостойное и ложное
Как только сложно все забыть!

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

Ты меня сделал бессильной и слабой –
Я так не привыкла тебя не любить,
Может мне вспомнить все прошлое, дабы
Легче стало обо всем забыть…

Не чувствую, не вижу твоего лица,
(не любим мы, но нелюбовь свою таим)
Как жаль, я даже не могу начать с конца.
Как я бессильна перед холодом твоим!

Теперь я могу только дальше идти,
Так и не вспомнив ничего и не забыв,
Вперед время идет – назад нету пути,
Осталась только боль – души разрыв.

…Но я смогу взлететь, подняться ввысь.
И меня к жизни вернет сама жизнь…
 К началу страницы 
+ Ответить 

 Ответить  Открыть новую тему 
1 чел. читают эту тему (гостей: 1, скрытых пользователей: 0)
Пользователей: 0

 





- Текстовая версия 4.12.2021 18:35
500Gb HDD, 6Gb RAM, 2 Cores, 7 EUR в месяц — такие хостинги правда бывают
Связь с администрацией: bu_gen в домене octagram.name