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


Гость






Да, я понял в чем проблема... Раньше просто не обратил на это внимание... 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.
 К началу страницы 
+ Ответить 

Сообщений в этой теме


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

 





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