Форум: "Основная";
Текущий архив: 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.49 MB
Время: 0.003 c