Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Delphi программирование > Общие вопросы Delphi
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 02.03.2014, 16:41   #1
SashaRasha
Я вижу марс :)
 
Регистрация: 02.03.2014
Сообщений: 7
По умолчанию Пропадает часть текста. Алгоритм преобразования текста.

Всем привет! Программа должна удалять лишние пробелы и записывать предложения с новой строки.
При преобразовании текста происходит следующее. Если имеем текст:
Цитата:
Это крепится
сюда.
то проблем нет, получается
Цитата:
Это крепится сюда.
Если имеем текст
Цитата:
Это крепится
сюда
и это.
так же проблем нет
Цитата:
Это крепится сюда и это.
А если имеем:
Цитата:
Сюда крепится
это.
А это нет.
то получается вот так
Цитата:
Сюда крепится
А это нет.
Т.е. вторая строка почему-то удаляется.

Код:
  public
  sl: tstringlist;
    { Public declarations }
  end;
 
var
  Form1: TForm1;
 
implementation
 
uses Unit2;
 
{$R *.dfm}
 
procedure TForm1.FormCreate(Sender: TObject);
begin
sl:= tstringlist.Create;
sl.text:= 'Привет :-)'
end;
 
procedure TForm1.N2Click(Sender: TObject);
    var i, j, c, k: integer;
begin
 if opendialog1.Execute then sl.LoadFromFile(opendialog1.FileName)else exit;
 c:= 0; k:= sl.Count;
 for i:= 0 to k-1 do for j:= 1 to length(sl[i]) do
  begin
   if sl[i][j]= #32 then inc(c);
  end;
 messagedlg('Всего символов: '+ inttostr(length(sl.Text)- k*2)+ #13+
 'Количество пробелов: '+ inttostr(c)+ #13+ 'Количество строк: '+
 inttostr(sl.Count), mtinformation, [mbOK], 0);
  memo1.Text:= sl.Text;
  button2.Visible:= true;
  memo1.show
end;
 
procedure TForm1.N3Click(Sender: TObject);
begin
close
end;
 
procedure TForm1.Button2Click(Sender: TObject);
label metka1, metka2, prijok, test;
const l=' -'; t='.'; vs='!'; vp='?';
var i, j, k, n, p: integer; c: array[1..56] of char;
s: array[1..169] of string[3]; zp: string[2]; nl, buf: ansistring;
kp, ns: char;
begin
 for i:= sl.count-1 downto 0 do if sl[i]='' then sl.Delete(i);
 if sl[0]='' then begin memo2.lines[0]:= 'Файл пуст!'; goto prijok end;
 button2.Visible:= false;
 j:= 1; for i:= 65 to 90 do begin c[j]:= chr(i); j:= j+1; end;
 for i:= 192 to 217 do begin c[j]:= chr(i); j:= j+1; end;
 c[53]:= #221; c[54]:= #222; c[55]:= #223; c[56]:= #168;
 for i:= 1 to 56 do s[i]:= '. '+ c[i]; s[57]:= '...';
 j:= 58; for i:= 1 to 56 do begin s[j]:= '! '+ c[i]; j:= j+1 end;
 j:= 114; for i:= 1 to 56 do begin s[j]:= '? '+ c[i]; j:= j+1 end;
 if memo2.Text<> '' then
  begin
   k:= messagedlg('Текст в редактировании будет удален',
   mtwarning, [mbOk, mbCancel], 0);
   if k = mrOk then memo2.clear else exit
  end;
 n:= sl.Count;
 for i:= 0 to n-1 do
  begin
   buf:= trim(sl[i]);
   while pos('  ', buf) <> 0 do
    begin
     p:= pos('  ', buf);
     delete(buf, p, 1);
    end;
   sl[i]:= buf
  end;
 i:=0;
 metka1: buf:= sl[i];
 metka2: k:= length(buf);
 zp:= buf[k-1]+ buf[k];
 kp:= buf[k];
 j:= 1;
 p:=0;
 while j<>169 do
  begin
   p:= ansipos(s[j], buf);
   if p<>0 then break else j:= j+1
  end;
 if p<>0 then
  begin nl:= copy(buf, p+2, k-p);
   delete(buf, p+1, k-p);
   sl[i]:= buf end;
 if (p<>0) and (i<n-1) then
  begin
   sl.Insert(i+1,(nl));
   n:= n+1; i:= i+1;
   goto metka1
  end;
 if (p<>0) and (i=n-1) then
  begin
   sl.Add(nl); n:= n+1; i:= i+1;
   goto metka1
  end;
 if (p=0) and (buf[k]='-') and (l<>zp) and (i<n-1) then
  begin
   delete(buf,k,1);
   buf:= buf+ sl[i+1];
   sl.Delete(i+1);
   n:= n-1;
   goto metka2
  end;
 if (p=0) and (i<n-1) then
  begin
   ns:= sl[i+1][1];
   j:=1;
    while j<>56 do
     begin
      if ns=c[j] then
       begin p:=1;
        goto test
       end
      else j:= j+1
     end;
   test: if ((kp=t) or (kp=vs) or (kp=vp)) and (p=1) then
    begin
     i:= i+1;
     goto metka1
    end;
  end;
 if (p=0) and (i<n-1) then
  begin
   buf:= buf +' '+ sl[i+1];
   sl.Delete(i+1);
   n:= n-1;
   goto metka2
  end;
 if (p=0) and (i=n-1) then sl[i]:= buf;
 for i:= 0 to n-1 do memo2.Lines.add(sl[i]);
 prijok: memo2.Show
end; 
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
sl.Free
end;
end.
Ошибка в роде в операторе
Код:
begin
   ns:= sl[i+1][1];
   j:=1;
    while j<>56 do
     begin
      if ns=c[j] then
       begin p:=1;
        goto test
       end
      else j:= j+1
     end;
но не могу понять в чем именно.
SashaRasha вне форума Ответить с цитированием
Старый 02.03.2014, 19:25   #2
XE5
Заблокирован
 
Регистрация: 02.03.2014
Сообщений: 439
По умолчанию

Цитата:
Сообщение от SashaRasha Посмотреть сообщение
Программа должна удалять лишние пробелы и записывать предложения с новой строки.
Код:
Uses StrUtils;
...

procedure bla_bla_bla;
const
  c: array [0..2] of string = ('.', '!', '?');
var
  i: integer;
begin
for i := Low(c) to High(c) do 
  sl.Text := StringReplace(sl.Text, c[i] + ' ', c[i] + #13#10, [rfReplaceAll]);
end;

Последний раз редактировалось XE5; 02.03.2014 в 19:30.
XE5 вне форума Ответить с цитированием
Старый 02.03.2014, 20:33   #3
SashaRasha
Я вижу марс :)
 
Регистрация: 02.03.2014
Сообщений: 7
По умолчанию

Спасибо, что-то примерное мне уже предлагали на cyberforume. Дело в том, что я хочу дополнительно детектировать в тексте сокращение. Сейчас, я уже точно нашел, в каком именно фрагменте кода ошибка. Вот он:
Код:
if (p=0) and (i<n-1) then
  begin
   ns:= sl[i+1][1];
   j:=1;
    while j<>56 do
     begin
      if ns=c[j] then
       begin p:=1;
        goto test
       end
      else j:= j+1
     end;
   test: if ((kp=t) or (kp=vs) or (kp=vp)) and (p=1) then
    begin
     i:= i+1;
     goto metka1
    end;
  end;
Если его исключить из программы, то все работает. Ну по крайней мере тест, разработанный мною на скорую руку он прошел. Вот он:
Цитата:
Данная строка содер-
жала перенос. Если это предложение начинается с начала второй строки, значит алгоритм детектирования переноса слова работает.
Если это предложение начинается с начала третей строки, значит все верно.




Если это -
предложение начинается с начала четвертой строки,
значит алгоритм соединения вышестоящего начала предложения с продолжением его на следующей строке верен!

Это пятая строка.
Это шестая строка. Это седь-
мая строка(слово "седьмая" было соединено). В этой строке под номером восемь не должно быть лишних пробелов. Проверьте, девятая ли это строка?
Это десятая строка, это во-первых,
во вторых, в ней не должно быть лишних пробелов. Если это строка имеет номер одиннадцать и она последняя а в тексте нет лишних пробелов,
значит тест пройден успешно!
Думаю Ваш вариант его тоже пройдет. Но если в текст включить сокращение, типа "т.к." или "Пушкин А.С.", то текст будет разбит, к тому же, мой алгоритм детектирует перенос слова, что то же, я думаю, очень полезно. Конечно, мой алгоритм тоже не идеальный, к примеру, если написать "Пушкин А. С.", то есть через пробел, то он будет так же разбит, но цель моя, показать преподавателю умение оперировать данными. К тому же курсовых работ по данной тематике было уже много, и не факт, что Ваш вариант пройдет тест на оригинальность. Спасибо еще раз, надеюсь, что кто-нибудь все же раскопает ошибку в моих каракулях Да чуть не забыл. Фрагмент текста, который я исключил, детектирует готовую строку, т.е. одно законченное предложение на всю строку. Без этого фрагмента, предложения сперва выталкиваются в верхние строки, а когда строки заканчиваются, текст выпрямляется операторами
Код:
if p<>0
SashaRasha вне форума Ответить с цитированием
Старый 02.03.2014, 21:06   #4
XE5
Заблокирован
 
Регистрация: 02.03.2014
Сообщений: 439
По умолчанию

Цитата:
Сообщение от SashaRasha Посмотреть сообщение
Но если в текст включить сокращение, типа "т.к." или "Пушкин А.С.", то текст будет разбит
Не будет, так как отсутствуют пробелы. Перенос произойдёт после "Пушкин А.С. ". Более грамотно искать сочетания "точка пробел заглавная буква", и проверять есть ли после заглавной буквы хоть один пробел до следующей точки. Дайте мне текстовый файл содержащий абсолютно все исключения, и текстовый файл отредактированный вручную как образец решения, напишу само решение.
XE5 вне форума Ответить с цитированием
Старый 02.03.2014, 21:27   #5
SashaRasha
Я вижу марс :)
 
