Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "Прочее";
Текущий архив: 2006.12.10;
Скачать: [xml.tar.bz2];

Вниз

Помогите создать функцию, умеющая красиво сокращать текст   Найти похожие ветки 

 
DelphiLexx ©   (2006-11-21 11:02) [0]

Помогите создать функцию, которая умела бы хорошо сокращать передаваемую фразу, если она превыщает 20 символов, например:
Полное название: МАРГАНЕЦ ДОБАВКА ПРЕМИКСОВ
Сокращенное название: МАРГАНЕЦ ДОБ ПРМ


 
Сергей М. ©   (2006-11-21 11:17) [1]

Красота - понятие растяжимое.
Мне вот кажется, что красивей ДОБАВКА = ДБВ, да и ДБК тоже симпатюшно...

ПРиводи свой критерий "красивости", а уж за помощью, думаю, дело не встанет)


 
ЮЮ ©   (2006-11-21 11:26) [2]

Не возр со. б об-ны этой ф-ей
Не удается до 20-ти сократить? :) А проблема откуда? Своих проблем не хватает?


 
Elen ©   (2006-11-21 12:02) [3]


> DelphiLexx

А что за проблема сокращай до второй согласной после гласной


 
DelphiLexx ©   (2006-11-21 12:26) [4]


> А что за проблема сокращай до второй согласной после гласной

Идея хорошая. С кодом не мог бы помочь.


 
clickmaker ©   (2006-11-21 12:33) [5]

а лучше убирай вообще все гласные. Если потом согласных останется, больше трех, убирай несогласных )


 
Плохиш ©   (2006-11-21 12:33) [6]


> Идея хорошая. С кодом не мог бы помочь.

Так бы сразу и говорил "Код давай", а то начал юлить "Помогите создать функцию".


 
Горгер ©   (2006-11-21 13:01) [7]

unit Unit1;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, StdCtrls;

type
 TForm1 = class(TForm)
   Memo1: TMemo;
   Button1: TButton;
   procedure Button1Click(Sender: TObject);
 private
   { Private declarations }
 public
   { Public declarations }
 end;

var
 Form1: TForm1;

implementation
function StrTok(var arg:string):string;
begin
result:=Copy(arg,1,Pos(" ",arg)-1);
delete(arg,1,Pos(" ",arg));
end;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var s,ss:string;
    i,j,k:byte;
    sglcount:byte;

begin
for i:=0 to Memo1.Lines.Count-1 do begin
s:=Memo1.Lines.Strings[i]+" ";
While Length(s)>0 do begin
sglcount:=0;
ss:=StrTok(s);
ss:=copy(ss,1,4);
for j:=1 to Length(ss)-1 do begin
if Pos(ss[j],"ауоАУО")>0 then inc(sglcount);
end;   {FOR J...}
if sglcount=0 then  begin
 for k:=1 to length(ss) do begin
if k>1 then if Pos(ss[k],"ЕИЫЮЭ")>0 then delete(ss,k,1);end; end;
ss:=copy(ss,1,3);
ShowMessage(ss);

end    
end;
end;

end.


 
Elen ©   (2006-11-21 13:21) [8]


> Идея хорошая. С кодом не мог бы помочь

за НЕ МОГ

var e,s:string;w,r,n,i:integer;
begin
s:="Марганец новый вкусный";e:="";
i:=1;
while i<length(s) do begin
if (i=1)or(s[i]=" ") then n:=0;
 while (s[i]<>" ")and(n<2) do begin
  if (pos(AnsiLowerCase(s[i]),"уеаоыюия")>0) then inc(n);
 e:=e+s[i];   inc(i);
 end;
inc(i); e:=e+" ";
end;
caption:=e;


 
RWolf ©   (2006-11-21 13:26) [9]

не стал бы доверять создание сокращений машине...


 
clickmaker ©   (2006-11-21 13:28) [10]


> [9] RWolf ©   (21.11.06 13:26)

Да. Лучше Маше. Секретарше )


 
RWolf ©   (2006-11-21 13:37) [11]


>  [10]

Маша, по крайней мере, явные ляпы заменит...


 
DelphiLexx ©   (2006-11-21 13:59) [12]


> ss:=StrTok(s);

Что это за функция


 
Elen ©   (2006-11-21 14:03) [13]


> Что это за функция

