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

Вниз

Оптимизация процедуры   Найти похожие ветки 

 
Tosov   (2002-01-02 23:37) [0]

Помогите сделать следующий код быстрее (если это возможно)

procedure WriteText(ARect:TRect;Text:String);
var
Widths:Integer;
pos1,pos2:Integer;
subtext:String;
Modif :String;
Tops:Integer;
begin
Tops:=0;
Widths:=2;
repeat
pos1:=Pos("[",Text);
pos2:=Pos("]",Text);

if Pos1=0 then Pos1:=Length(Text)+1;
Subtext:=Copy(Text,1,Pos1-1);
Canvas.TextOut(ARect.Left+Widths,ARect.Top+2+Tops,SubText);
Widths:=Widths+Canvas.TextWidth(SubText)+2;
Modif:=Copy(Text,Pos1+1,Pos2-Pos1-1);
if Length(Modif)=0 then Modif:=" ";
if Modif[1]="#"
then begin
if Pos("B",UpperCase(Modif))<>0 then Canvas.Font.Style:=Canvas.Font.Style+[fsBold];
if Pos("U",UpperCase(Modif))<>0 then Canvas.Font.Style:=Canvas.Font.Style+[fsUnderLine];
if Pos("I",UpperCase(Modif))<>0 then Canvas.Font.Style:=Canvas.Font.Style+[fsItalic];
if Pos("S",UpperCase(Modif))<>0 then Canvas.Font.Name:="Symbol";
if Pos("Z",UpperCase(Modif))<>0 then Canvas.Font.Size:=7;
if Pos("X",UpperCase(Modif))<>0 then begin Canvas.Font.Size:=7; Tops:=6;end;
end;

if Modif[1]="$"
then begin
if Pos("B",UpperCase(Modif))<>0 then Canvas.Font.Style:=Canvas.Font.Style-[fsBold];
if Pos("U",UpperCase(Modif))<>0 then Canvas.Font.Style:=Canvas.Font.Style-[fsUnderLine];
if Pos("I",UpperCase(Modif))<>0 then Canvas.Font.Style:=Canvas.Font.Style-[fsItalic];
if Pos("S",UpperCase(Modif))<>0 then Canvas.Font.Name:="Arial Cyr";
if Pos("Z",UpperCase(Modif))<>0 then Canvas.Font.Size:=10;
if Pos("X",UpperCase(Modif))<>0 then begin Canvas.Font.Size:=10; Tops:=0;end;
end;
if Pos2<>0 then Delete(Text,1,Pos2);
until (pos1=0) or (pos2=0);
end;

