#854. Containers, ARC and efficiency

Original in Russian: http://programmingmindstream.blogspot.ru/2015/09/1167-arc.html

I have containers.

Links:

Abstract containers.
Deriving of specific atomic containers from abstract ones.
Comments about containers  (in Russian)
Special containers. Part 2
http://18delphi.blogspot.ru/2013/07/blog-post_5374.html
Abstract containers. Part 2

Similar to TList<T> but own ones.

Usually, the iteration by container is as follows:

for i := 0 to Container.Count - 1 do
 Container.Items[i].SomeMethod;

Items is as follows:

function _l3TypedList_.pm_GetItems(anIndex: Integer): _ItemType_;
//#UC START# *47A1B1C102E9_47B084190028get_var*
//#UC END# *47A1B1C102E9_47B084190028get_var*
begin
//#UC START# *47A1B1C102E9_47B084190028get_impl*
 Result := GetItem(anIndex);
//#UC END# *47A1B1C102E9_47B084190028get_impl*
end;//_l3TypedList_.pm_GetItems
 
function _l3TypedListPrim_.GetItem(Index: Integer): _ItemType_;
//#UC START# *47B1CCC901BE_47A74A5F0123_var*
//#UC END# *47B1CCC901BE_47A74A5F0123_var*
begin
//#UC START# *47B1CCC901BE_47A74A5F0123_impl*
 CheckIndex(Index);
 Result := ItemSlot(Index)^;
//#UC END# *47B1CCC901BE_47A74A5F0123_impl*
end;//_l3TypedListPrim_.GetItem

The source code:
https://bitbucket.org/lulinalex/mindstream/src/7b84d023d4aefe22476b8a4ce398c42088e7f164/Examples/1167/?at=B284

Actually, it is quite good.

Containers of TList<T> sort are organized “in almost the same way”.

BUT!

It is “quite good” as long as _ItemType_ is the type WITHOUT ARC, i.e. it is atomic or is an object but neither a record with interfaces nor an interface.

As soon as we deal with ARC and/or a “large” record, we face efficiency issues.

What issues?

Items[i] return container’s elements ON VALUE, i.e. the values are COPIED to temporary variables.

But there is GetItemSlot method:

function GetItemSlot(anIndex: Integer;
  aList: _l3Items_): PItemType;
//#UC START# *47BEDF2A02EA_47A74A5F0123_var*
//#UC END# *47BEDF2A02EA_47A74A5F0123_var*
begin
//#UC START# *47BEDF2A02EA_47A74A5F0123_impl*
 Result := Pointer(aList.f_Data.AsPointer + anIndex * cItemSize);
 assert(Result <> nil);
//#UC END# *47BEDF2A02EA_47A74A5F0123_impl*
end;//GetItemSlot

It returns the POINTER to the container’s element.

Thus we may rewrite the iteration by container:

for i := 0 to Container.Count - 1 do
 Container.ItemSlot(i).SomeMethod;

The syntax is the same. We did not even have to dereference the pointer – the compiler did.

However, the semantics is different.

Instead of value copy the pointer to the element is returned.

Therefore, there are no overhead costs for either ARC or copying the “large record”.

IT IS CLEAR that we show the “container’s intestine”.

The reason is Delphi has no analogue to C++ const & (const reference).

We can write the value on this pointer but be ready to face the music.

Anyway, we win on the efficiency.

Even if we do as follows:

procedure SomeProc(const anItem: ItemType);
...
 
for i := 0 to Container.Count - 1 do
 SomeProc(Container.ItemSlot(i)^);

we still have NEITHER ARC nor copying.

The reason is const is written in SomeProc before anItem.

Referring back to TList<T> I’d like to say that the structure:

for Element in Container do
 Element.SomeMethod;

has the same problems as in the very first example.

The reason is:

TEnumerator = class abstract
protected
  function DoGetCurrent: T; virtual; abstract;
  function DoMoveNext: Boolean; virtual; abstract;
public
  property Current: T read DoGetCurrent;
  function MoveNext: Boolean;
end;
 
TEnumerable = class abstract
private
{$HINTS OFF}
  function ToArrayImpl(Count: Integer): TArray; // used by descendants
{$HINTS ON}
protected
  function DoGetEnumerator: TEnumerator; virtual; abstract;
public
  destructor Destroy; override;
  function GetEnumerator: TEnumerator;
  function ToArray: TArray; virtual;
end;

Current: T returns the VALUE instead of a pointer or a reference.

Thus ARC and/or COPYING.

Moreover, in mobile version ARC also works FOR OBJECTS (if there is assignment).

No way to do it differently in containers of TList<T> sort.

But it is possible to do it in “my” containers – using ItemSlot.

Thank you for attention.

P.S. Same is in https://bitbucket.org/lulinalex/mindstream/src/99ff3eee284bcab17905f1c9cbe02d4769c3e585/Examples/1167/tfwValueStack.pas?at=B284&fileviewer=file-view-default

pLast is used instead of Last with a good reason.

See the example:

...
function TtfwValueStack.PopBool: Boolean;
//#UC START# *4DB013AF01C9_4DB009CF0103_var*
//#UC END# *4DB013AF01C9_4DB009CF0103_var*
begin
//#UC START# *4DB013AF01C9_4DB009CF0103_impl*
 EtfwCheck.IsTrue(Count > 0, 'Empty stack');
 Result := pLast.AsBoolean;
 Delete(Count - 1);
//#UC END# *4DB013AF01C9_4DB009CF0103_impl*
end;//TtfwValueStack.PopBool
 
function TtfwValueStack.IsTopBool: Boolean;
//#UC START# *4DB04213007C_4DB009CF0103_var*
//#UC END# *4DB04213007C_4DB009CF0103_var*
begin
//#UC START# *4DB04213007C_4DB009CF0103_impl*
 if Empty then
  Result := false
 else
  Result := (pLast.rType = tfw_vtBool); 
//#UC END# *4DB04213007C_4DB009CF0103_impl*
end;//TtfwValueStack.IsTopBool
...
function TtfwValueStack.IsTopString: Boolean;
//#UC START# *4DB0488A0157_4DB009CF0103_var*
//#UC END# *4DB0488A0157_4DB009CF0103_var*
begin
//#UC START# *4DB0488A0157_4DB009CF0103_impl*
 if Empty then
  Result := false
 else
  Result := (pLast.rType = tfw_vtStr); 
//#UC END# *4DB0488A0157_4DB009CF0103_impl*
end;//TtfwValueStack.IsTopString
 
function TtfwValueStack.PopDelphiString: AnsiString;
//#UC START# *4DB0489C0129_4DB009CF0103_var*
//#UC END# *4DB0489C0129_4DB009CF0103_var*
begin
//#UC START# *4DB0489C0129_4DB009CF0103_impl*
 EtfwCheck.IsTrue(Count > 0, 'Empty stack');
 Result := pLast.AsDelphiString;
 Delete(Count - 1);
//#UC END# *4DB0489C0129_4DB009CF0103_impl*
end;//TtfwValueStack.PopDelphiString
...
etc

P.P.S. I do know about multithreading.

It does NOT ALLOW to return the pointer, JUST the value.

This is when you have to work with container using DIFFERENT threads.

P.P.P.S. Still, same issues with ARC and copying come up for large amounts of data.

#853. Access to private class members using records

Original in Russian: http://programmingmindstream.blogspot.ru/2015/09/1159-record.html

By no means always class members paradigm private/protected/public works as we would like it to work.

In fact, class may have “ordinary” users, “advanced” users and “experts”  .

Sometimes we want to provide each class of users with its "own level of access" to design class methods.

I devoted much thought to the ways how to do it.

Sure, interfaces may be used. I would not tell how for I believe you know it well.

But (!) interfaces are the overhead to AddRef/Release.

Sometimes we try to avoid this overhead.

We try to make something similar to interfaces that has no ARC. I dare say, "the protocols”.

Here are the links about the “protocols”:

Protocols vs interfaces. (in Russian)
"Makeshift" protocols. (in Russian)
Objective-C and Delphi.
Wide use of interfaces “in general” and InterlockedIncrement/InterlockedDecrement in particular…
(in Russian)

I don't know how "methods are called by name" in Objective-C, but that's how I would do it … (in Russian)

These are all “cows a in vacuum”.

How can we achieve it in practice?

I have been thinking it over and over again and came up with the following staff.

Nothing extraordinary. We simply make “facade" records that have access to the “object’s intestine”.

This is similar to Enumerators that are also implemented by records:

Generics, "mixins", interfaces and enumerators - just the code (in Russian)
With reference to my mate's words, "thoughts about syntax sugar" (in Russian)

Something as follows:

https://bitbucket.org/lulinalex/mindstream/src/b550da2431d733e50aab7b5bb3c4dcca7f3f68aa/Examples/Protocols/Protocols.dpr?at=B284&fileviewer=file-view-default

