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

← →
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 - халявчег :)

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;

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

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

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

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

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

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

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

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