Оптимизация процедуры

← →
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]

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

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