program Protocols;
 
{$APPTYPE CONSOLE}
 
{$R *.res}
 
uses
  System.SysUtils;
 
type
 TmyClass = class
  public
   // Here come the protocols for “advanced” user:
   type
    Advanced1 = record
     private
      f_Provider : TmyClass;
     public
      constructor Create(aProvider: TmyClass);
      procedure ForAdvancedUser1;
      procedure ForAdvancedUser2;
    end;//Advanced1
 
    Advanced2 = record
     private
      f_Provider : TmyClass;
     public
      constructor Create(aProvider: TmyClass);
      procedure ForAdvancedUser1;
    end;//Advanced2
 
    Advanced3 = record
     private
      f_Provider : TmyClass;
     public
      constructor Create(aProvider: TmyClass);
      procedure ForAdvancedUser2;
    end;//Advanced3
 
   // Here come the protocols for “experts”:
   type
    Expert1 = record
     private
      f_Provider : TmyClass;
     public
      constructor Create(aProvider: TmyClass);
      procedure ForExpertUser1;
      procedure ForExpertUser2;
    end;//Expert1
 
    Expert2 = record
     private
      f_Provider : TmyClass;
     public
      constructor Create(aProvider: TmyClass);
      procedure ForExpertUser1;
    end;//Expert2
 
    Expert3 = record
     private
      f_Provider : TmyClass;
     public
      constructor Create(aProvider: TmyClass);
      procedure ForExpertUser2;
    end;//Expert3
 
  private
   procedure ForAdvancedUser1;
   procedure ForAdvancedUser2;
 
   procedure ForExpertUser1;
   procedure ForExpertUser2;
  public
   procedure ForRegularUser1;
   procedure ForRegularUser2;
  public
   // Here come the methods to get the “protocols”
   function AsA1: Advanced1;
   function AsA2: Advanced2;
   function AsA3: Advanced3;
 
   function AsE1: Expert1;
   function AsE2: Expert2;
   function AsE3: Expert3;
 end;//TmyClass
 
// TmyClass.Advanced1
 
constructor TmyClass.Advanced1.Create(aProvider: TmyClass);
begin
 f_Provider := aProvider;
end;
 
procedure TmyClass.Advanced1.ForAdvancedUser1;
begin
 f_Provider.ForAdvancedUser1;
end;
 
procedure TmyClass.Advanced1.ForAdvancedUser2;
begin
 f_Provider.ForAdvancedUser2;
end;
 
// TmyClass.Expert1
 
constructor TmyClass.Expert1.Create(aProvider: TmyClass);
begin
 f_Provider := aProvider;
end;
 
procedure TmyClass.Expert1.ForExpertUser1;
begin
 f_Provider.ForExpertUser1;
end;
 
procedure TmyClass.Expert1.ForExpertUser2;
begin
 f_Provider.ForExpertUser2;
end;
 
// TmyClass.Expert2
 
constructor TmyClass.Expert2.Create(aProvider: TmyClass);
begin
 f_Provider := aProvider;
end;
 
procedure TmyClass.Expert2.ForExpertUser1;
begin
 f_Provider.ForExpertUser1;
end;
 
// TmyClass.Expert3
 
constructor TmyClass.Expert3.Create(aProvider: TmyClass);
begin
 f_Provider := aProvider;
end;
 
procedure TmyClass.Expert3.ForExpertUser2;
begin
 f_Provider.ForExpertUser2;
end;
 
// TmyClass.Advanced2
 
constructor TmyClass.Advanced2.Create(aProvider: TmyClass);
begin
 f_Provider := aProvider;
end;
 
procedure TmyClass.Advanced2.ForAdvancedUser1;
begin
 f_Provider.ForAdvancedUser1;
end;
 
// TmyClass.Advanced3
 
constructor TmyClass.Advanced3.Create(aProvider: TmyClass);
begin
 f_Provider := aProvider;
end;
 
procedure TmyClass.Advanced3.ForAdvancedUser2;
begin
 f_Provider.ForAdvancedUser2;
end;
 
// TmyClass
 
procedure TmyClass.ForAdvancedUser1;
begin
  WriteLn('ForAdvancedUser1');
end;
 
procedure TmyClass.ForAdvancedUser2;
begin
  WriteLn('ForAdvancedUser2');
end;
 
procedure TmyClass.ForExpertUser1;
begin
  WriteLn('ForExpertUser1');
end;
 
procedure TmyClass.ForExpertUser2;
begin
  WriteLn('ForExpertUser2');
end;
 
procedure TmyClass.ForRegularUser1;
begin
  WriteLn('ForRegularUser1');
end;
 
procedure TmyClass.ForRegularUser2;
begin
  WriteLn('ForRegularUser2');
end;
 
function TmyClass.AsA1: Advanced1;
begin
  Result := Advanced1.Create(Self);
end;
 
function TmyClass.AsA2: Advanced2;
begin
  Result := Advanced2.Create(Self);
end;
 
function TmyClass.AsA3: Advanced3;
begin
  Result := Advanced3.Create(Self);
end;
 
function TmyClass.AsE1: Expert1;
begin
  Result := Expert1.Create(Self);
end;
 
function TmyClass.AsE2: Expert2;
begin
  Result := Expert2.Create(Self);
end;
 
function TmyClass.AsE3: Expert3;
begin
  Result := Expert3.Create(Self);
end;
 
var
 l_C : TmyClass;
begin
  try
    l_C := TmyClass.Create;
    try
      l_C.ForRegularUser1;
      l_C.ForRegularUser2;
 
      l_C.AsA1.ForAdvancedUser1;
      l_C.AsA1.ForAdvancedUser2;
 
      l_C.AsA2.ForAdvancedUser1;
 
      l_C.AsA3.ForAdvancedUser2;
 
      l_C.AsE1.ForExpertUser1;
      l_C.AsE1.ForExpertUser2;
 
      l_C.AsE2.ForExpertUser1;
 
      l_C.AsE3.ForExpertUser2;
    finally
      FreeAndNil(l_C);
    end;
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
end.

That is all...

Of course, it is mundane and not wise to repeat it “for each class”.

However, it is useful in case of a “complex” class that has more than one "responsibility".

I do know about KISS and SRP.

(+) I do also know about RTTI and helpers.

(+)(+) Sure, I do know about God-object, too.

#852. Exceptions and efficiency

Original in Russian: http://programmingmindstream.blogspot.ru/2015/09/1165.html

I’ve profiled my scripts for efficiency (the problem roots in here - http://programmingmindstream.blogspot.ru/2015/09/1164-aqtime.html (in Russian)) and was surprised (again) to find out that (often) throwing the exception in business logic causes multiple loss in efficiency.

For example, the following code:

ARRAY FUNCTION LIST
 OBJECT IN anObject
 ^ IN aFunctor
  
 OBJECT VAR l_Element
 l_Element := anObject
 Result := [
  while true
  begin
   l_Element := ( l_Element aFunctor DO )
   if ( l_Element pop:object:IsNil ) then
    BREAK
   l_Element 
  end
 ]
; // LIST

works many times slower that the analogue:

ARRAY FUNCTION LIST
 OBJECT IN anObject
 ^ IN aFunctor
  
 OBJECT VAR l_Element
 l_Element := anObject
 BOOLEAN VAR l_NeedDo
 l_NeedDo := true
 Result := [
  while l_NeedDo
  begin
   l_Element := ( l_Element aFunctor DO )
   if ( l_Element pop:object:IsNil ) then
   begin
    l_NeedDo := false
   end
   else
    l_Element 
  end
 ]
; // LIST

Why is it so?

The reason is that actually BREAK is organized as follows:

https://bitbucket.org/lulinalex/mindstream/src/7deb4ed1ebc5a138c2a90cc69f14bed0847b09a1/Examples/1165/BasicsPack.pas?at=B284&fileviewer=file-view-default

procedure TkwBREAK.DoDoIt(const aCtx: TtfwContext);
//#UC START# *4DAEEDE10285_9FA400CD8713_var*
//#UC END# *4DAEEDE10285_9FA400CD8713_var*
begin
//#UC START# *4DAEEDE10285_9FA400CD8713_impl*
 raise EtfwBreak.Create('Loop exit');
//#UC END# *4DAEEDE10285_9FA400CD8713_impl*
end;//TkwBREAK.DoDoIt

Basic time is “chewed” by object creation/deletion which is actually “rather costly”.

Here is the assembly code:

That is why I used to do my own object cach.

Here is an example:

https://bitbucket.org/lulinalex/mindstream/src/7deb4ed1ebc5a138c2a90cc69f14bed0847b09a1/Examples/1165/l3UnknownPrim.imp.pas?at=B284&fileviewer=file-view-default

class function _l3UnknownPrim_.NewInstance: TObject;
  //override;
  {* - memory allocation function for object’s instance; it is overridden to check the memory for the objects. }
{$IfDef _UnknownNeedL3}
var
 l_System : Tl3System;
{$EndIf _UnknownNeedL3}
begin
 {$IfDef _UnknownNeedL3}
 l_System := Tl3System(g_l3System);
 if (l_System = nil) then
 begin
  if not l3MemUtilsDown{l3SystemDown} then
  begin
   l_System := l3System;
//   if (l_System <> nil) then
//    l_System.Stack2Log('Possible oddness NewInstance/FreeInatance');
  end;//not l3SystemDown
 end;//l_System = nil
 Assert((l_System <> nil) OR not Cacheable); 
 if (l_System <> nil) AND l_System.CanCache AND Cacheable then
 begin
  Result := GetFromCache;
  if (Result <> nil) then
  begin
   _l3UnknownPrim_(Result).InitAfterAlloc;
   Exit;
  end;//Result <> nil
 end;{l_System.CanCache}
 {$EndIf _UnknownNeedL3}
 Result := AllocInstanceMem;
 _l3UnknownPrim_(Result).Use;
 _l3UnknownPrim_(Result).InitAfterAlloc;
 {$IfDef _UnknownNeedL3}
 {$IfDef l3TraceObjects}
 if (l_System <> nil) then
  l_System.RegisterObject(Result, Cacheable);
 {$EndIf l3TraceObjects}
 {$EndIf _UnknownNeedL3}
end;

In this case I made exceptions as singletons and used them in the following way:

procedure TkwBREAK.DoDoIt(const aCtx: TtfwContext);
//#UC START# *4DAEEDE10285_9FA400CD8713_var*
//#UC END# *4DAEEDE10285_9FA400CD8713_var*
begin
//#UC START# *4DAEEDE10285_9FA400CD8713_impl*
 raise EtfwBreak.Instance;
//#UC END# *4DAEEDE10285_9FA400CD8713_impl*
end;//TkwBREAK.DoDoIt

In some degree, it solved the issue of efficiency.

Sure, this is all about “scripts”.

Indeed, I have found it at large working data sizes like the large model project (dozens of thousands classes and about 12-15 millions lines of code).

One would think Delphi developer does not care about it.

I just want to stress that “throwing exceptions” is a “costly” trick. Unnecessary use of exceptions in business logic (I have seen people doing so) as a “special function result” inevitably leads to efficiency loss.

It is so when exceptions are thrown relatively often compared to the “usual code”.

I would also like to write about ARC and exceptions but I’d rather won’t.

I do NOT think you will understand me right. ARC is mainstream, after all.

Though, as judged by the code, exceptions are ALSO exposed to ARC.

However, it seems the Embarcadero developers have not faced these problems yet.

Thus, let’s consider these thoughts as “my personal phantom pain”.

#851. Link. Cursor setting and auto recovery on method return

Original in Russian: http://programmingmindstream.blogspot.ru/2015/09/1163.html

In reference to http://www.tdelphiblog.com/2015/09/LazyCursorHelper.html (in Russian)

I can also add my two cents in this regards:

Asynchronous message window output in a separate triad.
Progress visualizer.

Link to the source code:
https://bitbucket.org/lulinalex/mindstream/src/e63e4f41630b37fb3f07ffd77b600ab8b081c77d/Examples/LongProcess/?at=B284

#850. Progress visualizer

Original in Russian: http://18delphi.blogspot.ru/2013/05/blog-post_7718.html

unit afwLongProcessVisualizer;
 
interface
 
uses
  afwInterfaces,
  l3Base,
  l3AsincMessageWindow
  ;
 
type
 TafwLongProcessVisualizer = class(Tl3Base, IafwLongProcessVisualizer)
 private
 // private fields
   f_Wnd : Tl3AsincMessageWindow;
    {* The message window.}
 protected
 // overridden protected methods
   procedure Cleanup; override;
     {* Object fields clean up function. }
 public
 // public methods
   constructor Create(const aCaption: IafwCString;
    anAttachWnd: THandle = 0;
    anInitialTimeout: Cardinal = afw_lpwTimeout;
    anImageList: TafwCustomImageList = nil;
    anImageIndex: Integer = -1); reintroduce;
     {* Creates class instant }
   class function Make(const aCaption: IafwCString;
    anAttachWnd: THandle = 0;
    anInitialTimeout: Cardinal = afw_lpwTimeout;
    anImageList: TafwCustomImageList = nil;
    anImageIndex: Integer = -1): IafwLongProcessVisualizer; reintroduce;
     {* Creates class instant in the form of interface IafwLongProcessVisualizer. }
 end;//TafwLongProcessVisualizer
 
implementation
 
// start class TafwLongProcessVisualizer
 
constructor TafwLongProcessVisualizer.Create(const aCaption: IafwCString;
  anAttachWnd: THandle = 0;
  anInitialTimeout: Cardinal = afw_lpwTimeout;
  anImageList: TafwCustomImageList = nil;
  anImageIndex: Integer = -1);
begin
 inherited Create;
 f_Wnd := Tl3AsincMessageWindow.Create(aCaption, anImageList, anImageIndex,
                                       anAttachWnd, anInitialTimeout);
end;//TafwLongProcessVisualizer.Create
 
class function TafwLongProcessVisualizer.Make(const aCaption: IafwCString;
  anAttachWnd: THandle = 0;
  anInitialTimeout: Cardinal = afw_lpwTimeout;
  anImageList: TafwCustomImageList = nil;
  anImageIndex: Integer = -1): IafwLongProcessVisualizer;
var
 l_Inst : TafwLongProcessVisualizer;
begin
 l_Inst := Create(aCaption, anAttachWnd, anInitialTimeout, anImageList, anImageIndex);
 try
  Result := l_Inst;
 finally
  l_Inst.Free;
 end;//try..finally
end;
 
procedure TafwLongProcessVisualizer.Cleanup;
begin
 FreeAndNil(f_Wnd);
 inherited;
end;//TafwLongProcessVisualizer.Cleanup
 
end.

#849. Asynchronous message window output in a separate thread

Original in Russian: http://18delphi.blogspot.ru/2013/05/blog-post_8549.html

Tl3GradientWaitbar is described here - Gradient wait bar

unit l3AsincMessageWindow;
{* Output the asynchronous message window in a separate thread }
 
interface
 
uses
 Windows,
 Classes,
 Graphics,
 Messages,
 ImgList,
 
 l3GradientWaitbar
 ;
 
type
  Tl3AsincMessageWindow = class(TThread)
  {* Asynchronous window with a message }
   private
   // internal variables
     f_Handle          : HWND;
     f_Caption         : Il3CString;
     f_Canvas          : TCanvas;
     f_Progress        : THandle;
     f_IconSize        : TSize;
     f_IconHandle      : HICON;
     f_TextRect        : TRect;
     f_SizeExcludeText : TSize;
     f_Waitbar         : Tl3GradientWaitbar;
     f_Size            : TSize;
     f_Images          : TCustomImageList;
     f_ImageIndex      : Integer;
     f_BottomContext   : Integer;
     f_WindowOrigin: TPoint;
     f_WindowExtent: TSize;
     f_ScreenWidth: Longint;
     f_WaitTimeout: Cardinal;
     f_Attached: Boolean;
     f_InPaint: Integer;
   private
   // property methods
     procedure pm_SetCaption(const aValue : Il3CString);
       {-}
     procedure pm_SetProgress(const Value : THandle);
       {-}
   private
   // internal methods
     procedure InitDC;
       {-}
     procedure UpdateSize;
       {-}
     procedure InitFont;
       {-}
     procedure Paint;
       {-}
     function DrawTextRect : TRect;
       {-}
     procedure PaintProgress(aInitPaint : Boolean = True);
       {-}
     function ProgressRect : TRect;
       {-}
     function BottomContext : Integer;
       {-}
     procedure RegisterClass;
       {* - registers the class of the window to be created. }
     procedure CreateWindow;
       {* - creates the window. }
     procedure DestroyWindow;
       {* - destroys the window. }
     procedure Show;
       {* - Shows the window; it is displayed on center of the current Application.MainForm }
     function ContextSpace : Integer;
       {-}
     function ContextRect : TRect;
       {-}
     procedure CalcSizeExcludeText;
       {-}
     procedure CalcTextRect;
       {-}
   protected
   // protected methods
     function CalcSize : TSize;
       {* - calculates the size of the form. }
     procedure Execute;
       override;
       {-}
   public
   // public methods
     constructor Create(const aCaption : Il3CString = nil;
                        aImages        : TCustomImageList = nil;
                        aImageIndex    : Integer = -1;
                        anAttachWnd    : THandle = 0;
                        anInitialWait  : Cardinal = 0);
       reintroduce;
       virtual;
       {-}
     destructor Destroy;
       override;
       {-}
   public
   // properties
     property Caption : Il3CString
       read f_Caption
       write pm_SetCaption;
       {-}
     property Progress : THandle
       read f_Progress
       write pm_SetProgress;
       {-}
  end;//Tl3AsincMessageWindow
 
procedure ActivateAllAsyncWindows(anActive: Boolean);
 
implementation
 
uses
  Controls,
  Types,
  Math,
  SysUtils,
  Forms,
  MultiMon
  ;
 
////////////////////////////////////////////////////////////////////////////////
const
 cClassName  = 'l3AsincMessageWindow';
   {* - name of the registered class. }
 cFrameSize = 4;
   {* - frame size. }
 cSpace      = 5;
   {* - space between the objects. }
 cProgressHeight = 15;
   {* - progress bar height. }
////////////////////////////////////////////////////////////////////////////////
 
var
 g_AllAsyncWindows: TThreadList = nil;
 
function WindowProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
// Potential hazard when switching to 64 bits – pointer to Self is moved through SetWindowLong (32 bits).
 
 procedure lpDef;
 begin
  Result := DefWindowProc(hWnd, Msg, wParam, lParam);
 end;
 
var
 l_Window: Tl3AsincMessageWindow;
 
begin
 case Msg of
  WM_PAINT:
  begin
   l_Window := Tl3AsincMessageWindow(GetWindowLong(hWnd, GWL_USERDATA));
   if Assigned(l_Window) then
    l_Window.Paint;
   Result := 0;
  end;
  WM_DESTROY:
   begin
    PostQuitMessage(0);
    Result := 0;
   end;
  WM_CLOSE:
    SetWindowPos(hWnd, 0, 0, 0, 0, 0, SWP_HIDEWINDOW);
  else
   lpDef;
 end;
end;
 
// Class Tl3AsincMessageWindow
 
procedure Tl3AsincMessageWindow.InitFont;
begin
 Assert(f_Canvas <> nil);
 with f_Canvas.Font do
 begin
  Size := 10;
  Charset := RUSSIAN_CHARSET;
 end;//with f_Canvas.Font
end;
 
constructor Tl3AsincMessageWindow.Create(const aCaption : Il3CString = nil;
                                         aImages        : TCustomImageList = nil;
                                         aImageIndex    : Integer = -1;
                                         anAttachWnd    : THandle = 0;
                                         anInitialWait  : Cardinal = 0);
var
 l_Rect: TRect;
 l_Form: TCustomForm;
 l_FormHandle: THandle;
 l_MonInfo: TMonitorInfo;
begin
 inherited Create(True);
 Assert(Suspended);
 f_InPaint := 0;
 f_WaitTimeout := anInitialWait;
 f_Attached := (anAttachWnd <> 0);
 if f_Attached then
 begin
  l_FormHandle := anAttachWnd;
  if not GetWindowRect(l_FormHandle,l_Rect) then
  begin
   f_Attached := False;
  end//not GetWindowRect(l_FormHandle,l_Rect)
  else
  with l_Rect do
  begin
   f_WindowOrigin := Point(Left, Bottom);
   f_ScreenWidth := Right - Left;
   f_WindowExtent.cx := 0;
   f_WindowExtent.cy := 0;
  end;//with l_Rect
 end;//f_Attached
 if not f_Attached then
 begin
  l_Form := Application.MainForm;
  if Assigned(l_Form) then
  begin
   l_FormHandle := l_Form.Handle;
   if not GetWindowRect(l_FormHandle,l_Rect) then
   begin
    l_FormHandle := 0;
    GetWindowRect(Application.Handle,l_Rect);
   end;//not GetWindowRect(l_FormHandle,l_Rect)
  end//Assigned(l_Form)
  else
  begin
   l_FormHandle := 0;
   GetWindowRect(Application.Handle,l_Rect);
  end;//Assigned(l_Form)
  f_WindowOrigin := l_Rect.TopLeft;
  l_MonInfo.cbSize := SizeOf(l_MonInfo);
  GetMonitorInfo(MonitorFromPoint(f_WindowOrigin,MONITOR_DEFAULTTONEAREST), @l_MonInfo);
  with l_MonInfo.rcWork do
   f_ScreenWidth := Right - Left;
  if (l_FormHandle = 0) then
  begin
   f_WindowOrigin := l_MonInfo.rcWork.TopLeft;
   f_WindowExtent.cx := f_ScreenWidth;
   with l_MonInfo.rcWork do
    f_WindowExtent.cy := Bottom - Top;
  end//l_FormHandle = 0
  else
   with l_Rect do
   begin
    f_WindowExtent.cx := Right - Left;
    f_WindowExtent.cy := Bottom - Top;
   end;//with l_Rect
 end;//not f_Attached
 
 f_Canvas := TCanvas.Create;
 // Waitbar
 f_Waitbar := Tl3GradientWaitbar.Create;
 if not f_Attached then
 begin
  // We get an icon
  if Assigned(aImages) and (aImageIndex <> -1) and ((aImageIndex >= 0) and
   (aImageIndex < aImages.Count)) then
  begin
   f_Images      := aImages;
   f_ImageIndex  := aImageIndex;
   f_IconSize.cx := aImages.Width;
   f_IconSize.cy := aImages.Height;
  end//Assigned(aImages)..
  else
  begin
   f_IconSize.cx := GetSystemMetrics(SM_CXICON);
   f_IconSize.cy := GetSystemMetrics(SM_CYICON);
   f_IconHandle := LoadIcon(0, IDI_EXCLAMATION);
  end;//Assigned(aImages)..
 end;//not f_Attached
 // Size with text excluded
 CalcSizeExcludeText;
 // Caption
 if aCaption <> nil then
  Caption := aCaption
 else
  Caption := str_l3mmLongOperation.AsCStr;
 // Size
 f_Size := CalcSize;
 // Initialized as an empty value
 f_BottomContext := -1;
 f_Handle := 0;
 Resume;
end;
 
destructor Tl3AsincMessageWindow.Destroy;
// override;
{-}
begin
 while (f_InPaint <> 0) do
  Sleep(0);
 l3Free(f_Canvas);
 l3Free(f_Waitbar);
 f_Caption := nil;
 inherited;
end;
 
procedure Tl3AsincMessageWindow.CalcTextRect;
begin
 SetRectEmpty(f_TextRect);
 if not f_Attached then
 begin
  // Maximum text width
  f_TextRect.Right := f_ScreenWidth div 2 - f_SizeExcludeText.cx;
  Assert(f_Canvas <> nil);
  // Text size
  DrawText(f_Canvas.Handle, PAnsiChar(l3Str(f_Caption)), -1, f_TextRect, DT_WORDBREAK or
   DT_CALCRECT);
 end;//not f_Attached
end;
 
procedure Tl3AsincMessageWindow.UpdateSize;
begin
 if f_Handle <> 0 then
 begin
  CalcTextRect;
  f_Size := CalcSize;
 end;
end;
 
procedure Tl3AsincMessageWindow.pm_SetCaption(const aValue : Il3CString);
{-}
begin
 if not l3Same(aValue, f_Caption) then
 begin
  f_Caption := aValue;
  UpdateSize;
 end;//not l3Same(aValue, f_Caption)
end;
 
procedure Tl3AsincMessageWindow.Show;
{* - Shows the window; it is displayed on center of the current Application.MainForm }
var
 lTop  : Integer;
 lLeft : Integer;
begin
 // Waitbar
 Inc(f_InPaint);
 try
  with ProgressRect do
  begin
   Assert(f_Waitbar <> nil);
   f_Waitbar.SetBounds(0, 0, Right - Left, Bottom - Top);
  end;//ProgressRect
  f_Waitbar.Speed := 1;
 finally
  Dec(f_InPaint);
 end;//try..finally 
 // Position
 if f_Attached then
 begin
  lTop := f_WindowOrigin.y;
  lLeft := f_WindowOrigin.x;
 end//f_Attached
 else
 begin
  lTop := f_WindowOrigin.y + ((f_WindowExtent.cy div 2) -
   (f_Size.cy div 2));
  lLeft := f_WindowOrigin.x + ((f_WindowExtent.cx div 2) -
   (f_Size.cx div 2));
 end;//f_Attached
 SetWindowPos(f_Handle, 0, lLeft, lTop, f_Size.cx, f_Size.cy, SWP_SHOWWINDOW or
  SWP_NOACTIVATE);
end;
 
function Tl3AsincMessageWindow.ContextRect : TRect;
begin
 if f_Attached then
  SetRectEmpty(Result)
 else
 begin
  GetClientRect(f_Handle, Result);
  OffsetRect(Result, -Result.Left, -Result.Top);
  InflateRect(Result, -ContextSpace, -ContextSpace);
 end;
end;
 
function Tl3AsincMessageWindow.ContextSpace : Integer;
begin
 Result := cFrameSize + cSpace;
end;
 
procedure Tl3AsincMessageWindow.CalcSizeExcludeText;
begin
 if not f_Attached then
 begin
  // From the frame to components
  Inc(f_SizeExcludeText.cx, ContextSpace * 2);
  Inc(f_SizeExcludeText.cy, ContextSpace * 2);
  // Icon
  Inc(f_SizeExcludeText.cx, f_IconSize.cx);
  Inc(f_SizeExcludeText.cy, f_IconSize.cy);
  // Space to text
  Inc(f_SizeExcludeText.cx, cSpace);
 end
 else
 begin
  f_SizeExcludeText.cx := f_ScreenWidth;
  f_SizeExcludeText.cy := cFrameSize;
 end;
end;
 
function Tl3AsincMessageWindow.CalcSize : TSize;
begin
 Result := f_SizeExcludeText;
 // Progress
 // Frame
 Inc(Result.cy, cFrameSize);
 // Progress
 Inc(Result.cy, cProgressHeight);
 // Caption Width
 Inc(Result.cx, f_TextRect.Right);
 // Caption Height
 if f_TextRect.Bottom > f_IconSize.cy then
 begin
  Dec(Result.cy, f_IconSize.cy);
  Inc(Result.cy, f_TextRect.Bottom);
 end;
end;
 
function Tl3AsincMessageWindow.BottomContext : Integer;
begin
 // Calculate one time
 if f_BottomContext = -1 then
 begin
  if f_Attached then
   f_BottomContext := 0
  else
   f_BottomContext := ContextSpace + Max(f_IconSize.cy, f_TextRect.Bottom) +
    cSpace;
 end;
 //
 Result := f_BottomContext;
end;
 
function Tl3AsincMessageWindow.ProgressRect : TRect;
begin
 Result := Rect(0, 0, f_Size.cx, f_Size.cy);
 InflateRect(Result, -cFrameSize, -cFrameSize);
 if not f_Attached then
  Result.Top := Result.Bottom - cProgressHeight;
 InflateRect(Result, -2, -2);
end;
 
procedure Tl3AsincMessageWindow.PaintProgress(aInitPaint : Boolean = True);
var
 lPStruct : TPaintStruct;
begin
 Inc(f_InPaint);
 try
  if (f_Waitbar = nil) or (f_Canvas = nil) then
   Exit;
  Assert(f_Waitbar <> nil);
  f_Waitbar.BackBuf.Canvas.Lock;
  try
   f_Waitbar.ManualProgress(1);
   Assert(f_Waitbar <> nil);
   if aInitPaint then
    BeginPaint(f_Handle, lPStruct);
   try
    Assert(f_Canvas <> nil);
    with ProgressRect do
     BitBlt(f_Canvas.Handle, Left, Top, Right - Left, Bottom - Top,
      f_Waitbar.BackBuf.Canvas.Handle, 0, 0, cmSrcCopy);
   finally
    if aInitPaint then
     EndPaint(f_Handle, lPStruct);
   end;//try..finally
  finally
   Assert(f_Waitbar <> nil);
   f_Waitbar.BackBuf.Canvas.Unlock;
  end;//try..finally
 finally
  Dec(f_InPaint);
 end;//try..finally
end;
 
function Tl3AsincMessageWindow.DrawTextRect : TRect;
begin
 Result.Right  := f_Size.cx - ContextSpace;
 Result.Left   := Result.Right - f_TextRect.Right;
 Result.Top    := ContextSpace;
 Result.Bottom := BottomContext - cSpace;
end;
 
procedure Tl3AsincMessageWindow.Paint;
{-}
var
 lRect    : TRect;
 lPStruct : TPaintStruct;
 lUpdate  : Boolean;
 lFlags   : Integer;
 lY       : Integer;
begin
 Inc(f_InPaint);
 try
  if (f_Canvas = nil) then
   Exit;
  lUpdate := GetUpdateRect(f_Handle, lRect, False);
  if EqualRect(lRect, ProgressRect) then
  begin
   PaintProgress;
   Exit;
  end;//EqualRect(lRect, ProgressRect)
  // Client output area
  GetClientRect(f_Handle, lRect);
  // Output
  if lUpdate then
   BeginPaint(f_Handle, lPStruct);
  try
   // Loading
   Assert(f_Canvas <> nil);
   with f_Canvas do
   begin
    Brush.Color := clBtnFace;
    FillRect(lRect);
   end;//with f_Canvas
   // Outer frame
   Assert(f_Canvas <> nil);
   DrawEdge(f_Canvas.Handle, lRect, BDR_RAISEDINNER, BF_RECT);
   if not f_Attached then
   begin
    // Context frame
    InflateRect(lRect, -cFrameSize, -cFrameSize);
    lRect.Bottom := BottomContext;
    Assert(f_Canvas <> nil);
    DrawEdge(f_Canvas.Handle, lRect, BDR_SUNKENINNER, BF_RECT);
   end//not f_Attached
   else
    InflateRect(lRect, -cFrameSize, 0);
   // Progress bar frame
   lRect.Top := BottomContext + cFrameSize;
   lRect.Bottom := lRect.Top + cProgressHeight;
   Assert(f_Canvas <> nil);
   DrawEdge(f_Canvas.Handle, lRect, BDR_SUNKENINNER, BF_RECT);
   if not f_Attached then
   begin
    // Output area
    lRect := ContextRect;
    // Icon
    lY := ((lRect.Bottom - lRect.Top) - f_IconSize.cy) div 2;
    Assert(f_Canvas <> nil);
    if Assigned(f_Images) then
     f_Images.Draw(f_Canvas, ContextSpace, lY, f_ImageIndex)
    else
     Windows.DrawIcon(f_Canvas.Handle, ContextSpace, lY, f_IconHandle);
   end;//not f_Attached
   // Progress
   PaintProgress(False);
   if not f_Attached then
   begin
    // Caption
    if not l3IsNil(f_Caption) then
    begin
     lRect := DrawTextRect;
     if f_IconSize.cy > f_TextRect.Bottom then
     begin
      lFlags := DT_SINGLELINE or DT_VCENTER;
     end
     else
      lFlags := DT_WORDBREAK;
     Assert(f_Canvas <> nil); 
     Windows.DrawText(f_Canvas.Handle,
                      PAnsiChar(l3Str(f_Caption)),
                      -1,
                      lRect,
                      lFlags);
    end;//if not l3IsNil(f_Caption) then
   end;
  finally
   if lUpdate then
    EndPaint(f_Handle, lPStruct);
  end;//try..finally
 finally
  Dec(f_InPaint);
 end;//try..finally
end;
 
procedure Tl3AsincMessageWindow.RegisterClass;
{* - registers the class of the window to be created. }
var
 l_Class: TWndClass;
begin
 if not GetClassInfo(hInstance, cClassName, l_Class) then
 begin
  l3FillChar(l_Class, SizeOf(l_Class), 0);
  l_Class.style         := CS_OWNDC or CS_NOCLOSE or CS_HREDRAW or CS_VREDRAW;
  l_Class.lpfnWndProc   := @WindowProc;
  l_Class.lpszClassName := cClassName;
  l_Class.hInstance     := hInstance;
  Windows.RegisterClass(l_Class);
 end;
end;
 
procedure Tl3AsincMessageWindow.InitDC;
begin
 Assert(f_Canvas <> nil);
 f_Canvas.Handle := GetDC(f_Handle);
 InitFont;
 UpdateSize;
end;
 
procedure Tl3AsincMessageWindow.CreateWindow;
begin
 // Class registration
 RegisterClass;
 // Window creation
 f_Handle := Windows.CreateWindow(cClassName, '', WS_POPUP,
  Integer(CW_USEDEFAULT), 0, Integer(CW_USEDEFAULT), 0, 0, 0, hInstance, nil);
 SetWindowLong(f_Handle, GWL_USERDATA, Integer(Self));
 
 if not f_Attached then
 begin
  SetWindowPos(f_Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
    SWP_NOSIZE or SWP_NOACTIVATE);
  g_AllAsyncWindows.Add(Pointer(f_Handle));
 end;//not f_Attached
 
 // DC
 InitDC;
 // Show the window
 Show;
end;
 
procedure Tl3AsincMessageWindow.DestroyWindow;
begin
 if f_Handle = 0 then Exit;
 if not f_Attached then
  g_AllAsyncWindows.Remove(Pointer(f_Handle));
 SetWindowLong(f_Handle, GWL_USERDATA, 0);
 SendMessage(f_Handle, WM_PAINT, 0, 0);
 Windows.DestroyWindow(f_Handle);
end;
 
procedure Tl3AsincMessageWindow.Execute;
var
 l_Message : TMsg;
 l_Rect    : TRect;
 l_Time    : Cardinal;
 
 procedure lpProgress;
 const
  cDelay = 1;
 begin
  if (GetTickCount - cDelay >= l_Time) then
  begin
   l_Rect := ProgressRect;
   Inc(f_InPaint);
   try
    Windows.RedrawWindow(f_Handle, @l_Rect, 0, RDW_INVALIDATE);
   finally
    Dec(f_InPaint);
   end;//try..finally
   l_Time := GetTickCount;
  end;//GetTickCount - cDelay >= l_Time
 end;
 
begin
 while not Terminated and (f_WaitTimeout > 0) do
 begin
  Sleep(100);
  if Terminated then
   exit;
  if f_WaitTimeout > 100 then
   Dec(f_WaitTimeout, 100)
  else
  begin
   Sleep(f_WaitTimeout);
   Break;
  end;
 end;
 if Terminated then
  exit;
 CreateWindow;
 try
  l_Time := GetTickCount;
  repeat
   if Terminated then
    DestroyWindow;
   if PeekMessage(l_Message, 0, 0, 0, PM_REMOVE) then
   begin
    if (l_Message.Message = WM_QUIT) or
       ((l_Message.Message = WM_CLOSE) and
         (l_Message.hWnd = f_Handle)) then
    begin
     f_Handle := 0;
     Break;
    end;
    TranslateMessage(l_Message);
    DispatchMessage(l_Message);
   end;
   if not Terminated then
    lpProgress;
  until False;
 finally
  DestroyWindow;
 end;//try..finally
end;
 
procedure Tl3AsincMessageWindow.pm_SetProgress(const Value: THandle);
begin
 f_Progress := Value;
end;
 
procedure FinalizeAllAsyncWindows;
begin
 FreeAndNil(g_AllAsyncWindows);
end;
 
procedure ActivateAllAsyncWindows(anActive: Boolean);
var
 l_IDX: Integer;
const
 cInsertAfter: array [Boolean] of HWND = (HWND_NOTOPMOST, HWND_TOPMOST);
begin
 with g_AllAsyncWindows.LockList do
 try
  for l_IDX := Count-1 downto 0 do
   SetWindowPos(THandle(Items[l_IDX]), cInsertAfter[anActive], 0, 0, 0, 0, SWP_NOMOVE or
     SWP_NOSIZE or SWP_NOACTIVATE);
 finally
  g_AllAsyncWindows.UnlockList;
 end;
end;
 
initialization
 g_AllAsyncWindows := TThreadList.Create;
 l3System.AddExitProc(FinalizeAllAsyncWindows);
 
end.

#848. Gradient wait bar

unit l3GradientWaitbar;
 
interface
 
uses
  Windows,
  Graphics,
  Messages,
  SysUtils,
  ExtCtrls,
  Classes
  ;
 
type
  Tl3GradientWaitbar = class(TObject)
  private
  // internal fields
   FLeft    : Integer;
   FTop     : Integer;
   FWidth   : Integer;
   FHeight  : Integer;  
   FBackBuf : TBitmap;
   FColor1  : TColor;
   FColor2  : TColor;
   FSpeed   : Integer;
   FTimer   : TTimer;
   TmpB     : TBitmap;
   FOnPaint : TNotifyEvent;
  private
  // internal methods
   procedure DoPaint;
     {-}
   procedure BuildBackBuffer;
     {-}
   procedure OnTimer(Sender: TObject);
     {-}
   function GetActive: Boolean;
     {-}
   procedure SetActive(const Value: Boolean);
     {-}
   procedure SetColor1(const Value: TColor);
     {-}
   procedure SetColor2(const Value: TColor);
     {-}
  protected
  // protected methods
   destructor Destroy;
     override;
     {-}
  public
  // public methods
   constructor Create;
     reintroduce;
     virtual;
     {-}
   procedure ManualProgress(Progress: Integer);
     {-}
   procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
     {-}
   procedure DoProgress;
     {-}
  public
  // public properties
   property Left : Integer
     read FLeft
     write FLeft;
     {-}
   property Top : Integer
     read FTop
     write FTop;
     {-}
   property Width : Integer
     read FWidth
     write FWidth;
     {-}
   property Height : Integer
     read FHeight
     write FHeight;
     {-}
   property BackBuf : TBitmap
     read FBackBuf;
     {-}
   property Active: Boolean
     read GetActive
     write SetActive;
     {-}
   property Color1: TColor
     read FColor1
     write SetColor1;
     {-}
   property Color2: TColor
     read FColor2
     write SetColor2;
     {-}
   property Speed: Integer
     read FSpeed
     write FSpeed
     default 1;
     {-}
  public
  // events
    property OnPaint : TNotifyEvent
      read FOnPaint
      write FOnPaint;
      {-}
  end;//Tl3GradientWaitbar
 
implementation
 
{ Tl3GradientWaitbar }
 
constructor Tl3GradientWaitbar.Create;
begin
 FSpeed := 1;
 FTimer := TTimer.Create(nil);
 FTimer.Interval := 1;
 FTimer.OnTimer := OnTimer;
 FBackBuf := TBitmap.Create;
 TmpB := TBitmap.Create;
 FColor1 := clSkyBlue;
 FColor2 := clBlue;
 SetBounds(Left, Top, 150, 25);
end;
 
destructor Tl3GradientWaitbar.Destroy;
// override;
{-}
begin
 FreeAndNil(FTimer);
 FreeAndNil(FBackBuf);
 FreeAndNil(TmpB);
 inherited;
end;
 
procedure Tl3GradientWaitbar.BuildBackBuffer;
 
type
 TRGB = record
  R,G,B : byte;
 end;
 
 function ColorToRGB(Color:TColor):TRGB;
 var
  Cl: Longint;
 Begin
  Cl := Graphics.ColorToRGB(Color);
  Result.R:=GetRValue(Cl);
  Result.G:=GetGValue(Cl);
  Result.B:=GetBValue(Cl);
 End;
 
var
 Rect: TRect;
 DestRGB, CurrRGB, SourceRGB: TRGB;
{
 RMode, GMode, BMode: Integer;
} 
 X: Integer;
 HalfWidth: Integer;
 Discrete : real;
 RDelta,GDelta,BDelta: Real;
 
begin
 FBackBuf.Canvas.Lock;
 try
  Assert(FBackBuf <> nil);
  FBackBuf.Width := Width;
  Assert(FBackBuf <> nil);
  FBackBuf.Height := Height;
  Assert(FBackBuf <> nil);
  with FBackBuf.Canvas do
  begin
   SourceRGB:=ColorToRGB(FColor1);
   DestRGB:=ColorToRGB(FColor2);
   CurrRGB:=SourceRGB;
 
   RDelta := (DestRGB.R - SourceRGB.R) / 255;
   GDelta := (DestRGB.G - SourceRGB.G) / 255;
   BDelta := (DestRGB.B - SourceRGB.B) / 255;
 
   Rect.top:=0;
   Rect.bottom:=Height;
 
   Discrete := Width / 512;
 
   For X:=0 to 255 do
   begin
    Rect.Left   := Round((X) * Discrete);
    Rect.right  := Round((X+1)* Discrete);
    CurrRGB.R := SourceRGB.R + Round(X*RDelta);
    CurrRGB.G := SourceRGB.G + Round(X*GDelta);
    CurrRGB.B := SourceRGB.B + Round(X*BDelta);
    Brush.Color:=TColor(rgb(CurrRGB.R,CurrRGB.G,CurrRGB.B));
    FillRect(Rect);
   end;//For X:=0 to 255
   HalfWidth := Width div 2;
   Assert(FBackBuf <> nil);
   StretchBlt(FBackBuf.Canvas.Handle, HalfWidth, 0, HalfWidth+(Width mod 2), Height,
     FBackBuf.Canvas.Handle, HalfWidth-1, 0, -HalfWidth, Height, cmSrcCopy);
  end;//with FBackBuf.Canvas
 finally
  Assert(FBackBuf <> nil);
  Assert(FBackBuf.Canvas <> nil);
  FBackBuf.Canvas.UnLock;
 end;//try..finally
 DoPaint;
end;
 
procedure Tl3GradientWaitbar.OnTimer(Sender: TObject);
begin
 DoProgress;
 DoPaint;
end;
 
procedure Tl3GradientWaitbar.DoProgress;
{-}
begin
 TmpB.Canvas.Lock;
 try
  FBackBuf.Canvas.Lock;
  TmpB.Width  := FSpeed;
  TmpB.Height := Height;
  BitBlt(TmpB.Canvas.Handle, 0, 0, FSpeed, Height,
    FBackBuf.Canvas.Handle, Width-FSpeed,0, cmSrcCopy);
  BitBlt(FBackBuf.Canvas.Handle, FSpeed, 0, Width-FSpeed, Height,
    FBackBuf.Canvas.Handle, 0,0, cmSrcCopy);
  BitBlt(FBackBuf.Canvas.Handle, 0, 0, FSpeed, Height,
    TmpB.Canvas.Handle, 0,0, cmSrcCopy);
  FBackBuf.Canvas.UnLock;
 finally
  TmpB.Canvas.UnLock;
 end;//try..finally 
end;
 
function Tl3GradientWaitbar.GetActive: Boolean;
begin
 Result := FTimer.Enabled;
end;
 
procedure Tl3GradientWaitbar.ManualProgress(Progress: Integer);
begin
 TmpB.Canvas.Lock;
 try
  TmpB.Width  := Progress;
  TmpB.Height := Height;
  FBackBuf.Canvas.Lock;
  try
   BitBlt(TmpB.Canvas.Handle, 0, 0, Progress, Height,
     FBackBuf.Canvas.Handle, Width-Progress,0, cmSrcCopy);
   BitBlt(FBackBuf.Canvas.Handle, Progress, 0, Width-Progress, Height,
     FBackBuf.Canvas.Handle, 0,0, cmSrcCopy);
   BitBlt(FBackBuf.Canvas.Handle, 0, 0, Progress, Height,
     TmpB.Canvas.Handle, 0,0, cmSrcCopy);
  finally
   FBackBuf.Canvas.UnLock;
  end;//try..finally
 finally
  TmpB.Canvas.UnLock;
 end;//try..finally
 DoPaint;
end;
 
procedure Tl3GradientWaitbar.SetActive(const Value: Boolean);
begin
 FTimer.Enabled := Value;
end;
 
procedure Tl3GradientWaitbar.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
 Assert(Self <> nil);
 if (Self = nil) then
  Exit;
 FLeft := ALeft;
 FTop  := ATop;
 if (AWidth <> FWidth) or (AHeight <> FHeight) then
 begin
  FWidth := AWidth;
  FHeight := AHeight;
  BuildBackBuffer;
 end;
end;
 
procedure Tl3GradientWaitbar.SetColor1(const Value: TColor);
begin
 if FColor1 <> Value then
 begin
  FColor1 := Value;
  BuildBackBuffer;
 end;
end;
 
procedure Tl3GradientWaitbar.SetColor2(const Value: TColor);
begin
 if FColor2 <> Value then
 begin
  FColor2 := Value;
  BuildBackBuffer;
 end;
end;
 
procedure Tl3GradientWaitbar.DoPaint;
begin
 if Assigned(FOnPaint) then
  FOnPaint(Self);
end;
 
end.

#847. Let’s create tests for script words

Original in Russian: http://programmingmindstream.blogspot.ru/2015/09/blog-post.html
The previous series was here – Introduction. Let’s create tests for script words.

I separated “words in dictionary” from tests there.

Now I will put them together:

string.ms.dict:

// string.ms.dict.web
 
USES
 Documentation.ms.dict
 params.ms.dict
 core.ms.dict
 map.ms.dict
 Testing.ms.dict
 io.ms.dict
;
 
: (string)
 ^ IN aValue
 aValue DO ToPrintable
; // (string)
 
STRING FUNCTION string:CatWihAny
 STRING IN aString
 IN aValue
 aString aValue ToPrintable Cat =: Result
; // string:CatWihAny
 
STRING FUNCTION any:Cat
 ARRAY IN anArray
 anArray .map> ToPrintable strings:Cat =: Result
; // any:Cat
 
TestsFor any:Cat
 Test T1 [ 'A' 123 'B' ] any:Cat Print ;
 Test T2 [ 'A' 124 'B' ] any:Cat Print ;
; // TestsFor any:Cat
 
STRING FUNCTION (+)?
 STRING in aPrefix
 STRING right aSuffix
 %SUMMARY 'If aSuffix is not empty, it returns the sum of aPrefix and aSuffix, otherwise or returns a blank string' ;
 Result := ''
 STRING VAR l_Suffix
 aSuffix =: l_Suffix
 if ( l_Suffix =/= '' ) then
  ( aPrefix l_Suffix Cat =: Result )
; // (+)?
 
TestsFor (+)?
 Test T1 '' (+)? 'B' Print ;
 Test T2 'A' (+)? 'B' Print ;
 Test T3 'A' (+)? '' Print ;
 Test T4 'A' (+)? 'D' Print ;
 Test T5 'A' (+)? '123' Print ;
; // TestsFor (+)?
 
STRING FUNCTION ?(+)
 STRING in aPrefix
 STRING right aSuffix
 %SUMMARY 'If aPrefix is not empty, it returns the sum of aPrefix and aSuffix, otherwise or returns a blank string ' ;
 Result := ''
 if ( aPrefix =/= '' ) then
  ( aPrefix aSuffix Cat =: Result )
; // ?(+)
 
TestsFor ?(+)
 Test T1 '' ?(+) 'B' Print ;
 Test T2 'A' ?(+) 'B' Print ;
 Test T3 'A' ?(+) '' Print ;
; // TestsFor ?(+)
 
STRING FUNCTION strings:CatSep>
 STRING right aSep
 ARRAY right aValues
 aValues aSep strings:CatSep =: Result
; // strings:CatSep>
 
TestsFor strings:CatSep>
 Test T1 strings:CatSep> ' ' [ 'A' 'B' ] Print ;
 Test T2 strings:CatSep> ' ' [ 'A ' 'B' ] Print ;
 Test T3 strings:CatSep> ' ' [ 'A ' ' B' ] Print ;
 Test T4 strings:CatSep> ' ' [ 'A' ' B' ] Print ;
 Test T5 strings:CatSep> ' ' [ '' 'B' ] Print ;
 Test T6 strings:CatSep> ' ' [ 'A' '' ] Print ;
; // TestsFor strings:CatSep>
  
WordAlias CatSep> strings:CatSep>

String.ms.script:

USES
 Documentation.ms.dict
 string.ms.dict
 Testing.ms.dict
;
 
RunTests (+)?
 %REMARK 'Launch the “standard tests” for the word (+)?'
RunTests ?(+)
 %REMARK 'Launch the “standard tests” for the word ? (+)'
RunTests strings:CatSep>
 %REMARK 'Launch the “standard tests” for the word strings:CatSep>'
RunTests any:Cat
 %REMARK ' Launch the “standard tests” for the word any:Cat'

The result of the tests:

String.ms.script.out

Testing: (+)?
T1
B
T2
AB
T3
 
T4
AD
T5
A123
Testing end: (+)?
------------------
Testing: ?(+)
T1
 
T2
AB
T3
A
Testing end: ?(+)
------------------
Testing: strings:CatSep>
T1
A B
T2
A B
T3
A  B
T4
A  B
T5
B
T6
A
Testing end: strings:CatSep>
------------------
Testing: any:Cat
T1
A123B
T2
A124B
Testing end: any:Cat
------------------

In order to put it together I introduced the word TestsFor and RunTests.

TestsFor – determines tests for the word.
RunTests – launches tests for the word.

These look as follows:

Testing.ms.dict:

// Testing.ms.dict
 
USES
 axiom_push.ms.dict
 macro.ms.dict
 params.ms.dict
 io.ms.dict
 EngineTypes.ms.dict
 Documentation.ms.dict
;
 
CONST cTests 'Tests:'
 
MACRO TestsFor
 ENGINE_WORD RIGHT LINK IN aName
  %REMARK 'aName link to the word at the right of TestsFor'
 %SUMMARY 'Determines the tests set for word aName' ;
 
 axiom:PushSymbol VOID
 axiom:PushSymbol axiom:operator
 cTests aName |N Cat Ctx:Parser:PushSymbol
; // TestsFor
 
PRIVATE PROCEDURE DoRunTestsFor
 STRING IN aTestedWordName
 ENGINE_WORD IN aTestsHolder
 %SUMMARY 'Executes tests for aTestsHolder' ;
 
 [ 'Testing: ' aTestedWordName ] strings:Cat Print
 aTestsHolder MembersIterator ==> (
  IN aTest
   %REMARK 'aTest – embedded element aTestsHolder'
  if ( ( aTest %ST |N ) = ( NameOf Test ) ) then
   %REMARK '- filtrates tests only.'
  begin
   aTest |N Print
    %REMARK 'Print the test name'
   aTest DO
    %REMARK 'Launch the test'
  end // ( ( aTest %ST |N ) = 'Test' )
 )
 [ 'Testing end: ' aTestedWordName ] strings:Cat Print
 '------------------' Print
; // DoRunTestsFor
 
MACRO RunTests
 ENGINE_WORD RIGHT LINK IN aName
  %REMARK 'aName link to the word at the right of RunTests'
 %SUMMARY 'Executes tests for aName' ;
 
 STRING VAR l_Name
 aName |N >>> l_Name
 STRING VAR l_TestsHolderName
 cTests l_Name Cat >>> l_TestsHolderName
 
 l_Name Ctx:Parser:PushString
 axiom:PushSymbol @
 l_TestsHolderName Ctx:Parser:PushSymbol
 axiom:PushSymbol DoRunTestsFor
; // RunTests

Nothing “exorbitant”.

The test just “moved” closer to the code for testing.

Yet, this is actually not so bad.

It is sort of “encapsulation of code and its contracts”.

The code and the tests are together now.

After all, tests are “the contracts to the code” in some way.

They work when “static typing” fails.

I’ll remind you the right words of Roman Yankovsky:

"To some extend, unit-tests and static typing solve the same tasks. This is probably the reason why tests were adopted in areas where static typing is not available.

What is static typing? This is the code requirements description the conformity to which the code is checked by the compiler. What are unit tests? Again, these are the requirements the code should confirm with.

This understanding of unit tests eliminates the antilogies. What is the starting point of developing on languages with static typing? Types description! What is the starting point of developing on TDD? Tests writing! Thus, architecture first is suitable in both cases.

It looks not obvious and confusing, but this is due to underdeveloped means of language we use. However, the way how we describe the requirements to the input and output data of some function makes no difference, since we only describe the TYPE."

http://programmingmindstream.blogspot.ru/2013/11/tdd_28.html?showComment=1386063749826#c6337489882377572276

Actually, the idea was developed there.

The idea is not new.

Barbara Liskov developed a similar one.

In one separate case I “lived the idea out”.

In closing, I’ll refer to a simple thought I like.

If the code may be tested easily, it has to be tested.

It is great when tests are put together with the code or encapsulated in it.

In this case tests are not only used for checking, but also as examples of code use as well as the real demonstration of boundary conditions.

If you make “one more step”, than you will see the base requirements in the combination of code, tests and specification.

Let me also recommend you a book by Barbara Liskov and John Guttag – “Abstraction and Specification in Program Development”.

This is one of my favorite books.

#846. Introduction. Let’s create tests for script words

Original in Russian: http://programmingmindstream.blogspot.ru/2015/08/blog-post_70.html
The previous series was here – Code generation. Extracting the specific model and specific templates to external dictionaries.

Let’s take our mind off the code generation and discuss the tests.

The idea was raised here - ToDo. Tests for script words.

Now I have developed this idea.

I’ll try to tell you how it was done.

Let us have the functions dictionary:

string.ms.dict

USES
 Documentation.ms.dict
 params.ms.dict
 core.ms.dict
 map.ms.dict
;
 
: (string)
 ^ IN aValue
 aValue DO ToPrintable
; // (string)
 
STRING FUNCTION string:CatWihAny
 STRING IN aString
 IN aValue
 aString aValue ToPrintable Cat =: Result
; // string:CatWihAny
 
STRING FUNCTION any:Cat
 ARRAY IN anArray
 anArray .map> ToPrintable strings:Cat =: Result
; // any:Cat
 
STRING FUNCTION (+)?
 STRING in aPrefix
 STRING right aSuffix
 %SUMMARY 'If aSuffix is not empty, it returns the sum of aPrefix and aSuffix, otherwise or returns a blank string ' ;
 Result := ''
 STRING VAR l_Suffix
 aSuffix =: l_Suffix
 if ( l_Suffix =/= '' ) then
  ( aPrefix l_Suffix Cat =: Result )
; // (+)?
 
STRING FUNCTION ?(+)
 STRING in aPrefix
 STRING right aSuffix
 %SUMMARY 'If aPrefix is not empty, it returns the sum of aPrefix and aSuffix, otherwise or returns a blank string ' ;
 Result := ''
 if ( aPrefix =/= '' ) then
  ( aPrefix aSuffix Cat =: Result )
; // ?(+)
 
STRING FUNCTION strings:CatSep>
 STRING right aSep
 ARRAY right aValues
 aValues aSep strings:CatSep =: Result
; // strings:CatSep>
 
WordAlias CatSep> strings:CatSep>

The tests for it:

String.ms.script

USES
 string.ms.dict
;
 
'' (+)? 'B' Print
'A' (+)? 'B' Print
'A' (+)? '' Print
'------------------' Print
 
'' ?(+) 'B' Print
'A' ?(+) 'B' Print
'A' ?(+) '' Print
'------------------' Print
 
strings:CatSep> ' ' [ 'A' 'B' ] Print
strings:CatSep> ' ' [ 'A ' 'B' ] Print
strings:CatSep> ' ' [ 'A ' ' B' ] Print
strings:CatSep> ' ' [ 'A' ' B' ] Print
strings:CatSep> ' ' [ '' 'B' ] Print
strings:CatSep> ' ' [ 'A' '' ] Print
'------------------' Print
 
[ 'A' 123 'B' ] any:Cat Print
'------------------' Print

The results of the tests:

B
AB
 
------------------
 
AB
A
------------------
A B
A B
A  B
A  B
B
A
------------------
A123B
------------------

More or less we’ve tested the functions.

Various code areas have been covered.

Not so bad, but let’s move on.

We can put tests “inside” the functions and launch them from outside automatically.

Later I will try to tell how to do it.

#845. ToDo. Tests for script words

Original in Russian: http://programmingmindstream.blogspot.ru/2015/06/todo_27.html
Something like this:

operator EVAL
// - operator to calculate the value of aWhat
 RIGHT IN aWhat
 aWhat |^ DO
; // EVAL 
 
 EVAL %Tests 'tests for operator EVAL'
 (
 // - tests for operator EVAL
  : T1
   EVAL 1 PrintStack
  ; // T1
 
  : T2
   EVAL '2' PrintStack
  ; // T2
 
  : T3
   VAR X
   X := 1
   EVAL X PrintStack
  ; // T3
 
  : T4
   EVAL ( 123 456 ) PrintStack
  ; // T4
 
  : T5
   EVAL ( 123 456 + ) PrintStack
  ; // T5
 
  : T6
   EVAL ( 1 2 + ) == 3 ASSERTS
  ; // T6
 
  : T7
   EVAL ( 'A' 'B' Cat ) == 'AB' ASSERTS
  ; // T7
 
 ) // EVAL %Tests

We get the tests subtree in DUnit:

EVAL are the tests for operator EVAL
 T1
 T2
 T3
 T4
 T5
 T6
 T7

My “paranoia”:

+ %Tests 'Tests for operator +'
(
 : T1
  1 2 + == 3 ASSERT
 ; // T1
 
 : T2
  1 -2 + == -1 ASSERT
 ; // T2
 
 : T3
  VAR A A := 1
  VAR B B := 2
  A B + == 3 ASSERT
 ; // T3
 
 : T4
  VAR A A := 1
  VAR B B := 2
  VAR C C := 3
  A B + == C ASSERT
 ; // T4
 
) // + %Tests

We get the tests subtree in DUnit:

+ - Tests for operator +
 T1
 T2
 T3
 T4

ARRAY %Tests ' Tests for operator ARRAY'
(
  : T1
   [ ] PrintStack
  ; // T1
 
  : T2
   [ 1 2 ] PrintStack
  ; // T2
 
  : T3
   [ 1 2 3 ] PrintStack
  ; // T3
 
  : T4
   [ 1 2 3 ] Revert PrintStack
  ; // T4
 
  : T5
   [ 1 2 2 3 1 3 5 6 7 ] RemoveDup PrintStack
  ; // T5
 
  : T6
   ARRAY VAR A
   A := [ 1 2 2 3 1 3 5 6 7 ] 
   A RemoveDup PrintStack
  ; // T6
 
  : T7
   ARRAY VAR A
   A := [ 1 2 2 3 1 3 5 6 7 ] 
   A RemoveDup ==> Print
  ; // T7
 
) // ARRAY %Tests

I hope you understand my idea.

We have the functionality and the “atomic tests” for it.

I believe this is not a new idea.

As for me, it is fun. The key point is that I’ve almost implemented it, I only need to register it in DUnit.

I need to register it in ANY application that contains these words and DUnit and I will get a separate branch of tests for the words.

%Tests looks as follows:
VOID operator %Tests
 LEFT IN aWord
 RIGHT IN aDoc
 RIGHT IN aTests
 
 VAR l_Group
 
 DUnit:AddTestsGroup aWord aDoc >>> l_Group
 
 aCode MembersIterator ==> ( IN aTest
  l_Group DUnit:TestsGroup:AddTest aTest
 )
; // %Tests

We can go further:

'TControl' RTTIObject %Tests 'Tests for class TControl'
(
 : T1
  OBJECT VAR l_Control
  'TControl' RTTIClass 'Create' RTTIConstructor RTTIExecute [ nil { - This is the Owner} ] >>> l_Control
  CONST cName 'MyControl'
  'TControl' RTTIClass 'Name' RTTIProperty l_Control RTTISet [ cName { - This is the Name value} ]
  STRING VAR l_Name
  'TControl' RTTIClass 'Name' RTTIProperty l_Control RTTIGet >>> l_Name
  l_Name == cName ASSERT
 ; // T1
)