Задумался о применении векторных изображений в стилях контролов. На примере TButton, т.е. создать векторный "стилевой" класс по аналогичный с растровым TButtonStyleObject,
где для 4-х визуальных представлений будет использовать не TBitmapLinks, а TPath.
Минусы:
Не будет 9parts, а значит только фиксированное соотношение сторон;
Не родное решение (ниже Сомнение№2);
Плюсы:
Самый очевидный - один стиль с 4-мя картинками, вместо в много раз(10+) больше картинок под разные scale/разрешений экрана/размеров....(в зависимости от выбронного способа избавления от "мыла" для работы приложения на любых экранах и мониторах с любым разрешением и scale);
Меньшая ресурсоёмкость. Будет шустрее работать (как минимум НЕ медленне), что не критично для Windows, но актуально для большей части комьюнити данного форума, разработчиков под мобильные платформы. Только за счет отказа от 9parts, быстродействие отрисовки вырастет. См. реализацию TCustomStyleObject.DoDrawToCanvas -9 частей отрисовываются всегда(9 вызовов Canvas.DrawBitmap(...)), даже если они фактически не используются. Я, к примеру, 9parts использую только у стиля листбокса, который "внутри" комбобокса. В остальных случаях, дефакто - 1 область + 8 областей нулевой площади. При желении, даже у листбокса можно отказаться от 9parts. Время загрузки Стиля- (+/-)10% по сравнению к растровому решению.
Сомнения:
Поизучав FMX.Styles.Objects.pas "легкой" реализации, что бы, что-нибудь наследовать и пару строк дописать, я не нашёл. Для меня понятное решение, это полностью скопировать(взять за основу "векторных" стиливых классов) TCustomStyleObject и TButtonStyleObject и править... Это 1500+ строк кода. Зная свой темп работы, я для себя переписывание и отладку оцениваю в 2-е недели работы.
А потом выйдет 10.4.3 или если сильно повезет, то переставать работать "векторный" класс будет лишь на каждом втором релизе и... goto п.1
ПРЕДЛАГАЮ ОБСУДИТЬ + И - ТАКОГО РЕШЕНИЯ, РЕАЛИЗАЦИЮ, ЦЕЛЕСООБРАЗНОСТЬ, АЛЬТЕРНАТИВЫ.
Добрый день!
Заметил неприятный эффект(баг, особенность либо моё недопонимание чего либо). Через некоторое непродолжительно время работы PopItem( в версии возвращающей TWaitResult) перестаёт ожидать данные из очереди, и перестаёт "усыплять" на(до) TThreadedQueue.FPopTimeout мсек, поток из которого была вызвана, а возвращает wrTimeout без ожидания(менее 100 тактов). Ниже тестовый код, который демонстрирует этот эффект.
Описание теста: основной поток, создаёт поток с условным названием FirstDepthThread, который:
-запускает MaxThread(константа)+1 потоков( по умолчанию их 10) с условными названиями SecondDepthThread_X ;
- c интервалом в 2-5 секунды в каждую из очередей записывается константный идентификатор. Кол-во очередей =MaxThread+1(в каждом из потоков SecondDepthThread_X есть поле с очередью) .
Функционал потоков SecondDepthThread_X - ждать данных извлекать их из очереди.
В Procedure TSecondDepthThread.Execute есть 2-а условия( помечены в тексте, как {жучок 1} и {жучок 2}), которые в моём понимании никогда не должны выполняться, но...выполняются. Понимание, как обойти этот эффект есть, но очень хочется разобраться, что не так с указанной реализацией? Буду рад мнениям.
Условия тестирования: Delphi 10.3.1., W10.1903. Так же рекомендуется попробовать разные значения MaxThread( при MaxThread=2, эффект может и не наступить,при MaxThread= 9, на 3-х разные cpu Intel эффект наступает через ,5-5 секунд, на стареньком AMD FX-8300 лишь через 2-10 минут. при MaxThread=14, AMDешный cpu так же "сдаётся" за несколько секунд). В отладчике смотрим окно Events. Если без отладчика, то в виндовом диспетчере задач, как только загрузка процессора у данного процесс подскочила от 0 к 100%, значит эффект достигнут.
unit UThreadedQueue;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs,System.Generics.Collections;
Const MaxThread=9;
type
TSecondDepthThread=class(TThread)
Protected
FThreadNomber:integer;
FError:boolean;
Procedure Execute;override;
Public
TickSending:Cardinal;
TickInterval:Cardinal;
SendingDataQuery:TThreadedQueue<TBytes>;
constructor Create(AThreadCount:integer);
Destructor Destroy;override;
Property ThreadNomber:integer read FThreadNomber;
end;
TFirstDepthThread=class(TThread)
Protected
FSecondDepthThreads:array[0..MaxThread] of TSecondDepthThread;
Procedure Execute;override;
Public
SendingDataQuery:TThreadedQueue<TBytes>;
constructor Create;
Destructor Destroy;override;
end;
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FFirstDepthThread:TFirstDepthThread;
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses SyncObjs,TypInfo;
{$R *.dfm}
Constructor TSecondDepthThread.Create(AThreadCount: Integer);
begin
FError:=false;
TickInterval:=2000+random(3000);
FThreadNomber:=AThreadCount;
SendingDataQuery:=TThreadedQueue<TBytes>.Create(100, 1, 1); //инициализация очереди
FreeOnTerminate := false;
Inherited Create(false);
end;
Destructor TSecondDepthThread.Destroy;
begin
FreeAndNil(SendingDataQuery);
inherited;
end;
Procedure TSecondDepthThread.Execute;
var iCounterPerSec,TimeStart, TimeFinish: TLargeInteger;
QSize:integer;
WaitResult:TWaitResult;
ReceivedData:TBytes;
ElapsedTime:double;
begin
NameThreadForDebugging('SecondDepthThread_'+inttostr(FThreadNomber));
while (not Terminated)do
begin
QueryPerformanceFrequency(iCounterPerSec);
QueryPerformanceCounter(TimeStart);
WaitResult:=SendingDataQuery.PopItem(QSize,ReceivedData);
QueryPerformanceCounter(TimeFinish);
ElapsedTime:= (TimeFinish - TimeStart)/iCounterPerSec;
if (ElapsedTime<0.000082)and(WaitResult=TWaitResult.wrTimeout)and(not FError) then
begin {жучок 1}
OutputDebugString(pchar('Поток№ '+inttostr(FThreadNomber)+ ' Всё.., началось! Ответ(состояние) очереди='+
GetEnumName(TypeInfo(TWaitResult), Ord(WaitResult))+' выполнение за '+
FormatFloat('0.000000', ElapsedTime) + ' сек., а должно быть более 0.001 сек'));
FError:=true; // дальше сообщения с wrTimeout не выводим, т.к. их слишком много
end;
if (WaitResult=TWaitResult.wrSignaled)and(length(ReceivedData)>0) then
begin
if ReceivedData[0]=100+FThreadNomber then
{OutputDebugString(pchar('Поток№ '+inttostr(FThreadNomber)+ ' ,есть корректные данные'))};
if ReceivedData[0]<>100+FThreadNomber then {жучок 2}
OutputDebugString(pchar('Поток№ '+inttostr(FThreadNomber)+ 'некорректные данные, должно прийти'+
inttostr(100+FThreadNomber)+' ,а пришло '+inttostr(ReceivedData[0])));
if ReceivedData[0]=0 then {подвид 2-го жука}
OutputDebugString(pchar('Поток№ '+inttostr(FThreadNomber)+ ' Такого быть не должно! Ответ(состояние) очереди='+
GetEnumName(TypeInfo(TWaitResult), Ord(WaitResult))+
' сигнал о наличии данных есть, а данных нет,'+
' выполнение за '+FormatFloat('0.000000', ElapsedTime) ));
ReceivedData[0]:=0; // для контроля извлекаемых из очереди данных.
end
end;
end;
Constructor TFirstDepthThread.Create;
Var Count:integer;
begin
for count := 0 to MaxThread do FSecondDepthThreads[Count]:=TSecondDepthThread.Create(Count);
FreeOnTerminate := false;
Inherited Create(false);
end;
Destructor TFirstDepthThread.Destroy;
Var Count:integer;
begin
for Count := 0 to MaxThread do
begin
FSecondDepthThreads[Count].Terminate;
FSecondDepthThreads[Count].WaitFor;
FSecondDepthThreads[Count].Free;
end;
inherited;
end;
Procedure TFirstDepthThread.Execute;
var Count:integer;
SendingData:Tbytes;
begin
NameThreadForDebugging('FirstDepthThread');
Setlength(SendingData,1);
while not terminated do
begin
for Count := 0 to MaxThread do with FSecondDepthThreads[Count] do
if GetTickCount-TickSending>TickInterval then
begin
SendingData[0]:=100+ThreadNomber;
SendingDataQuery.PushItem(SendingData);
TickSending:=GetTickCount;
end;
sleep(1);
//yield;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FFirstDepthThread:=TFirstDepthThread.Create;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FFirstDepthThread.Terminate;
FFirstDepthThread.WaitFor;
FFirstDepthThread.Free;
end;
end.