Регистрация: 02.03.2014
Сообщений: 7
По умолчанию

Спасибо. для теста.rar Думаю, этого будет достаточно. Наверно самое сложное будет в последнем предложении, но его не обязательно.
SashaRasha вне форума Ответить с цитированием
Старый 02.03.2014, 22:33   #6
XE5
Заблокирован
 
Регистрация: 02.03.2014
Сообщений: 439
По умолчанию

Код:
procedure TForm1.Button1Click(Sender: TObject);
var
  TS: TStringList;
  s, tmp: string;
  i: integer;
begin
TS := TStringList.Create;
TS.LoadFromFile('D:/Тест.txt');
s := TS.Text;
TS.Free;
Memo1.Text := s;

s := StringReplace(s, '-' + #13#10, '', [rfReplaceAll]); // убирает переносы с "разрезанием" слова на две части
while pos(#13#10#13#10, s) <> 0 do
  s := StringReplace(s, #13#10#13#10, #13#10, [rfReplaceAll]); // убирает все повторяющиеся переносы
while pos('  ', s) <> 0 do
  s := StringReplace(s, '  ', ' ', [rfReplaceAll]); // убирает все повторяющиеся пробелы
s := StringReplace(s, ',' + #13#10 + ' ', ', ', [rfReplaceAll]);  // убирает перенос предложения послезапятой
s := StringReplace(s, ', ' + #13#10, ', ', [rfReplaceAll]); // убирает перенос предложения послезапятой и пробела
s := StringReplace(s, #13#10 + ' ', #13#10, [rfReplaceAll]); // убирает пробел в начале предложения "Это шестая строка"
tmp := s;
s := '';

for i := 1 to Length(tmp) -1 do begin
s := s + tmp[i];
if (tmp[i - 3] <> ' ') // " A." пробел перед буквой сокращения
     and
       (tmp[i - 1] in ['.', '!', '?']) // символы окончания предложения
         and
           (tmp[i] = ' ') // пробел после символа окончания предложения
             and
               (tmp[i + 1] in ['A'..'Z','А'..'Я']) // следующий символ после символа окончания строки и пробела
                 then
                   s := s + #13#10; // переводим строку
end;

Memo2.Text := s;
end;
И вот слегка иной метод, где вначале убираются абсолютно все переносы строки, а затем на основе анализа ближайшего окружения ключевых символов ".","!","?" принимается решение о вставке переноса строки. А так же тут показан метод выноса алфавита, и разделителей предложений в константы процедуры.

Код:
procedure TForm1.Button1Click(Sender: TObject);
const
  A: set of char= ['A'..'Z', 'А'..'Я'];
  P: set of char= ['.', '!', '?'];
var
  TS: TStringList;
  s, tmp: string;
  i: integer;
begin
TS := TStringList.Create;
TS.LoadFromFile('D:/Тест.txt');
s := TS.Text;
TS.Free;
Memo1.Text := s;
s := StringReplace(s, '-' + #13#10, '', [rfReplaceAll]); // убирает переносы с "разрезанием" слова на две части
s := StringReplace(s, #13#10, '', [rfReplaceAll]); // убирает все переносы
while pos('  ', s) > 0 do s := StringReplace(s, '  ', '', [rfReplaceAll]); // Убирает повторяющиеся пробелы
tmp := s;
s := '';
for i := 1 to Length(tmp) - 1 do begin
s := s + tmp[i];
if (tmp[i] in P) and (tmp[i + 1] in A) 
  then s := s + #13#10; // случай когда между предложениями НЕТ пробела
if (tmp[i - 3] <> ' ') and (tmp[i - 1] in P) and (tmp[i] = ' ') and (tmp[i + 1] in A) and not(tmp[i + 2] in P) 
  then s := s + #13#10;//Случай когда между предложениями ЕСТЬ пробел
end;
Memo2.Text := s;
end;
Второе решение более гибкое и позволяет обрабатывать дополнительные исключения через редактирование двух основных строк проверки символьного окружения разделителей предложений.
Изображения
Тип файла: jpg Безымянный.jpg (29.4 Кб, 138 просмотров)

Последний раз редактировалось XE5; 03.03.2014 в 04:14.
XE5 вне форума Ответить с цитированием
Старый 03.03.2014, 06:25   #7
SashaRasha
Я вижу марс :)
 
Регистрация: 02.03.2014
Сообщений: 7
По умолчанию

Огромное спасибо!
SashaRasha вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
как из текста выдрать часть текста? k500k Microsoft Office Excel 4 26.08.2012 20:09
преобразования текста (или XML) по заданным правилам IVAN_MA Помощь студентам 3 12.06.2012 17:09
Сервис преобразования текста в картинку Arigato Свободное общение 27 14.02.2012 11:15
Программа для преобразования текста в jpg alexp21 Фриланс 10 28.11.2011 18:43
Отмена преобразования текста в дату yursanch Microsoft Office Excel 5 14.01.2011 13:09