Этот код пишет текст в ячейку стринггрида (Если ячеек много-все работает медленно :()
Параметр функции
aaa[#bu]далее тескт жирный и подчеркнутый[$b]подчеркнутый [#S]подчеркнутый и шрифтомSymbol[$SU]Arial


 
Tosov   (2002-01-02 23:39) [1]

Z-верхний индекс X -нижний
#чего-нибудь - включение $-выключение


 
skaminski~~~~   (2002-01-02 23:57) [2]

Для начала попробуй не делать десяток раз UpperCase одной переменной. Просто сделай один раз и результат сохрани, а с ним потом сравнивай.


 
Tosov   (2002-01-03 00:33) [3]

OK. вместо
Modif:=Copy(Text,Pos1+1,Pos2-Pos1-1);
теперь
Modif:=UpperCase(Copy(Text,Pos1+1,Pos2-Pos1-1));
и UpperCase нет. Может еще что нибудь изменить ?



 
skaminski~~~   (2002-01-03 00:43) [4]

уже хорошо было бы UpperCase(Modif) сохранить сначала. Неплохо было бы обращения к канве сделать как
With Canvas do
begin
// и тут без Canvas.
end;

организуй цикл на основе If -- Else, зачем провереять на "X", если уже точно знаешь, что "Z" (тут я, возможно, не разобрался - но очень плохая постановка задачи)



 
Tosov   (2002-01-03 01:24) [5]

Задача : передаю a[#bu]bbb[$b]ccc[#i]dd[$u]eee[$i]fff
В ячейке TStringGrid получаю
a bbb ccc dd eeefff

Как я это сделал :
-нахожу текст (bbb) и СЛЕДУЮЩУЮ КОМАНДУ (Modif="$b")
-выводу текст bbb со старыми настройками
-Разбираю Modif : Если Modif[1]-# значит вкл. функцию (жирн.текст например) и ищу каждый символ (B,U,I,...) в остатке строки. Если нахожу - устанавливаю новое значение Canvas
-Удаляю то, что уже выведено и goto начало.
до тех пор, пока в строке есть [ and ]

А With Canvas .. -дает какой нибудь выигрыш в скорости ??

Заменил:
if Pos("Z",UpperCase(Modif))<>0 then Canvas.Font.Size:=7
else if Pos("X",UpperCase(Modif))<>0 then begin Canvas.Font.Size:=7; Tops:=6;end;

Может как-то это сделать по другому, без Delete и Copy ?


 
Alx2   (2002-01-03 09:17) [6]

Мой вариант:

Procedure WriteText(ARect: TRect; Text: ShortString);
Var
Widths, K : Integer;
pos1, pos2: Integer;
subtext : String;
Modif : String;
Tops : Integer;
fStyles : TFontStyles;
Begin
Tops := 0;
Widths := 2;
fStyles := Canvas.Font.Style;
Repeat
pos1 := Pos("[", Text);
pos2 := Pos("]", Text);

If pos1 = 0 Then pos1 := Length(Text) + 1;
subtext := Copy(Text, 1, pos1 - 1);
Canvas.TextOut(ARect.Left + Widths, ARect.Top + 2 + Tops, subtext);
Widths := Widths + Canvas.TextWidth(subtext) + 2;
Modif := Copy(Text, pos1 + 1, pos2 - pos1 - 1);
If Length(Modif) = 0 Then Modif := " ";
Modif := UpperCase(Modif);
Case Modif[1] Of
"#":
Begin
For K := 2 To Length(Modif) Do
Case Modif[K] Of
"B": fStyles := fStyles + [fsBold];
"U": fStyles := fStyles + [fsUnderline];
"I": fStyles := fStyles + [fsItalic];
"S": Canvas.Font.Name := "Symbol";
"Z": Canvas.Font.Size := 7;
"X":
Begin
Canvas.Font.Size := 7;
Tops := 6;
End;
End;
Canvas.Font.Style := fStyles;
End;

"$":
Begin
For K := 2 To Length(Modif) Do
Case Modif[K] Of
"B": fStyles := fStyles - [fsBold];
"U": fStyles := fStyles - [fsUnderline];
"I": fStyles := fStyles - [fsItalic];
"S": Canvas.Font.Name := "Arial Cyr";
"Z": Canvas.Font.Size := 10;
"X":
Begin
Canvas.Font.Size := 10;
Tops := 0;
End;
End;
Canvas.Font.Style := fStyles;
End;
End;
If pos2 <> 0 Then Delete(Text, 1, pos2);
Until (pos1 = 0) Or (pos2 = 0);
End;



 
Alx2   (2002-01-03 10:51) [7]

То, что выше - по мотивам вопроса.
Теперь - почти полностью переделанный вариант. Скорость на порядок выше:

Procedure WriteText(ARect: TRect; Const Text: String);
Var
len : Integer;
fStyles : TFontStyles;
Tops, Widths: Integer;
OutRect : TRect;
Procedure GetSubText(Var K: Integer);
Var S: String;
Start : Integer;
Begin
Start := k;
While (K <= len) And (Text[K] <> "[") Do inc(K);
S := Copy(Text, Start, K - Start);
OutRect := Rect(ARect.Left+ Widths,Arect.Top+ 2 + Tops,ARect.Right,ARect.Bottom);
Canvas.TextRect(OutRect,OutRect.Left,OutRect.Top,S);
// Canvas.TextOut(ARect.Left + Widths, ARect.Top + 2 + Tops, S);
Widths := Widths + Canvas.TextWidth(S) + 2;
if Widths>ARect.Right-ARect.Left then
k := Len+1;
End;
Procedure SetAttrib(Var K: Integer);
Begin
If (K < len) And (Text[K] = "[") Then
Begin
inc(K);
If Text[K] In ["#", "$"] Then
Begin
If Text[K] = "#" Then
Begin
inc(K);
While (K <= len) And (Text[K] <> "]") Do
Begin
Case Text[K] Of
"B","b": fStyles := fStyles + [fsBold];
"U","u": fStyles := fStyles + [fsUnderline];
"I","i": fStyles := fStyles + [fsItalic];
"S","s": Canvas.Font.Name := "Symbol";
"Z","z": Canvas.Font.Size := 7;
"X","x":
Begin
Canvas.Font.Size := 7;
Tops := 6;
End;
End;
inc(K);
End;
End
Else
Begin
inc(K);
While (K <= len) And (Text[K] <> "]") Do
Begin
Case Text[K] Of
"B","b": fStyles := fStyles - [fsBold];
"U","u": fStyles := fStyles - [fsUnderline];
"I","i": fStyles := fStyles - [fsItalic];
"S","s": Canvas.Font.Name := "Arial Cyr";
"Z","z": Canvas.Font.Size := 10;
"X","x":
Begin
Canvas.Font.Size := 10;
Tops := 0;
End;
End;
inc(K);
End;
End;
Canvas.Font.Style := fStyles;
End;
inc(K);
End;
End;

Var
K: Integer;

Begin
len := Length(Text);
Tops := 0;
Widths := 2;
fStyles := Canvas.Font.Style;

K := 1;
While K <= Len Do
Begin
GetSubText(K);
SetAttrib(K);
End;
End;



 
Alx2   (2002-01-03 11:21) [8]

Небольшая ремарка:
В приведенном выше варианте есть неточность: не учитывается стили, заданные в конце форматной строки. Чтобы работало корректно нужно исправить так:

Procedure GetSubText(Var K: Integer);
Var S: String;
Start : Integer;
Begin
Start := k;
While (K <= len) And (Text[K] <> "[") Do inc(K);
if not StopDrawing then
begin
S := Copy(Text, Start, K - Start);
OutRect := Rect(ARect.Left+ Widths,Arect.Top+ 2 + Tops,ARect.Right,ARect.Bottom);
Canvas.TextRect(OutRect,OutRect.Left,OutRect.Top,S);
Widths := Widths + Canvas.TextWidth(S) + 2;
StopDrawing := Widths>ARect.Right-ARect.Left;
end;
End;


Переменную StopDrawing делаем False в начале тела WriteText.

После некоторого анализа выяснились причины тормозов:
1. Ф-я Canvas.TextOut - медленная. Посему будет лучше, если она будет выводить только самое необходимое. Некоторый шаг к этому я сделал (use TextRect). Результат - значительное повышение скорости.
2. Копирование из одних строк в другие - довольно медленно.
Улучшаем с помощью посимвольного прохода по строке Text (видно из примера, хотя полностью копирования избегать не пришлось).

3. Присвоение Canvas.Font.Name, Canvas.Font.Size, Canvas.Font.Style etc - медленно. Нужно постараться это делать когда действительно необходимо. Для дальнейшего ускорения (этого я не делал, так как мне хватило и этого :))) можно использовать фиктивные переменные, например, FontName : String; FontSize : Integer, FontStyle : TFontStyles значения которых передавать шрифту если StopDrawing = false или, для корректной работы, передавать в конце тела процедуры WriteText в случае, если StopDrawing=true.


Но, все-таки, основной подход: - пишите на Canvas только то, что действительно будет видимым.


 
Tosov   (2002-01-03 23:37) [9]

Alx2
Спасибо. Выиргыш в скорости действительно есть..не на порядок, но вместо 3 минут тест работает чуть более 2 (а разница не малая)


 
Alx2   (2002-01-04 07:40) [10]

Странно...
У меня разница очень существенная (если использовать последний описанный мною вариант).
Шли свой код на мыло. Есть подозрение, что что-то у тебя не так :))



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

Форум: "Основная";
Текущий архив: 2002.01.21;
Скачать: [xml.tar.bz2];

Наверх





Память: 0.6 MB
Время: 0.02 c
1-66247
DJ X
2002-01-02 16:14
2002.01.21
PLEASE! - иконка DLL


14-66338
Христос
2001-11-24 14:42
2002.01.21
WinApi


4-66402
ДедушкаКо
2001-11-19 14:45
2002.01.21
Из осн. удалили...не понял почему. Попробую здесь...


4-66401
qwertysdffsfsdfa
2001-11-22 01:19
2002.01.21
Как читать буфер клавиатуры?


4-66400
Olgerd
2001-11-21 20:36
2002.01.21
Не совсем понятно





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
Английский Французский Немецкий Итальянский Португальский Русский Испанский