в [7] все написано сразу после implementation


 
МихаилМ   (2006-11-21 16:50) [14]

DelphiLexx - халявчег :)


 
vasIzmax ©   (2006-11-21 18:23) [15]


> Горгер ©   (21.11.06 13:01)

Дополнение к библиотеке кодов. Мож и когда пригодится :))). Мож открыть по аналогии с сотовыми телефонами сайтик "Скачай бесплатно код". :)))


 
TUser ©   (2006-11-21 18:34) [16]

> Сергей М. ©   (21.11.06 11:17) [1]

Разве всегда проблема может быть четко сформулирована? Могу привести примеры совершенно реальных проблем, где это не так.


 
TUser ©   (2006-11-21 18:35) [17]

... решаемых програмно, забыл добавить.


 
DelphiLexx ©   (2006-11-22 09:28) [18]


> DelphiLexx - халявчег :)


function StrShorten(const Value: String): String;
var
 S: TStringList;
 I: Integer;
 a: string;
 function FoundEngLetter(Text: string): boolean;
 var
   i: integer;
 begin
   {если в слове есть английская буква, то предполагется, что это формула}
   for i:=0 to Length(Text) do
   begin
     Result := false;
     if Pos(AnsiLowerCase(Text[i]), "qwertyuioplkjhgfdsazxcvbnm") <> 0 then
     begin
       Result := true;
       break;
     end;
   end;
 end;
begin
 Result := "";
 S := TStringList.Create;
 try
   S.DelimitedText := Value;
   for I := 0 to S.Count - 1 do
     if (Length(S[I]) > 3) and (not FoundEngLetter(S[i])) then
     begin
       Result := Result + Copy(S[I], 1, Length(S[I]) div 2);
       a := copy(Result, Length(Result), 1);
       if Pos(AnsiLowerCase(a), "уеаоыюия) <> 0 then
         Delete(Result, Length(Result), 1);
       Result := Result + ". ";
     end
     else
       Result := Result + S[I] + " ";
 finally
   S.Free;
 end;
end;


 
Горгер ©   (2006-11-22 18:18) [19]

function StrTok(var arg:string):string;
begin
result:=Copy(arg,1,Pos(" ",arg)-1);
delete(arg,1,Pos(" ",arg));
end;


 
Горгер ©   (2006-11-22 18:21) [20]

function StrTok(var arg:string):string; возвращает из строки подстроку начиная с первого символа до пробела, после чего удаляет из исходного аргумента эту подстроку. Таким образом можно выделить из текста все слова последовательно одно за другим ( поскольку аргумент передается по ссылке).


 
kaif ©   (2006-11-23 00:16) [21]

copy(s, 20) + " ТЫРЫ - ПЫРЫ..."


 
Oreolek ©   (2006-11-23 03:25) [22]

Удаляешь в слове гласные оставляешь 3 первых буквы.
СОздаешь словарь сокращений.
Продаешь программу,чтобы вернуть деньги на потраченное пиво
Борешься с крекерами
Знакомишься с крекерами
Жружишь с крекерами
Нанимаешь крекеров,чтобы они тебе сделалаи зашиту на пррограмму и снова ее продаешь
Крекеры тебя предают и туту же выставляют крек
Ругаешься с крекерами и их выгоняешь
Продаешь программу
а дальше вы знаете...


 
Ппп   (2006-11-23 07:23) [23]

Oreolek ©   (23.11.06 03:25) [22]
Вин2к?


 
Elen ©   (2006-11-23 08:18) [24]


> Жружишь с крекерами

Э-э-э может Жужжиш? или лучше Гудиш?



Страницы: 1 вся ветка

Форум: "Прочее";
Текущий архив: 2006.12.10;
Скачать: [xml.tar.bz2];

Наверх




Память: 0.5 MB
Время: 0.042 c
9-1138683498
Bogdan1024
2006-01-31 07:58
2006.12.10
как облегчить игру?


15-1163962639
Kerk
2006-11-19 21:57
2006.12.10
Лампочка своими руками


6-1153229738
avram
2006-07-18 17:35
2006.12.10
сокеты


15-1164009374
cyborg
2006-11-20 10:56
2006.12.10
Нет доступа к рабочей группе


3-1159787864
ceval
2006-10-02 15:17
2006.12.10
Enter в DBgridе





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский