ddr 2
-
Постов
18 -
Зарегистрирован
-
Посещение
-
Победитель дней
2
Сообщения, опубликованные ddr 2
-
-
Задумался о применении векторных изображений в стилях контролов. На примере 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
ПРЕДЛАГАЮ ОБСУДИТЬ + И - ТАКОГО РЕШЕНИЯ, РЕАЛИЗАЦИЮ, ЦЕЛЕСООБРАЗНОСТЬ, АЛЬТЕРНАТИВЫ.
-
14 часов назад, slav_z сказал:
RegisterFmxClasses...
То, что нужно! Благодарю.
-
Пытаюсь реализовать CheckBox с дополнительными визуальными представлениями, которые можно задавать в редакторе стилей.
Реализация: компонент созданный наследованием от TCheckBox и элемент стиля через наследование TCheckStyleObject.
Пока написал класс поражденный от TCheckStyleObject (код ниже). Тестирую поместив на форму компонент TCheckBox и указываю ему в StyleLookup, стиль создванный с испозольванием класса поражденного от TCheckStyleObject, компонент успешно применяет Стиль, что я визуально наблюдаю. Т.е. в дизайнере все состовляющие стиля видны(зарегистрированы) и доступны. Но при запуске приложения ошибка: First chance exception at $77079962. Exception class EClassNotFound with message 'Class TCheckDUStyleObject not found'. Process TestCheckBox.exe (20216). Ошибка при загрузке StyleBooka.
В чем может быть проблема?
Подозреваю, что проблема окажеться из разряда базовых "детских", поэтому описываю более подробно свои дейсвия. Возможно проблема в одном из этий действий.
По тестирование. На форму кидаю TCheckBox . На нем "Edit Custom Style...". В редакторе стилей появившемся стиле удаляю background(TCheckStyleObject)
и заменяю его своим background(TCheckDUStyleObject) перетаскиванием из палитры и меняю часть свойств в т.ч. SourceLink и другие *Link, что бы в дальнейшем увидеть нужные визуальное предстваление. Закрываю редактор стилей. Меняю StyleLookup чекбокса на "CheckBoxNew". И его визуальное представление меняется, т.е. стиль УСПЕШНО применен.
Про TCheckDUStyleObject.
Файл UCheckDUStyleObject содержащий класс, добавлен в пакет. Пакет собирается, компилируется инсталируется. Пути(Library Path) к нему пропысаны. Класс в палитре отображается.
unit UCheckDUStyleObject; interface uses FMX.Styles.Objects,System.Classes,FMX.Ani,FMX.Types; type TCheckDUStyleObject=class(TCheckStyleObject) protected type TLinkEx = (Pressed,ActivePressed,WaitingResponse,ActiveWaitingResponse,Disabled,ActiveDisabled); {$SCOPEDENUMS ON} TStateEx = (Active,Pressed, WaitingResponse, Disabled); {$SCOPEDENUMS OFF} TTransitionRec = record Animation: TAnimation; Event: TNotifyEvent; end; private protected FBitmapLinksEx: array [TLinkEx] of TBitmapLinks; FTransitionsEx: array [TStateEx] of TTransitionRec; FStateEx: set of TStateEx; procedure DefineProperties(Filer: TFiler); override; procedure SetupAnimations; override; function GetCurrentLink: TBitmapLinks; override; function GetLinkEx(Index: TLinkEx): TBitmapLinks; procedure SetLinkEx(Index: TLinkEx; const Value: TBitmapLinks); procedure ActiveTriggeredEx(Sender: TObject); procedure PressedTriggered(Sender: TObject); procedure WaitingResponseTriggered(Sender: TObject); procedure DisabledTriggered(Sender: TObject); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure StartTriggerAnimation(const AInstance: TFmxObject; const ATrigger: string); override; published property PressedLink: TBitmapLinks index TLinkEx.Pressed read GetLinkEx write SetLinkEx; property ActivePressedLink: TBitmapLinks index TLinkEx.ActivePressed read GetLinkEx write SetLinkEx; property WaitingResponseLink: TBitmapLinks index TLinkEx.WaitingResponse read GetLinkEx write SetLinkEx; property ActiveWaitingResponseLink: TBitmapLinks index TLinkEx.ActiveWaitingResponse read GetLinkEx write SetLinkEx; property DisabledLink: TBitmapLinks index TLinkEx.Disabled read GetLinkEx write SetLinkEx; property ActiveDisabledLink: TBitmapLinks index TLinkEx.ActiveDisabled read GetLinkEx write SetLinkEx; end; procedure Register; implementation procedure Register; begin RegisterComponents('Мои компоненты', [TCheckDUStyleObject]); end; // и т.д. Далее реализация TCheckDUStyleObject -
В 11.08.2020 в 16:56, ddr 2 сказал:
Вопрос 5. В моей задаче кпопка "безфокусная". Соответсвенно и статус Focused в основном Стиле не используется. Возможно ли Disabled реализовать через подмену Focused<->Normal в основном используемом Стиле?
Ответ: Кнопка в режиме Disabled(Enabled=false) отображается в стиле Focused
//добавляем protected FIsFocused:Boolean; procedure ApplyStyleLookup; override; published property IsFocused read FIsFocused write FIsFocused; end; procedure TButtonWithShadow.ApplyStyleLookup; Begin inherited; EnabledChanged; End; //изменяем на procedure TButtonWithShadow.EnabledChanged; Begin IsFocused:= not Enabled; StartTriggerAnimation(Self, 'Focused'); EndЦитатаВопрос 4. Текущая реализация запоминания(FFStyledEnabled:=StyleLookup;) основного стиля кнопки(для обратной подмены) в procedure TButtonWithShadow.EnabledChanged; при каждом изменении значения с ИСТИНЫ на ЛОЖЬ свойства Enabled, совсем не изящное. Однократное сохранения значения свойств я ранее делал, в AfterConstruction, но с StyleLookup такой подход не работает.
Ответ: Однократное сохранения куда либо значения StyleLookup в процессе создания экземпляра (инициализации) компонента можно сделать в перекрываемом методе Loaded , в котором значение в StyleLookup уже загружено из ресурсов.
ЦитатаВопрос 3. Опытным путем(и немного чтением этого форума) выяснил, что для того, что бы Стили отображались в StyleLookup необходимо, что бы стили имели имя по маске "ButtonWithShadow*".Возможно ли влиять(изменить) на маску?
Ответ: Применяется маска"*ClassName*", вполне адекватна и не требует изменений.
-
По вопрос1 решение найдено. В конструкторе, после создание Тени нужно добавить
FShadow.Stored:=false;Остальные вопросы остаются актуальными.
-
Добрый день!
Требуется кнопка с стилизованым Disabled. Пошел по пути подмены Стиля. И раз уж все равно решается это только через наследование TButton, то хочется сразу интегрировать в компонент ТЕНЬ. Сделал. Код ниже. Работает, но есть вопросы и моя реализация с тенью явно требует изменений.
Вопрос 1(ОСНОВНОЙ).
При каждом открытии проекта, к каждой кнопке TButtonWithShadow добавляется новая(ещё одна) тень(см. картинку). Как от этого избаваться?
Вопрос 2. Выбор подменяемого Стиля я реализовал через published property StyledDisabled:String read FStyledDisabled write FStyledDisabled; При этом в Дизайнере данное свойство - строка. Как сделать не строку, а выпадающий список по аналогии с StyleLookup?
Вопрос 3. Опытным путем(и немного чтением этого форума) выяснил, что для того, что бы Стили отображались в StyleLookup необходимо, что бы стили имели имя по маске "ButtonWithShadow*".Возможно ли влиять(изменить) на маску?
Вопрос 4. Текущая реализация запоминания(FFStyledEnabled:=StyleLookup;) основного стиля кнопки(для обратной подмены) в procedure TButtonWithShadow.EnabledChanged; при каждом изменении значения с ИСТИНЫ на ЛОЖЬ свойства Enabled, совсем не изящное. Однократное сохранения значения свойств я ранее делал, в AfterConstruction, но с StyleLookup такой подход не работает.
Вопрос 5. В моей задаче кпопка "безфокусная". Соответсвенно и статус Focused в основном Стиле не используется. Возможно ли Disabled реализовать через подмену Focused<->Normal в основном используемом Стиле?
unit UButtonWithShadow; interface uses FMX.StdCtrls,System.Classes,FMX.Effects,System.UITypes,FMX.Types; type TButtonWithShadow = class(TButton) private protected FShadow:TShadowEffect; FStyledDisabled:String; FFStyledEnabled:String; procedure EnabledChanged; override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure AfterConstruction; override; published property StyledDisabled:String read FStyledDisabled write FStyledDisabled; end; procedure Register; implementation procedure Register; begin RegisterComponents('Мои компоненты', [TButtonWithShadow]); end; constructor TButtonWithShadow.Create(AOwner: TComponent); Begin inherited; DisabledOpacity := 1; //отключаем прозрачность для enabled=false TextSettings.Font.Family:='Roboto'; TextSettings.Font.Size:=36.0; TextSettings.Font.Style:=[TFontStyle.fsBold]; StyledSettings:=[TStyledSetting.Style,TStyledSetting.FontColor]; FShadow:= TShadowEffect.Create(self{nil}); FShadow.Direction:=45; FShadow.Distance:=5; FShadow.Softness:=0.2; FShadow.ShadowColor:=TAlphaColorRec.Dimgray; FShadow.Trigger:='IsPressed=false'; FShadow.Parent := Self; //AddObject(FShadow); End; destructor TButtonWithShadow.Destroy; Begin //RemoveObject(FShadow); FShadow.Free; inherited; End; procedure TButtonWithShadow.AfterConstruction; Begin // NeedStyleLookup; // ApplyStyleLookup; FFStyledEnabled:=StyleLookup; //Пустая строка. inherited; End; procedure TButtonWithShadow.EnabledChanged; Begin if Enabled then StyleLookup:=FFStyledEnabled else if FMX.Types.FindStyleResource(FStyledDisabled)<>nil then Begin FFStyledEnabled:=StyleLookup; StyleLookup:=FStyledDisabled; End; End; end. -
В 21.07.2020 в 18:33, dnekrasov сказал:
А вообще - посмотрите исходники TCircle-TEllipse-TShape - всё станет намного понятнее.
Спасибо. Ясности действительно прибавило.
Ещё мне вот эти исходники помогли разбираться http://fire-monkey.ru/topic/1902-семисегментный-индикатор/ ,как создавать визуальные компоненты на примитивах.
По моим базовым непониманиям, по которыхзадавал вопросы:
- очищать канву в Paint не нужно, она и так очищена;
- при рисовании примитовов на канве нужно следить, что бы ничего не "нарисовать" вне размеров элемента, иначе будет, как я писал выше.
В 21.07.2020 в 18:33, dnekrasov сказал:В 21.07.2020 в 17:02, ddr 2 сказал:3. Как задать размеры элемента по умолчанию?
переопределите функцию GetDefaultSize: TSizeF
Что-то такое "размеры по умолчанию", я так и не понял. Я своём вопросе я имел в виду значения Width и Heigth которые отображаются в Object Inspector при добавлении компонента в Design. Получается не корректно задал вопрос. Прошу прощения. А решение, которое я нашел, что инициализация указанных свойств в конструкторе.
-
Здравствуйте.
Разработал свой первый визуальный компонент – Индикатор из 4-х состояний
. Разобраться слету во всех иерархиях имеющихся классов тяжко. Что «наинтернетил», так и сделал. Есть вопросы. И в целом любая критика приветствуется.
1. Разумно ли выбран TImage в качестве предка?
2. Основной вопрос. В TLEDIndicator.Paint, с помощью
Canvas.DrawEllipse(TRectF.Create(1, 1,width-2,width-2), 1);отприсовывается внешний контур Индикатора. Применен отступ от краёв в 1 пиксель. И это вынужденная мера. Если сделать без отступа TRectF.Create(0, 0,Width-1,Width-1), то при изменении статуса индикатора подразумевающие изменения цвета внешнего контура, остаются частично «следы» старого цвета контура.
Если окно свернуть/развернуть, то «следы» пропадают. Делаю вывод, что все корректно, и это скорее всего результат используемого в DrawEllipse «сглаживания». Логично попробовать решить это через очистку канвы. В качестве эксперимента в Paint добавляю
Canvas.Clear(TAlphaColorRec.Green);В результате зеленеет(очищается) вся форма!?!?!? Смотрю размер канвы. 640x480. Тоже вопросы.. откуда??? Пытаюсь изменить размер канвы
Canvas.SetSize(trunc(Width),trunc(Height));Результат- ошибки, зависание, аварийное завершение.
Меня вполне устраивает решение с отступом в 1 пиксель, но хочу разобраться с полученным, я явно делаю, что-то не правильно.
3. Как задать размеры элемента по умолчанию?
unit ULEDIndicator; interface uses System.SysUtils, System.Classes, FMX.Types, FMX.Controls, FMX.Objects,FMX.Graphics,System.Types,System.UITypes; type TLEDStatus=(Red,Green,Null); TLEDIndicator = class(TImage) {вопрос 1} private FStatus: TLEDStatus; procedure SetLEDStatus(Value:TLEDStatus); Function GetInColor:TColor; inline; Function GetOutColor:TColor; inline; protected procedure Paint; override; public constructor Create(AOwner: TComponent); override; published property Status:TLEDStatus read Fstatus write SetLEDStatus stored true default TLEDStatus.Green; end; procedure Register; implementation procedure Register; begin RegisterComponents('Samples', [TLEDIndicator]); end; constructor TLEDIndicator.Create(AOwner: TComponent); Begin inherited; FStatus:=TLEDStatus.Green; End; procedure TLEDIndicator.Paint; var IWidth:integer; begin inherited; {вопрос 2} IWidth:=Canvas.Width; // Canvas.Clear(TAlphaColorRec.Green); Canvas.Stroke.Color:=GetIncolor; Canvas.Fill.Color:=GetOutColor; Canvas.Stroke.Thickness:=1; Canvas.Stroke.Dash:= TStrokeDash.Solid; Canvas.Stroke.Kind:= TBrushKind.Solid; Canvas.DrawEllipse(TRectF.Create(1, 1,width-2,width-2), 1);{вопрос 2} Canvas.FillEllipse(TRectF.Create(3, 3,width-4,width-4), 1); end; procedure TLEDIndicator.SetLEDStatus(Value:TLEDStatus); Begin Fstatus:=Value; Repaint; End; Function TLEDIndicator.GetInColor:TColor; Begin if Enabled then Result:= TAlphaColorF.Create(42 / 255, 42 / 255, 42 / 255, 1).ToAlphaColor else Result:=TAlphaColorF.Create($E5/ 255, $E5 / 255, $E5/ 255, 1).ToAlphaColor; End; Function TLEDIndicator.GetOutColor:TColor; Begin if Enabled then case FStatus of Red:Result:= TAlphaColorRec.Red; Green:Result:= TAlphaColorRec.Green; Null:Result:=TAlphaColorF.Create($E5/ 255, $E5 / 255, $E5/ 255, 1).ToAlphaColor; end else Result:=TAlphaColorF.Create($E5/ 255, $E5 / 255, $E5/ 255, 1).ToAlphaColor End; end. -
Форум жив! Это радует. Ответ, через 4 месяца, лучше, чем без ответа вообще (без сарказма). Благодарю за внимание! Я долго разбирался с ранее описанными проблемами. И в некотором роде разобрался. Пусть останется для истории. Ранее я несколько сумбурно описал проблемы при использовании TThreadedQueue, отчасти это связано, что на тот момент я не понимал природу этих проблем. Итак имеем:
-Проблема 1: «замусоривание» данных при использовании TThreadedQueue<T> , где <T>=Tbytes; (и как выяснилось любой динамический массив). Ранее я это называл {жучок 2}
-Проблема 2: TThreadedQueue.PopItem при определенных обстоятельствах перестаёт «ожидать» данные заданное кол-во времени соответственно не «усыпляет» поток в котором он был вызван. Ранее я это называл {жучок 1}
Начну с 2-ой проблемы. Пытаясь разобраться, я пошел по пути написать своей TThreadedQueue. Что и было сделано. Итак, оригинальный TThreadedQueue реализован через TMonitor, который в WIN32\64 реализуется через критическую секцию. Т.к. меня в первую очередь интересует windows платформа, то свой TThreadedQueue я реализовал сразу на критической секции. Далее изучая исходники TThreadedQueue, я выяснил, что PopItem реализован через WINAPIшные WaitForSingleObject(WaitForMultipleObjects) у которых один из параметров dwMilliseconds(время ожидания в мсек, которое передаётся из конструктора TThreadedQueue). И как выяснилось именно эти функции реализуют описанную проблему. В разных версиях Windows и при разном кол-ве ядер CPU функции ведут себя по-разному в плане «ожидания». Далее не буду углубляться… я пришел к выводу, что такой подход имеет смысл. Правильный подход это всегда использовать dwMilliseconds= INFINITE. И за слишком частые вызовы WaitForMultipleObjects с параметром ожидания 1мсек, или 100мсек, Microsoft попросту «наказывает» программиста за неэффективное проектирование кода. Пробовал экспериментировать с задержками, в поиске найти «безопасную» задержку, так вот безопасная это только INFINITE. На 500мсек., при 50 потоках ждать проблему приходиться до 8 минут. При 1 секунде- не дождался, но… скорее всего если оставить программу работать на несколько суток, то эффект был бы получен. Возвращаясь к бесконечной задержке ожидания, в числе прочего меня к ней подтолкнул исходники TThreadedQueue. Если без подробностей, то в нем есть публичный метод DoShutDown, он позволяет «выйти» из бесконечного ожидания PopItem, при этом вызывать его естественно нужно не из потока «читателя». DoShutDown – необходимо использовать ВСЕГДА, при использовании TThreadedQueue. А использование бесконечной задержки – гарантия, что проблема не возникнет. Да проблемы проявляется скорее в «экстремальной» нагрузке, при 1-2 «читателей-писателей» или при низкой активности «писателей» проблема может и не проявиться, но лучше не рисковать. Фактически данная особенность не имеет отношение ни к Delphi ни к реализации TThreadedQueue, это WINAPI и возможно, что на других платформах этого не будет.
Что касается 1-ой проблемы с «замусориванием» данных, то решение есть – никогда не использовать динамические массивы в TThreadedQueue<T>, а значит и в любом многопоточном приложении, а т.е. в любом… Поясню. Ранее написанный пример демонстрирует «замусоривание» данных. Если в примере заменить TBytes на статический массив array[0..2048]of byte – проблема исчезает. Так же, если «обернуть» TBytes в class, то проблемы так же исчезает. Фактически динамические массивы нужно использовать очень осторожно, они не потокобезопасны даже при использовании критических секций. Это очень печальная «особенность» в Delphi. Опять же проявляется только под «экстремальной» нагрузкой.
-
Попробовал TBitmapSurface. Работает стабильно. Спасибо! Ниже аналогичная реализация с TBitmapSurface. Но, увы, эта реализация работает медленнее. Изучив исходники TBitmapSurface, стало понятно почему: а) в TBitmapSurface.SetSize происходит прописывание нулями всего массива данных(спорное решение) б) в TBitmap.Assign(TPersistent), если параметр TBitmap, то происходит лишь копирование ссылки, а если TBitmapSurface, то копирование всего битмапа. В своей реализации пошел другим путем, но изучение исходников TBitmapSurface в этом сильно помогло. Ещё раз спасибо.
По поводу «потокобезопастности» TBitmap в RIO, однозначно нет в Win32-64, и мой пример тому доказательство, но судя по коду, есть ощущение, что с ARC в Android и прочих, все будет работать «безопасно», но это только догадка, без фактической проверки.
function GetFMXBitmapSurface: TBitmapSurface ; var Count_X,Count_Y:NativeInt; CurrentColor:TAlphaColor; begin Result := TBitmapSurface.Create; Result.SetSize(640,512); for Count_X := 0 to Result.width-1 do for Count_Y := 0 to Result.height-1 do begin TAlphaColorRec(CurrentColor).R:=Random(255); TAlphaColorRec(CurrentColor).G:=Random(255); TAlphaColorRec(CurrentColor).B:=Random(255); TAlphaColorRec(CurrentColor).A:=$FF; Result.Pixels[Count_X,Count_Y]:=CurrentColor; end; end; -
Требуется на форме отображать картинку TImage(кадр) обновляя её с высокой частотой. Обновляемая картинка динамически формируется попиксельно. Попиксельный доступ реализован через TBitmapData. Формирование кадра достаточно ресурсоёмко. Есть желание вынести формирование кадра в отдельный поток. Но опытным путем я выяснил, что TBitmapData нельзя использовать вне основного потока. Ниже тестовая демонстрационная реализация. Формирование кадра вынесено в функцию GetFMXBitmap. Если bmp := GetFMXBitmap; вызывается через Synchronize, то код на 100% потокобезопасен, если же вызов идет без Synchronize, то приложение валиться, достаточно лишь мышкой энергично изменять размеры окна(формы). Вопрос: TBitmapData полученный через TBitMap.Map действительно можно использовать только из основного потока, или я допустил какую-то ошибку? Если только основной поток, то как бы поизящней обойти это ограничение?
unit Unit1; interface uses System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Objects; type TTestThread=class(TThread) Private Protected Procedure execute;override; Public constructor create(); end; TForm1 = class(TForm) Image1: TImage; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); private { Private declarations } public { Public declarations } TestTthread: TTestThread; end; var Form1: TForm1; implementation {$R *.fmx} function GetFMXBitmap: FMX.Graphics.TBitmap; var bitdata: TBitmapData; Count:Cardinal; begin Result := FMX.Graphics.TBitmap.Create; Result.SetSize(640,512); if (Result.Map(TMapAccess.ReadWrite{Write}, bitdata)) then try // здесь "рисуем" через bitdata for count := 0 to Result.width*Result.height-1 do begin pbyte(bitdata.Data)[4*count]:=Random(255); pbyte(bitdata.Data)[4*count+1]:=Random(255); pbyte(bitdata.Data)[4*count+2]:=Random(255); pbyte(bitdata.Data)[4*count+3]:=$FF; end; finally Result.Unmap(bitdata); end; end; constructor TTestThread.create(); begin FreeOnTerminate := true; inherited Create(false); end; Procedure TTestThread.execute; var bmp: FMX.Graphics.TBitmap; begin while not Terminated do begin {Вариант 1- следующая строчка закоментарена, Вариант 2- следующая строчка НЕ закоментарена } //bmp := GetFMXBitmap; TThread.Synchronize(nil, procedure begin {Вариант 1- следующая строчка НЕ закоментарена, Вариант 2- следующая строчка закоментарена } bmp := GetFMXBitmap; Form1.Image1.Bitmap.Assign(bmp); bmp.Free; end); end; end; procedure TForm1.FormCreate(Sender: TObject); begin Image1.Width:=640; Image1.Height:=512; TestTthread:=TTestThread.create; end; procedure TForm1.FormDestroy(Sender: TObject); begin TestTthread.Terminate; end; end. -
Добрый день!
Заметил неприятный эффект(баг, особенность либо моё недопонимание чего либо). Через некоторое непродолжительно время работы 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.
-
В 06.02.2019 в 00:02, Евгений Корепов сказал:
вместо OnIdle, очередь можно проверять по таймеру
Таймер был моей самой первой реализацией, но он негативно сказывается на отзывчивости интерфейса. В качестве стресс-теста на отзывчивость - в Windows перемещение окна мышкой. Таймер вызывает лаг(и) при перемещении окна. OnIdle, я раньше не пробовал. Попробовал- работает "мягче"- лаг не замечен. Кстати этот стресс-тест создаёт "пропуск" пакетов на экране, но это не критично и решается созданием более длинной очереди(1).
В 06.02.2019 в 08:26, kami сказал:В 05.02.2019 в 21:03, ddr 2 сказал:нужно учитывать и контролировать, что бы поток не завершился раньше, чем все "сообщения" будут обработаны основным потоком?
Это зависит от того, какого эффекта надо добиться.
Извините, я не правильно сформулировал вопрос. Меня заботило, то, что при закрытии формы, в момент, когда мы в FormDestroy завершаем поток TMyThread, у нас в очереди могут
быть(остаться) сообщения/пакеты, которые никогда не будут обработаны, т.е. фактически это потерянные данные. Если в TMyThread.Execute, убрать sleep(random(800)), то данный
эффект наблюдается, как в моём предыдущем варианте с подпиской на сообщения, так и в варианте Евгения. И на решении этой локальной задачи, я признал, вариант Евгения лучшим
из имеющихся, потому, что в его варианте эта задача решается достаточно просто(ниже), а в варианте с подпиской, возможно решение и существует, но я пас.
Вариант решения задачи "потерянных данных"(2), заменяемprocedure TForm1.FormDestroy(Sender: TObject); begin FMyThread.Terminate; FMyThread.WaitFor; FMyThread.Free; FMyQueueIn.Free; FMyQueueOut.Free end;на
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); var TempBoolean:Boolean; begin FMyThread.Terminate; FMyThread.WaitFor; onIdle(Sender,TempBoolean); end; procedure TForm1.FormDestroy(Sender: TObject); begin FMyThread.Free; FMyQueueIn.Free; FMyQueueOut.Free end;Так же для оптимизации, в TForm1.OnIdle заменил условие выполнения цикла(3).
procedure TForm1.OnIdle(Sender: TObject; var Done: Boolean); Var AMyMessage : TMyMessage; S : String; begin while FMyQueueIn.QueueSize>0 do begin AMyMessage:=FMyQueueIn.PopItem; S:='Пакет№ ' + AMyMessage.PackedNumber.ToString + ' X=' + AMyMessage.X.ToString + ' Y=' + AMyMessage.Y.ToString + ' Z=' + AMyMessage.Z.ToString + ' ' + AMyMessage.StringMessage; Memo.BeginUpdate; Memo.Lines.Add(S); Memo.GoToTextEnd; Memo.EndUpdate; end; end;В новом варианте при каждом вызове OnIdle, если в очереди(TThreadedQueue) нет "сообщений"/элементов, то происходит лишь обращение к полю и сравнение, а ранее был вызов метода TThreadedQueue.PopItem в котором выполняется много всего и большая часть в критической секции.
Вместо резюме: Всем спасибо за ответы! Для себя в решении задачи двустороннего обмена сообщениями между формой и потоком, остановился на варианте Евгения с правками (1)(2)(3)
Углубившись в проблематику, пришёл к выводу, что в кроссплатформенном FMX лучше избегать архитектуры двусторонней связи формы с потоком, а пользоваться передачей данный из
формы в запускаемый поток, через конструктор потока, а обратно, через обработчик onTerminate. -
В 04.02.2019 в 17:09, kami сказал:
и удивитесь - в каком потоке он вызывается.
Поставил бряк, посмотрел стек, да Вы правы, вызов идет из потока mythread.
Я хотел реализовать "PostMessage" из потока в главный поток, которого FMX нет. Нашёл подсказку
ЦитатаTThread.Queue заменяет PostMessage, если вызов идет не из главного потока.
Переделал.Все работает и вызов ReciveMessage происходит из главного потока(MainThread). Правильно ли я понимаю, что в подобной реализации "PostMessage"(речь не про данный код,
а про сам подход) нужно учитывать и контролировать, что бы поток не завершился раньше, чем все "сообщения" будут обработаны основным потоком?Буду рад услышать, о других возможных реализация "PostMessage"
unit Unit2; interface uses System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs,System.Messaging, FMX.Controls.Presentation, FMX.ScrollBox, FMX.Memo, FMX.StdCtrls,System.Generics.Collections; type tmythread=class(TThread) public constructor Create; protected PackedNumber:integer; procedure PostMessage; procedure Execute; override; end; TForm2 = class(TForm) Memo1: TMemo; Label1: TLabel; Label2: TLabel; procedure FormCreate(Sender: TObject); private mythread:tmythread; { Private declarations } public procedure ReciveMessage; { Public declarations } end; var Form2: TForm2; qqueue: TThreadedQueue<string>; implementation constructor tmythread.Create; begin PackedNumber:=0; FreeOnTerminate := true; inherited create(false); end; procedure tmythread.Execute; var strmessage:string; begin while (not Terminated) do begin inc(PackedNumber); strmessage:='Пакет№ '+inttostr(PackedNumber)+' значение X='+inttostr(random(1000))+ ' значение Y='+inttostr(random(1000))+' значение Z='+inttostr(random(1000)); qqueue.PushItem(strmessage); Tthread.Queue(nil,PostMessage); sleep(random(800)); end; end; {$R *.fmx} procedure TForm2.ReciveMessage; var stringrecive:string; begin stringrecive:=qqueue.PopItem; label1.Text:=stringrecive; label2.Text:=stringrecive; memo1.Lines.Add(stringrecive);memo1.GoToTextEnd; end; procedure tmythread.PostMessage; begin Form2.ReciveMessage; end; procedure TForm2.FormCreate(Sender: TObject); begin qqueue := TThreadedQueue<string>.Create(5, 1000); memo1.StyledSettings:=[] ; memo1.TextSettings.Font.Size:=8; label1.StyledSettings:=[]; label1.TextSettings.Font.Size:=8; label2.StyledSettings:=[]; label2.TextSettings.Font.Size:=8; mythread:=tmythread.Create; end; end.
-
Не знал про TThreadedQueue. Полезный функционал, спасибо!
Полагаю, что отсылку сообщения из потока в форму можно/нужно делать через TMessageManager. Написал небольшой тест(ниже по тексту- поток посылает сообщения, а форма принимает их и отображает ). Увы, но тест работает не корректно. При запуске под Windows, в процедуре обработке принятого сообщения выскакивает исключение, где-то в районе label1.Text:=stringrecive; . Если в процедуре TForm2._ReciveMessage закоментировать строчки label1.Text:=stringrecive; и label2.Text:=stringrecive ,то оставшиеся добавление строки в memo работает, но явно "не здорово" подмаргивает. При запуске под Android, изменение текста в метках работает, но memo так же дергается и моргает. Применение TThreadedQueue никак не влияет на результат и в тексте закоментировано.
Прошу помощи, в чем ошибка?
unit Unit2; interface uses System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs,System.Messaging, FMX.Controls.Presentation, FMX.ScrollBox, FMX.Memo, FMX.StdCtrls,System.Generics.Collections; type tmythread=class(TThread) public constructor Create; protected packetnomber:integer; procedure Execute; override; end; TForm2 = class(TForm) Memo1: TMemo; Label1: TLabel; Label2: TLabel; procedure FormCreate(Sender: TObject); private mythread:tmythread; procedure _ReciveMessage(const Sender: TObject; const M: TMessage); { Private declarations } public { Public declarations } end; var Form2: TForm2; // qqueue: TThreadedQueue<string>; implementation constructor tmythread.Create; begin packetnomber:=0; FreeOnTerminate := true; inherited create(false); end; procedure tmythread.Execute; var strmessage:string; MessageManager: TMessageManager;_Message: TMessage; begin while (not Terminated) do begin inc(packetnomber); strmessage:='Пакет№ '+inttostr(packetnomber)+' значение X='+inttostr(random(1000))+ ' значение Y='+inttostr(random(1000))+' значение Z='+inttostr(random(1000)); //qqueue.PushItem(strmessage); _Message:=TMessage<String>.Create(strmessage); MessageManager := TMessageManager.DefaultManager; MessageManager.SendMessage(self, _Message, true); sleep(random(800)); end; end; {$R *.fmx} procedure TForm2._ReciveMessage(const Sender: TObject; const M: TMessage); var stringrecive:string; begin stringrecive:=(M as TMessage<String>).Value; //stringrecive:=qqueue.PopItem; label1.Text:=stringrecive; label2.Text:=stringrecive; memo1.Lines.Add(stringrecive);memo1.GoToTextEnd; end; procedure TForm2.FormCreate(Sender: TObject); var SubscriptionId: Integer; MessageManager: TMessageManager; begin // qqueue := TThreadedQueue<string>.Create(5, 1000); memo1.StyledSettings:=[] ; memo1.TextSettings.Font.Size:=8; label1.StyledSettings:=[]; label1.TextSettings.Font.Size:=8; label2.StyledSettings:=[]; label2.TextSettings.Font.Size:=8; mythread:=tmythread.Create; MessageManager := TMessageManager.DefaultManager; SubscriptionId := MessageManager.SubscribeToMessage(TMessage<String>,self._ReciveMessage); end; end.
-
Привет
Под WIN32/64:
- сообщение из формы в поток отправлял PostThreadMessage(myThread.ThreadID, WM_user+1, nativeuint(@data1),nativeuint(@data2));
- сообщение из потока в форму SendMessage(FormHandle,WM_user+2,nativeuint(@data1),nativeuint(@data2));
В Android такого нет. Подскажите, как организовать обмен сообщениями между формой и потоками в Android?
. Разобраться слету во всех иерархиях имеющихся классов тяжко. Что «наинтернетил», так и сделал. Есть вопросы. И в целом любая критика приветствуется.
Если окно свернуть/развернуть, то «следы» пропадают. Делаю вывод, что все корректно, и это скорее всего результат используемого в
Убрать маштабирование экрана на андроиде
в Графика
Опубликовано
"Убрать"(изменить) мастабирование для формы на платформе Windows:
if (Handle is TWinWindowHandle) then // (Handle as TWinWindowHandle).DpiChanged(FDPI); // реализация для версий ДО D11 (Handle as TWinWindowHandle).SetForcedScaleForForm(FDPI/96); // релазизация ДЛЯ D11DpiChanged - раньше работал правильно. В новом SetForcedScaleForForm изменять масштабирование можно на одинаковое значение для всех форм приложения, иначе краш..