////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2026 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// Elementary drawing utilites.                                               //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20011104 - Creation                                                        //
// 20021220 - RefreshEditAttributes,GetFontDescription                        //
// 20030326 - Struggle for safety (add some try/except checks)...             //
// 20050222 - ConvertBmpToBlackAndWhite                                       //
// 20061226 - GetFontAsText                                                   //
// 20070716 - SmartBitmap.Title                                               //
// 20160426 - AvailFontCharsets,AvailFontPitches,CharsetToString,             //
//            PitchToString                                                   //
// 20170301 - TSmartDrawer - increased buffer size, see SmartDrawerListSize   //
// 20171007 - DrawEllipse, DrawEllipsePie                                     //
// 20171027 - DrawEllipseArc,DrawEllipseChord,DrawPolyLine,DrawPolygon,       //
//            DrawPolyBezier                                                  //
// 20180131 - ReadBufferedFont,ReadIniFileFont,...,StringToFontStyles         //
// 20190914 - CreateBarBmp,CreateLedBmp                                       //
// 20190914 - FindFontNameByAlias                                             //
// 20210324 - EvalTextSize                                                    //
// 20230810 - Modified for FPC (A.K.)                                         //
// 20240613 - ConvertBmpToBlackAndWhite modified for FPC                      //
// 20251205 - TSmartBitmap: TBitmap buffer instead of TMemoryStream (faster)  //
// 20251226 - TSmartBitmap.CopyBitmapTo                                       //
////////////////////////////////////////////////////////////////////////////////

unit _crw_eldraw; // elementary drawing

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

interface

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 sysutils, classes, math, graphics, buttons,
 controls, forms, dialogs, actnlist, stdctrls,
 extctrls, comctrls, checklst, types, lcltype,
 {$IFDEF WINDOWS} RichEdit, {$ENDIF}
 _crw_alloc, _crw_fpu, _crw_ef, _crw_fifo, _crw_str, _crw_snd, _crw_fio,
 _crw_plut, _crw_colors, _crw_guiutils, _crw_fonts, _crw_hl,
 _crw_bmpcache;

 {
 ***************************************************
 SmartUpdate(...) change a property and updates some
 VCL object with some checking for safety and speed.
 ***************************************************
 }
procedure SmartUpdate(aLabel:TLabel; const aCaption:LongString); overload;
procedure SmartUpdate(aPanel:TPanel; const aCaption:LongString); overload;
procedure SmartUpdate(aGroupBox:TGroupBox; const aCaption:LongString); overload;
procedure SmartUpdate(aRadioGroup:TRadioGroup; const aCaption:LongString); overload;
procedure SmartUpdate(aEdit:TEdit; const aText:LongString); overload;
procedure SmartUpdate(aMemo:TMemo; const aText:LongString); overload;
procedure SmartUpdate(aButton:TButton; const aCaption:LongString); overload;
procedure SmartUpdate(aListBox:TListBox; const aItems:LongString); overload;
procedure SmartUpdate(aListBox:TCheckListBox; const aItems:LongString); overload;
procedure SmartUpdate(aCheckBox:TCheckBox; const aCaption:LongString); overload;
procedure SmartUpdate(aStatusBar:TStatusBar; aPanel:Integer; const aText:LongString); overload;
procedure SmartUpdate(aAction:TAction; const aCaption:LongString); overload;
procedure SmartUpdate(aBitBtn:TBitBtn; const aCaption:LongString); overload;

procedure SmartFocus(Control:TWinControl);
procedure CheckWithoutClick(CheckBox:TCheckBox; Checked:Boolean);
procedure RefreshEditAttributes(Edit:TCustomEdit; SEL:Boolean; SCF:Integer);
function  GetFontDescription(Font:TFont):LongString;

 {
 ****************************************
 Kill for some standard graphical classes
 ****************************************
 }
procedure Kill(var TheObject:TBitmap); overload;
procedure Kill(var TheObject:TForm); overload;

 {
 ****************
 Working with Pen
 ****************
 }
type
 TPenParams=packed record
  Color : TColor;
  Style : TPenStyle;
  Mode  : TPenMode;
  Width : Integer;
 end;

procedure SavePen(Pen:TPen; out PenParams:TPenParams);
procedure RestorePen(Pen:TPen; const PenParams:TPenParams);
procedure SetPen(Pen   : TPen;
                 Color : TColor    = clBlack;
                 Style : TPenStyle = psSolid;
                 Mode  : TPenMode  = pmCopy;
                 Width : Integer   = 1);

 {
 ******************
 Working with Brush
 ******************
 }
type
 TBrushParams = packed record
  Color : TColor;
  Style : TBrushStyle;
 end;

procedure SaveBrush(Brush:TBrush; out BrushParams:TBrushParams);
procedure RestoreBrush(Brush:TBrush; const BrushParams:TBrushParams);
procedure SetBrush(Brush : TBrush;
                   Color : TColor      = clBlack;
                   Style : TBrushStyle = bsSolid);

 {
 *****************
 Working with Font
 *****************
 }
type
 PFontParams=^TFontParams;
 TFontParams=packed record
  CharSet : TFontCharSet;
  Color   : TColor;
  Height  : Integer;
  Name    : PureString;
  Pitch   : TFontPitch;
  Style   : TFontStyles;
 end;

const
 stdFontCharSet = RUSSIAN_CHARSET;
 stdFontColor   = clBlack;
 stdFontBack    = clWhite;
 stdFontHeight  = -13;
 stdFontName    = 'PT Mono';
 stdFontPitch   = fpFixed;
 stdFontStyle   = [];
 StandardFont : TFontParams = (
  CharSet : stdFontCharSet;
  Color   : stdFontColor;
  Height  : stdFontHeight;
  Name    : stdFontName;
  Pitch   : stdFontPitch;
  Style   : stdFontStyle;
 );
 DefaultSansFont : TFontParams = (
  CharSet : stdFontCharSet;
  Color   : stdFontColor;
  Height  : stdFontHeight;
  Name    : 'PT Sans';
  Pitch   : stdFontPitch;
  Style   : stdFontStyle;
 );
 DefaultSansNarrowFont : TFontParams = (
  CharSet : stdFontCharSet;
  Color   : stdFontColor;
  Height  : stdFontHeight;
  Name    : 'PT Sans Narrow';
  Pitch   : stdFontPitch;
  Style   : stdFontStyle;
 );
 AvailFontCharsets = [ANSI_CHARSET, DEFAULT_CHARSET, SYMBOL_CHARSET, MAC_CHARSET,
  SHIFTJIS_CHARSET, HANGEUL_CHARSET, JOHAB_CHARSET, GB2312_CHARSET,
  CHINESEBIG5_CHARSET, GREEK_CHARSET, TURKISH_CHARSET, HEBREW_CHARSET,
  ARABIC_CHARSET, BALTIC_CHARSET, RUSSIAN_CHARSET, THAI_CHARSET,
  EASTEUROPE_CHARSET, OEM_CHARSET];
 AvailFontPitches = [DEFAULT_PITCH, FIXED_PITCH, VARIABLE_PITCH];

procedure SaveFont(Source:TFont; out FontParams:TFontParams); overload;
procedure RestoreFont(Dest:TFont; const FontParams:TFontParams); overload;
procedure SetFont(Dest    : TFont;
                  CharSet : TFontCharSet = stdFontCharSet;
                  Color   : TColor       = stdFontColor;
                  Height  : Integer      = stdFontHeight;
            const Name    : LongString   = stdFontName;
                  Pitch   : TFontPitch   = stdFontPitch;
            const Style   : TFontStyles  = stdFontStyle); overload;
procedure SetStandardFont(Form:TForm);
procedure InitFontNameByAliasHashList;
procedure FreeFontNameByAliasHashList;
function  FindFontNameByAlias(const FontAlias:LongString; const Default:LongString=''):LongString;
function  ReadBufferedFont(out Font:TFontParams; Buffer:LongString; Replacement:Boolean; const Default:TFontParams):Boolean;
function  ReadIniFileFont(var Font:TFontParams; const IniFile,Section:LongString):Boolean;
function  GetFontAsText(const Font:TFontParams):LongString; overload;
function  GetFontAsText(const Font:TFont):LongString; overload;

const DefaultScreenPPI : Integer = 96;
function  UsesScreenPixelsPerInch:Integer;
function  FontSizeToHeight(Size:Integer; PPI:Integer=0):Integer;
function  FontHeightToSize(Height:Integer; PPI:Integer=0):Integer;

function  EvalTextSize(const aFont:TFont; aText:LongString):TSize; overload;
function  EvalTextSize(const aFont:TFontParams; aText:LongString):TSize; overload;

function  CharsetToString(Charset:TFontCharSet; Suffix:LongString='_CHARSET'):LongString;
function  PitchToString(Pitch:TFontPitch; Suffix:LongString='_PITCH'):LongString; overload;
function  PitchToString(Pitch:Integer):LongString; overload;
function  FontStylesToString(const FontStyles:TFontStyles):LongString;
function  StringToCharset(S:LongString; Default:TFontCharSet):TFontCharSet;
function  StringToPitch(S:LongString; Default:TFontPitch):TFontPitch;
function  StringToFontStyles(S:LongString; Default:TFontStyles):TFontStyles;

 {
 *********************
 Draw lines and arrows
 *********************
 }
procedure DrawLine(Canvas   : TCanvas;
             const Start    : TPoint2I;
             const Stop     : TPoint2I;
                   Color    : TColor    = clBlack;
                   Style    : TPenStyle = psSolid;
                   Mode     : TPenMode  = pmCopy;
                   PenWidth : Integer   = 1);
procedure DrawPatternLine(Canvas   : TCanvas;
                    const Start    : TPoint2I;
                    const Stop     : TPoint2I;
                          Color    : TColor = clBlack;
                          Pattern  : Integer = $FFFFFF);
procedure DrawArrow(Canvas    : TCanvas;
              const e1        : TPoint2I;
              const e2        : TPoint2I;
                    Color     : TColor    = clBlack;
                    Style     : TPenStyle = psSolid;
                    Mode      : TPenMode  = pmCopy;
                    PenWidth  : Integer   = 1;
                    d1        : Integer   = 3;
                    d2        : Integer   = 3);
procedure DrawPointMarker(Canvas : TCanvas;
                    const Where  : TPoint2I;
                          Color  : TColor = clBlack;
                          Style  : Byte   = 0);
procedure DrawLineMarker(Canvas : TCanvas;
                   const Start  : TPoint2I;
                   const Stop   : TPoint2I;
                         Color  : TColor = clBlack;
                         Style  : Byte   = 0);
const
 LinePatternTable : array[0..15] of Integer =
 ($000000, { %000000000000000000000000 - 0  psClear}
  $FFFFFF, { %111111111111111111111111 - 1  psSolid}
  $AAAAAA, { %101010101010101010101010 - 2  User}
  $DDDDDD, { %111011101110111011101110 - 3  User}
  $CCCCCC, { %110011001100110011001100 - 4  User}
  $888888, { %100010001000100010001000 - 5  User}
  $808080, { %100000001000000010000000 - 6  User}
  $800000, { %100000000000000000000000 - 7  User}
  $F0F0F0, { %111100001111000011110000 - 8  User}
  $FF00F0, { %111111110000000011110000 - 9  User}
  $FFF000, { %111111111111000000000000 - 10 User}
  $FFFFC0, { %111111111111111111000000 - 11 psDash}
  $E38E38, { %111000111000111000111000 - 12 psDot}
  $FF81C0, { %111111111000000111000000 - 13 psDashDot}
  $FF8E38, { %111111111000111000111000 - 14 psDashDotDot}
  $FF0FF0);{ %111111110000111111110000 - 15 User}

 {
 ************************
 Draw bars and rectangles
 ************************
 }
procedure DrawBar(Canvas : TCanvas;
            const Rect   : TRect2I;
                  Color  : TColor      = clBlack;
                  Style  : TBrushStyle = bsSolid);
procedure DrawRect(Canvas   : TCanvas;
             const Rect     : TRect2I;
                   Color    : TColor    = clBlack;
                   Style    : TPenStyle = psSolid;
                   Mode     : TPenMode  = pmCopy;
                   PenWidth : Integer   = 1);
procedure DrawCustomRect(Canvas     : TCanvas;
                   const Rect       : TRect2I;
                         PenColor   : TColor      = clBlack;
                         PenStyle   : TPenStyle   = psSolid;
                         PenMode    : TPenMode    = pmCopy;
                         PenWidth   : Integer     = 1;
                         BrushColor : TColor      = clBlack;
                         BrushStyle : TBrushStyle = bsClear);
procedure DrawRoundRect(Canvas     : TCanvas;
                  const Rect       : TRect2I;
                  const Rounded    : TPoint2I;
                        PenColor   : TColor      = clBlack;
                        PenStyle   : TPenStyle   = psSolid;
                        PenMode    : TPenMode    = pmCopy;
                        PenWidth   : Integer     = 1;
                        BrushColor : TColor      = clBlack;
                        BrushStyle : TBrushStyle = bsClear);
procedure DrawEllipse(Canvas     : TCanvas;
                const Rect       : TRect2I;
                      PenColor   : TColor      = clBlack;
                      PenStyle   : TPenStyle   = psSolid;
                      PenMode    : TPenMode    = pmCopy;
                      PenWidth   : Integer     = 1;
                      BrushColor : TColor      = clBlack;
                      BrushStyle : TBrushStyle = bsClear);
procedure DrawEllipsePie(Canvas     : TCanvas;
                   const Rect       : TRect2I;
                   const PieRect    : TRect2I;
                         PenColor   : TColor      = clBlack;
                         PenStyle   : TPenStyle   = psSolid;
                         PenMode    : TPenMode    = pmCopy;
                         PenWidth   : Integer     = 1;
                         BrushColor : TColor      = clBlack;
                         BrushStyle : TBrushStyle = bsClear);
procedure DrawEllipseArc(Canvas     : TCanvas;
                   const Rect       : TRect2I;
                   const ArcRect    : TRect2I;
                         PenColor   : TColor      = clBlack;
                         PenStyle   : TPenStyle   = psSolid;
                         PenMode    : TPenMode    = pmCopy;
                         PenWidth   : Integer     = 1);
procedure DrawEllipseChord(Canvas     : TCanvas;
                     const Rect       : TRect2I;
                     const ChordRect  : TRect2I;
                           PenColor   : TColor      = clBlack;
                           PenStyle   : TPenStyle   = psSolid;
                           PenMode    : TPenMode    = pmCopy;
                           PenWidth   : Integer     = 1;
                           BrushColor : TColor      = clBlack;
                           BrushStyle : TBrushStyle = bsClear);
procedure DrawPolyLine(Canvas     : TCanvas;
                 const Points     : array of TPoint;
                       PenColor   : TColor      = clBlack;
                       PenStyle   : TPenStyle   = psSolid;
                       PenMode    : TPenMode    = pmCopy;
                       PenWidth   : Integer     = 1);
procedure DrawPolyBezier(Canvas     : TCanvas;
                   const Points     : array of TPoint;
                         PenColor   : TColor      = clBlack;
                         PenStyle   : TPenStyle   = psSolid;
                         PenMode    : TPenMode    = pmCopy;
                         PenWidth   : Integer     = 1);
procedure DrawPolygon(Canvas     : TCanvas;
                const Points     : array of TPoint;
                      PenColor   : TColor      = clBlack;
                      PenStyle   : TPenStyle   = psSolid;
                      PenMode    : TPenMode    = pmCopy;
                      PenWidth   : Integer     = 1;
                      BrushColor : TColor      = clBlack;
                      BrushStyle : TBrushStyle = bsClear);
procedure ClearClientArea(Form:TForm);

 {
 *********
 Draw text
 *********
 }
procedure DrawText(Canvas : TCanvas;
             const Where  : TPoint2I;
             const Msg    : LongString;
                   Color  : TColor = clBlack;
                   Back   : TColor = clWhite;
                   aBrush : TBrushStyle = bsSolid);
function CreateTextBitmap(const Msg         : LongString;
                                FontCharSet : TFontCharSet = stdFontCharSet;
                                FontColor   : TColor       = stdFontColor;
                                FontHeight  : Integer      = stdFontHeight;
                          const FontName    : LongString   = stdFontName;
                                FontPitch   : TFontPitch   = stdFontPitch;
                                FontStyle   : TFontStyles  = stdFontStyle;
                                BackColor   : TColor       = stdFontBack):TBitmap;

function CreateBarBmp(BarWidth,BarHeight,ColorDepth,FillColor:Integer):TBitmap;

function CreateLedBmp(TextWidth,FontSize,ColorDepth,FillColor:Integer; const FontName:LongString;
                      Caption:LongString=''; TextColor:TColor=clNone; FontStyle:TFontStyles=[];
                      xSpace:Integer=0; ySpace:Integer=0):TBitmap;

 {
 *******************************************************************************
 Smart drawing usefull when You need to plot some messages without
 intersections, for example, when draws grid marks of 2D or 3D graphics plot.
 *******************************************************************************
 }
const
 SmartDrawerListSize = 1024;
type
 TSmartDrawer = class(TMasterObject)
 private
  myCount : Integer;
  myList  : packed array[0..SmartDrawerListSize-1] of TRect2I;
 public
  constructor Create;
  destructor  Destroy; override;
  procedure   StartDraw;
  procedure   StopDraw;
  function    NoIntersections(const R:TRect2I):Boolean;
  function    LockRect(const R:TRect2I):Boolean;
  function    LastRect:TRect2I;
  function    DrawText(Canvas : TCanvas;
                 const Where  : TPoint2I;
                 const Msg    : LongString;
                       Color  : TColor  = clBlack;
                       Back   : TColor  = clWhite;
                       SpaceX : Integer = 0;
                       SpaceY : Integer = 0):Boolean;
  function    DrawBitmap(Canvas : TCanvas;
                   const Where  : TPoint2I;
                         Bitmap : TBitmap):Boolean;
 end;

function  NewSmartDrawer:TSmartDrawer;
procedure Kill(var TheObject:TSmartDrawer); overload;

 {
 *******************************************************************************
 TXorSelector object usefull to organize inverted color selection dialogs.
 *******************************************************************************
 }
type
 TXorSelectorMode = (sm_Rect, sm_Line, sm_ArrowFrom, sm_ArrowTo, sm_BigCross,
                     sm_HorzLine, sm_VertLine);
 TXorSelector=class(TMasterObject)
 private
  myStart  : Boolean;
  myRect   : TRect2I;
  myMode   : TXorSelectorMode;
  myWidth  : Integer;
  myArrSiz : TPoint2I;
  function   GetIsStart:Boolean;
  function   GetSelection:TRect2I;
  function   GetMode:TXorSelectorMode;
  procedure  SetMode(m:TXorSelectorMode);
  function   GetWidth:Integer;
  procedure  SetWidth(w:Integer);
  function   GetArrowSize:TPoint2I;
  procedure  SetArrowSize(const s:TPoint2I);
  procedure  Plot(Canvas:TCanvas; const r:TRect2I);
 public
  constructor Create(aMode  : TXorSelectorMode = sm_Rect;
                     aWidth : Integer = 1);
  destructor  Destroy; override;
 public
  function    Start(Canvas:TCanvas; const At:TPoint2I):Boolean;
  function    StartXY(Canvas:TCanvas; x,y:Integer):Boolean;
  function    Replace(Canvas:TCanvas; const At:TPoint2I):Boolean;
  function    ReplaceXY(Canvas:TCanvas; x,y:Integer):Boolean;
  function    Stop(Canvas:TCanvas):Boolean;
 public
  property    IsStart   : Boolean          read GetIsStart;
  property    Selection : TRect2I          read GetSelection;
  property    Mode      : TXorSelectorMode read GetMode      write SetMode;
  property    Width     : Integer          read GetWidth     write SetWidth;
  property    ArrowSize : TPoint2I         read GetArrowSize write SetArrowSize;
 end;

function  NewXorSelector:TXorSelector;
procedure Kill(var TheObject:TXorSelector); overload;

 {
 *******************************************************************************
 TSmartBitmap uses to keep TBitmap object with addon metadata: Source,Title etc.
 *******************************************************************************
 }
type
 TSmartBitmap = class(TMasterObject)
 private
  myCacheBmp : TBitmap;
  myOwnedBmp : TBitmap;
  mySource   : LongString;
  myTitle    : LongString;
  myIdent    : Integer;
  myWidth    : Integer;
  myHeight   : Integer;
  function    CurrentBmp:TBitmap;
  function    GetSource:LongString;
  procedure   SetSource(const aSource:LongString);
  function    GetTitle:LongString;
  procedure   SetTitle(const aTitle:LongString);
  function    GetIdent:Integer;
  procedure   SetIdent(aIdent:Integer);
  function    GetWidth:Integer;
  function    GetHeight:Integer;
  procedure   KillBitmap;
  procedure   ClearLinks;
 protected
  function    CheckOk:Boolean; override;
 public
  constructor Create;
  destructor  Destroy; override;
  function    Clone:TSmartBitmap;
  procedure   Assign(Bitmap:TBitmap);
  procedure   LoadFromFile(const FileName:LongString; NoCache:Boolean=False);
  function    CopyBitmapTo(aTarget:TBitmap):Boolean;
  function    CreateBitmap:TBitmap;
  procedure   Draw(Canvas:TCanvas; X,Y:Integer);
  function    GetRect(X:Integer=0; Y:Integer=0):TRect2I;
  function    ExposedInsideOf(Canvas:TCanvas; X,Y:Integer):Boolean;
  function    HasBitmap:Boolean;
 public
  property    Source:LongString     read GetSource write SetSource;  {bitmap filename}
  property    Title:LongString      read GetTitle  write SetTitle;   {title text}
  property    Ident:Integer         read GetIdent  write SetIdent;   {any user identifier}
  property    Width:Integer         read GetWidth;
  property    Height:Integer        read GetHeight;
 end;

function NewSmartBitmap(const FileName : LongString = '';
                              Bitmap   : TBitmap    = nil;
                              Ident    : Integer    = 0;
                              Title    : LongString = '') : TSmartBitmap;
procedure Kill(var TheObject:TSmartBitmap); overload;

 {
 *******************************************************************************
 Convert color bitmap to black and white.
 White1, White2 is colors which should be white, all other colors will be black.
 Mode bits = 1:FastMode 2:ConvertToGrayscale
 *******************************************************************************
 }
function ConvertBmpToBlackAndWhite(Bmp:TBitmap; White1,White2:TColor; Mode:Integer=1):Boolean;

implementation

 {
 ********************
 SmartUpdate routines
 ********************
 }
procedure SmartUpdate(aLabel:TLabel; const aCaption:LongString); overload;
begin
 if Assigned(aLabel) then
 if (aLabel.Caption<>aCaption) then begin
  aLabel.Caption:=aCaption;
  aLabel.Update;
 end;
end;

procedure SmartUpdate(aPanel:TPanel; const aCaption:LongString); overload;
begin
 if Assigned(aPanel) then
 if (aPanel.Caption<>aCaption) then begin
  aPanel.Caption:=aCaption;
  aPanel.Update;
 end;
end;

procedure SmartUpdate(aGroupBox:TGroupBox; const aCaption:LongString); overload;
begin
 if Assigned(aGroupBox) then
 if (aGroupBox.Caption<>aCaption) then begin
  aGroupBox.Caption:=aCaption;
  aGroupBox.Update;
 end;
end;

procedure SmartUpdate(aRadioGroup:TRadioGroup; const aCaption:LongString); overload;
begin
 if Assigned(aRadioGroup) then
 if (aRadioGroup.Caption<>aCaption) then begin
  aRadioGroup.Caption:=aCaption;
  aRadioGroup.Update;
 end;
end;

procedure SmartUpdate(aEdit:TEdit; const aText:LongString); overload;
begin
 if Assigned(aEdit) then
 if (aEdit.Text<>aText) then begin
  aEdit.Text:=aText;
  aEdit.Update;
 end;
end;

procedure SmartUpdate(aMemo:TMemo; const aText:LongString); overload;
begin
 if Assigned(aMemo) then
 if (aMemo.Text<>aText) then begin
  aMemo.Text:=aText;
  aMemo.Update;
 end;
end;

procedure SmartUpdate(aButton:TButton; const aCaption:LongString); overload;
begin
 if Assigned(aButton) then
 if (aButton.Caption<>aCaption) then begin
  aButton.Caption:=aCaption;
  aButton.Update;
 end;
end;

procedure SmartUpdate(aListBox:TListBox; const aItems:LongString); overload;
begin
 if Assigned(aListBox) then
 if (aListBox.Items.Text<>aItems) then begin
  aListBox.Items.Text:=aItems;
  aListBox.Update;
 end;
end;

procedure SmartUpdate(aListBox:TCheckListBox; const aItems:LongString); overload;
begin
 if Assigned(aListBox) then
 if (aListBox.Items.Text<>aItems) then begin
  aListBox.Items.Text:=aItems;
  aListBox.Update;
 end;
end;

procedure SmartUpdate(aCheckBox:TCheckBox; const aCaption:LongString); overload;
begin
 if Assigned(aCheckBox) then
 if (aCheckBox.Caption<>aCaption) then begin
  aCheckBox.Caption:=aCaption;
  aCheckBox.Update;
 end;
end;

procedure SmartUpdate(aStatusBar:TStatusBar; aPanel:Integer; const aText:LongString); overload;
begin
 if Assigned(aStatusBar) and (aPanel>=0) and (aPanel<aStatusBar.Panels.Count) then
 if (aStatusBar.Panels[aPanel].Text<>aText) then begin
  aStatusBar.Panels[aPanel].Text:=aText;
  aStatusBar.Update;
 end;
end;

procedure SmartUpdate(aAction:TAction; const aCaption:LongString); overload;
begin
 if Assigned(aAction) then
 if (aAction.Caption<>aCaption) then begin
  aAction.Caption:=aCaption;
  aAction.Update;
 end;
end;

procedure SmartUpdate(aBitBtn:TBitBtn; const aCaption:LongString); overload;
begin
 if Assigned(aBitBtn) then
 if (aBitBtn.Caption<>aCaption) then begin
  aBitBtn.Caption:=aCaption;
  aBitBtn.Update;
 end;
end;

procedure SmartFocus(Control:TWinControl);
begin
 try
  if (Control is TWinControl) then
  if Control.CanSetFocus and not Control.Focused
  then Control.SetFocus;
 except
  on E:Exception do BugReport(E,nil,'SmartFocus');
 end;
end;

procedure CheckWithoutClick(CheckBox:TCheckBox; Checked:Boolean);
var
 SaveOnClick:TNotifyEvent;
begin
 if (CheckBox is TCheckBox) then
 if (CheckBox.Checked<>Checked) then begin
  SaveOnClick:=CheckBox.OnClick;
  CheckBox.OnClick:=nil;
  CheckBox.Checked:=Checked;
  CheckBox.OnClick:=SaveOnClick;
 end;
end;

procedure RefreshEditAttributes(Edit:TCustomEdit; SEL:Boolean; SCF:Integer);
{$IFDEF WINDOWS}
var Format : TCharFormat;
{$ENDIF ~WINDOWS}
begin
 {$IFDEF WINDOWS}
 if (Edit is TCustomEdit) then with Edit do
 if HandleAllocated then begin
  SafeFillChar(Format,SizeOf(Format),0);
  Format.cbSize:=SizeOf(Format);
  SendMessage(Handle, EM_GETCHARFORMAT, WPARAM(SEL), LPARAM(PointerToPtrInt(@Format)));
  SendMessage(Handle, EM_SETCHARFORMAT, WPARAM(SCF), LPARAM(PointerToPtrInt(@Format)));
 end;
 {$ENDIF WINDOWS}
end;

function GetFontDescription(Font:TFont):LongString;
begin
 Result:='';
 if (Font is TFont) then begin
  Result:=Format('Font Charset = %s', [CharsetToString(Font.Charset,'')]) +EOL+
          Format('Font Color   = %s', [ColorToString(Font.Color)]) +EOL+
          Format('Font Height  = %d', [Font.Height])  +EOL+
          Format('Font Size    = %d', [Font.Size])    +EOL+
          Format('Font Name    = %s', [Font.Name])    +EOL+
          Format('Font Pitch   = %s', [PitchToString(Font.Pitch,'')])+EOL+
          Format('Font Style   = %s', [FontStylesToString(Font.Style)])+EOL;
 end;
end;

 {
 *************
 Kill routines
 *************
 }
procedure Kill(var TheObject:TBitmap); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E,nil,'Kill');
 end; 
end;

procedure Kill(var TheObject:TForm); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E,nil,'Kill');
 end; 
end;

 {
 ************
 Pen routines
 ************
 }
procedure SavePen(Pen:TPen; out PenParams:TPenParams);
begin
 with PenParams do
 if Assigned(Pen) then begin
  Color:=Pen.Color;
  Style:=Pen.Style;
  Mode :=Pen.Mode;
  Width:=Pen.Width;
 end else begin
  Color:=clNone;
  Style:=psSolid;
  Mode :=pmNop;
  Width:=0;
 end;
end;

procedure RestorePen(Pen:TPen; const PenParams:TPenParams);
begin
 with PenParams do
 if Assigned(Pen) then begin
  Pen.Color:=Color;
  Pen.Style:=Style;
  Pen.Mode :=Mode;
  Pen.Width:=Width;
 end;
end;

procedure SetPen(Pen   : TPen;
                 Color : TColor    = clBlack;
                 Style : TPenStyle = psSolid;
                 Mode  : TPenMode  = pmCopy;
                 Width : Integer   = 1);
begin
 if Assigned(Pen) then begin
  Pen.Color:=Color;
  Pen.Style:=Style;
  Pen.Mode:=Mode;
  Pen.Width:=Width;
 end;
end;

 {
 **************
 Brush routines
 **************
 }
procedure SaveBrush(Brush:TBrush; out BrushParams:TBrushParams);
begin
 with BrushParams do
 if Assigned(Brush) then begin
  Color:=Brush.Color;
  Style:=Brush.Style;
 end else begin
  Color:=clNone;
  Style:=bsSolid;
 end;
end;

procedure RestoreBrush(Brush:TBrush; const BrushParams:TBrushParams);
begin
 with BrushParams do
 if Assigned(Brush) then begin
  Brush.Color:=Color;
  Brush.Style:=Style;
 end;
end;

procedure SetBrush(Brush : TBrush;
                   Color : TColor      = clBlack;
                   Style : TBrushStyle = bsSolid);
begin
 if Assigned(Brush) then begin
  Brush.Color:=Color;
  Brush.Style:=Style;
 end;
end;

 {
 *************
 Font routines
 *************
 }
procedure SaveFont(Source:TFont; out FontParams:TFontParams); overload;
begin
 with FontParams do
 if Assigned(Source) then begin
  Color:=Source.Color;
  Name:=Source.Name;
  CharSet:=Source.CharSet;
  Style:=Source.Style;
  Height:=Source.Height;
  Pitch:=Source.Pitch;
 end else begin
  Color:=clNone;
  Name:='';
  CharSet:=0;
  Style:=[];
  Height:=0;
  Pitch:=fpDefault;
 end;
end;

procedure RestoreFont(Dest:TFont; const FontParams:TFontParams); overload;
begin
 with FontParams do
 if Assigned(Dest) then begin
  Dest.Color:=Color;
  Dest.Name:=Name;
  Dest.CharSet:=CharSet;
  Dest.Style:=Style;
  Dest.Height:=Height;
  Dest.Pitch:=Pitch;
 end;
end;

procedure SetFont(Dest    : TFont;
                  CharSet : TFontCharSet = stdFontCharSet;
                  Color   : TColor       = stdFontColor;
                  Height  : Integer      = stdFontHeight;
            const Name    : LongString   = stdFontName;
                  Pitch   : TFontPitch   = stdFontPitch;
            const Style   : TFontStyles  = stdFontStyle); overload;
begin
 if (Dest is TFont) then begin
  Dest.Color:=Color;
  Dest.Name:=Name;
  Dest.CharSet:=CharSet;
  Dest.Style:=Style;
  Dest.Height:=Height;
  Dest.Pitch:=Pitch;
 end;
end;

procedure SetStandardFont(Form:TForm);
begin
 if Assigned(Form) then
 RestoreFont(Form.Font,StandardFont);
end;

const
 FontAliasHashList : THashList = nil;

procedure InitFontNameByAliasHashList;
var i:Integer;
 procedure AddItem(s:LongString; const v:LongString);
 begin
  s:=SysUtils.Trim(s); if (s='') then exit; FontAliasHashList.KeyedParams[s]:=v;
  if Pos(' ',s)>0 then FontAliasHashList.KeyedParams[StringReplace(s,' ','',[rfReplaceAll])]:=v;
 end;
begin
 if Assigned(FontAliasHashList) then exit;
 FontAliasHashList:=NewHashList(false,HashList_DefaultHasher);
 for i:=0 to Screen.Fonts.Count-1 do AddItem(Screen.Fonts[i],Screen.Fonts[i]);
 {$IFDEF WINDOWS}
 for i:=0 to FullEmbeddedFontList.Count-1 do begin
  AddItem(FullEmbeddedFontList[i].FontName,FullEmbeddedFontList[i].FontFamily);
  AddItem(FullEmbeddedFontList[i].FontFamily,FullEmbeddedFontList[i].FontFamily);
 end;
 {$ENDIF ~WINDOWS}
end;

procedure FreeFontNameByAliasHashList;
begin
 Kill(FontAliasHashList);
end;

function FindFontNameByAlias(const FontAlias:LongString; const Default:LongString=''):LongString;
var i:Integer; Alias:LongString;
 function Assign(const Value,Default:LongString):LongString;
 begin
  if (Value<>'') then Result:=Value else Result:=Default;
 end;
 function Match(const Alias,Name:LongString):Boolean;
 begin
  Result:=false; if (Alias='') then exit; if (Name='') then exit;
  if SameText(Alias,Name) or SameText(Alias,StringReplace(Name,' ','',[rfReplaceAll]))
  then Result:=true;
 end;
begin
 Result:=Default;
 try
  Alias:=SysUtils.Trim(StringReplace(FontAlias,'_',' ',[rfReplaceAll]));
  if (Alias='') then exit;
  // Uses HashList to search fonts faster
  if (FontAliasHashList=nil) then InitFontNameByAliasHashList;
  if (FontAliasHashList<>nil) then begin
   Result:=Assign(FontAliasHashList.KeyedParams[Alias],Default);
   exit;
  end;
  // Search in EmbeddedFont
  {$IFDEF WINDOWS}
  for i:=0 to FullEmbeddedFontList.Count-1 do begin
   if Match(Alias,FullEmbeddedFontList[i].FontFamily) then begin
    Result:=Assign(FullEmbeddedFontList[i].FontFamily,Default);
    exit;
   end;
   if Match(Alias,FullEmbeddedFontList[i].FontName) then begin
    Result:=Assign(FullEmbeddedFontList[i].FontFamily,Default);
    exit;
   end;
  end;
  {$ENDIF ~WINDOWS}
  // Search in Screen.Fonts
  i:=Screen.Fonts.IndexOf(Alias);
  if i>=0 then begin
   Result:=Assign(Screen.Fonts[i],Default);
   exit;
  end;
  for i:=0 to Screen.Fonts.Count-1 do begin
   if Match(Alias,Screen.Fonts[i]) then begin
    Result:=Assign(Screen.Fonts[i],Default);
    exit;
   end;
  end;
 except
  on E:Exception do BugReport(E,nil,'FindFontNameByAlias');
 end;
end;

 // Name:PT_Mono|Size:10|Height:-13|Charset:Russian|Color:Black|Pitch:Fixed|Style:Regular
function ReadBufferedFont(out Font:TFontParams; Buffer:LongString; Replacement:Boolean; const Default:TFontParams):Boolean;
var s:LongString; d,n:LongInt;
 function AdjustName(const s:LongString):LongString;
 begin
  Result:=FindFontNameByAlias(Trim(StringReplace(s,'_',' ',[rfReplaceAll])),Font.Name);
 end;
begin
 Result:=False;
 Font:=Default;
 Buffer:=Trim(Buffer);
 if (Buffer='') then exit;
 if Replacement then begin
  if Pos('_',Buffer)>0 then Buffer:=StringReplace(Buffer,'_',' ',[rfReplaceAll]);
  if Pos('\',Buffer)>0 then Buffer:=StringReplace(Buffer,'\',EOL,[rfReplaceAll]);
  if Pos('/',Buffer)>0 then Buffer:=StringReplace(Buffer,'/',EOL,[rfReplaceAll]);
  if Pos('|',Buffer)>0 then Buffer:=StringReplace(Buffer,'|',EOL,[rfReplaceAll]);
  if Pos(':',Buffer)>0 then Buffer:=StringReplace(Buffer,':',' = ',[rfReplaceAll]);
 end;
 n:=0; d:=0; s:='';
 if ScanVarString(svConfig,PChar(Buffer),'CharSet%s',s)<>nil then begin inc(n); Font.CharSet:=StringToCharset(s,Font.CharSet); end;
 if ScanVarString(svConfig,PChar(Buffer),'Color%s',s)<>nil   then begin inc(n); Font.Color:=StringToColor(s,Font.Color);       end;
 if ScanVarLongInt(svConfig,PChar(Buffer),'Size%d',d)<>nil   then begin inc(n); if d<>0 then Font.Height:=FontSizeToHeight(d); end;
 if ScanVarLongInt(svConfig,PChar(Buffer),'Height%d',d)<>nil then begin inc(n); if d<>0 then Font.Height:=d;                   end;
 if ScanVarString(svConfig,PChar(Buffer),'Name%s',s)<>nil    then begin inc(n); Font.Name:=AdjustName(s);                      end;
 if ScanVarAlpha(svConfig,PChar(Buffer),'Pitch%a',s)<>nil    then begin inc(n); Font.Pitch:=StringToPitch(s,Font.Pitch);       end;
 if ScanVarString(svConfig,PChar(Buffer),'Style%s',s)<>nil   then begin inc(n); Font.Style:=StringToFontStyles(s,Font.Style);  end;
 Result:=(n>0);
end;

function ReadIniFileFont(var Font:TFontParams; const IniFile,Section:LongString):Boolean;
var Buffer:LongString;
begin
 Result:=false;
 Font:=StandardFont;
 if FileExists(IniFile,faAnyFile and not faDirectory) then begin
  Buffer:=ExtractTextSection(IniFile,Section,efConfigNC);
  if (Buffer<>'') then Result:=ReadBufferedFont(Font,Buffer,false,StandardFont);
 end;
end;

function GetFontAsText(const Font:TFontParams):LongString; overload;
begin
 Result:=Format('CharSet = %s',[CharsetToString(Font.Charset,'')])+EOL+
         Format('Color   = %s',[ColorToString(Font.Color)])+EOL+
         Format('Height  = %d',[Font.Height])+EOL+
         Format('Name    = %s',[Font.Name])+EOL+
         Format('Pitch   = %s',[PitchToString(Font.Pitch,'')])+EOL+
         Format('Style   = %s',[FontStylesToString(Font.Style)])+EOL;
end;

function GetFontAsText(const Font:TFont):LongString; overload;
var Params:TFontParams;
begin
 Result:='';
 if (Font is TFont) then begin
  SaveFont(Font,Params);
  Result:=GetFontAsText(Params);
 end;
end;

function UsesScreenPixelsPerInch:Integer;
begin
 Result:=DefaultScreenPPI;
 if (Result=0) then if Assigned(Screen) then Result:=Screen.PixelsPerInch;
 if (Result<0) then if Assigned(Application) and Assigned(Application.MainForm) then Result:=Application.MainForm.PixelsPerInch;
end;

function FontSizeToHeight(Size:Integer; PPI:Integer=0):Integer;
begin
 if (PPI=0) then PPI:=UsesScreenPixelsPerInch;
 Result:=-MulDiv(Size,PPI,72);
end;

function FontHeightToSize(Height:Integer; PPI:Integer=0):Integer;
begin
 if PPI=0 then PPI:=UsesScreenPixelsPerInch;
 Result:=-MulDiv(Height,72,PPI);
end;

function EvalTextSize(const aFont:TFont; aText:LongString):TSize; overload;
var FP:TFontParams;
begin
 Result.cx:=0;
 Result.cy:=0;
 if (aFont<>nil) then begin
  SaveFont(aFont,FP);
  Result:=EvalTextSize(FP,aText);
 end;
end;
 
function EvalTextSize(const aFont:TFontParams; aText:LongString):TSize; overload;
var bmp:TBitmap;
begin
 Result.cx:=0;
 Result.cy:=0;
 try
  bmp:=TBitmap.Create;
  try
   bmp.Width:=32; bmp.Height:=32;
   RestoreFont(bmp.Canvas.Font,aFont);
   Result:=bmp.Canvas.TextExtent(aText);
  finally
   Kill(bmp);
  end;
 except
  on E:Exception do BugReport(E,nil,'EvalTextSize');
 end;
end;

function CharsetToString(Charset:TFontCharset; Suffix:LongString='_CHARSET'):LongString;
begin
 Result:='';
 case Charset of
  ANSI_CHARSET        : Result:='ANSI'+Suffix;
  DEFAULT_CHARSET     : Result:='Default'+Suffix;
  SYMBOL_CHARSET      : Result:='Symbol'+Suffix;
  MAC_CHARSET         : Result:='MAC'+Suffix;
  SHIFTJIS_CHARSET    : Result:='ShiftJIS'+Suffix;
  HANGEUL_CHARSET     : Result:='Hangeul'+Suffix;
  JOHAB_CHARSET       : Result:='Johab'+Suffix;
  GB2312_CHARSET      : Result:='GB2312'+Suffix;
  CHINESEBIG5_CHARSET : Result:='ChineseBig5'+Suffix;
  GREEK_CHARSET       : Result:='Greek'+Suffix;
  TURKISH_CHARSET     : Result:='Turkish'+Suffix;
  HEBREW_CHARSET      : Result:='Hebrew'+Suffix;
  ARABIC_CHARSET      : Result:='Arabic'+Suffix;
  BALTIC_CHARSET      : Result:='Baltic'+Suffix;
  RUSSIAN_CHARSET     : Result:='Russian'+Suffix;
  THAI_CHARSET        : Result:='Thai'+Suffix;
  EASTEUROPE_CHARSET  : Result:='EastEurope'+Suffix;
  OEM_CHARSET         : Result:='OEM'+Suffix;
  //else                Result:=IntToStr(Charset);
 end;
 if (Result<>'') and (Suffix<>'') then Result:=UpperCase(Result);
end;

function PitchToString(Pitch:TFontPitch; Suffix:LongString='_PITCH'):LongString; overload;
begin
 Result:='';
 case Pitch of
  fpDefault  : Result:='Default'+Suffix;
  fpFixed    : Result:='Fixed'+Suffix;
  fpVariable : Result:='Variable'+Suffix;
 end;
 if (Result<>'') and (Suffix<>'') then Result:=UpperCase(Result);
end;

function PitchToString(Pitch:Integer):LongString; overload;
begin
 Result:='';
 case Pitch of
  DEFAULT_PITCH  : Result:='DEFAULT_PITCH';
  FIXED_PITCH    : Result:='FIXED_PITCH';
  VARIABLE_PITCH : Result:='VARIABLE_PITCH';
 end;
end;

function FontStylesToString(const FontStyles:TFontStyles):LongString;
 procedure Add(var S:LongString; const W:LongString);
 begin
  if (Length(S)>0) and (S[Length(S)]<>'[') then S:=S+','+W else S:=S+W;
 end;
begin
 Result:='[';
 if fsBold      in FontStyles then Add(Result,'Bold');
 if fsItalic    in FontStyles then Add(Result,'Italic');
 if fsUnderline in FontStyles then Add(Result,'Underline');
 if fsStrikeout in FontStyles then Add(Result,'Strikeout');
 Result:=Result+']';
end;


function StringToCharset(S:LongString; Default:TFontCharSet):TFontCharSet;
var id:LongString;
begin
 Result:=Default;
 S:=SysUtils.Trim(S);
 if (S<>'') then begin
  for Result:=Low(Result) to High(Result) do
  if (Result in AvailFontCharsets) then begin
   id:=CharsetToString(Result,'');         if (id<>'') and SameText(id,S) then Exit;
   id:=CharsetToString(Result,'_CHARSET'); if (id<>'') and SameText(id,S) then Exit;
  end;
  Result:=StrToIntDef(S,Default);
 end;
end;

function StringToPitch(S:LongString; Default:TFontPitch):TFontPitch;
begin
 Result:=Default;
 S:=SysUtils.Trim(S);
 if (S<>'') then begin
  if SameText(s,'DEFAULT')  or SameText(s,'DEFAULT_PITCH')  then Result:=fpDefault else
  if SameText(s,'FIXED')    or SameText(s,'FIXED_PITCH')    then Result:=fpFixed   else
  if SameText(s,'VARIABLE') or SameText(s,'VARIABLE_PITCH') then Result:=fpVariable;
 end;
end;

function StringToFontStyles(S:LongString; Default:TFontStyles):TFontStyles;
var i:Integer; w:LongString;
begin
 Result:=Default;
 S:=SysUtils.Trim(S);
 if (S<>'') then begin
  Result:=[];
  S:=StringReplace(S,'[',' ',[rfReplaceAll]);
  S:=StringReplace(S,']',' ',[rfReplaceAll]);
  for i:=1 to WordCount(S,ScanSpaces) do begin
   w:=ExtractWord(i,S,ScanSpaces);
   if SameText(w,'BOLD')      then include(Result,fsBold);
   if SameText(w,'ITALIC')    then include(Result,fsItalic);
   if SameText(w,'UNDERLINE') then include(Result,fsUnderline);
   if SameText(w,'STRIKEOUT') then include(Result,fsStrikeOut);
  end;
 end;
end;

 {
 **********
 Draw lines
 **********
 }
procedure DrawLine(Canvas   : TCanvas;
             const Start    : TPoint2I;
             const Stop     : TPoint2I;
                   Color    : TColor    = clBlack;
                   Style    : TPenStyle = psSolid;
                   Mode     : TPenMode  = pmCopy;
                   PenWidth : Integer   = 1);
var PenParams:TPenParams; BrushParams:TBrushParams;
begin
 with Canvas do begin
  SavePen(Pen,PenParams);
  SaveBrush(Brush,BrushParams);
  SetPen(Pen,Color,Style,Mode,PenWidth);
  SetBrush(Brush,Color,bsClear);
  with Start do MoveTo(x,y);
  with Stop do LineTo(x,y);
  RestoreBrush(Brush,BrushParams);
  RestorePen(Pen,PenParams);
 end;
end;

const
 StartMask = $800000;

type
 TPatRec = packed record
  Mask    : Integer;
  Pattern : Integer;
  Canvas  : TCanvas;
 end;

procedure PatternPixel(x,y,Color:Integer; CustomData:Pointer);
begin
 with TPatRec(CustomData^) do begin
  if Mask and Pattern <> 0 then Canvas.Pixels[x,y]:=Color;
  Mask:=Mask shr 1;
  if Mask=0 then Mask:=StartMask;
 end;
end;

procedure DrawPatternLine(Canvas   : TCanvas;
                    const Start    : TPoint2I;
                    const Stop     : TPoint2I;
                          Color    : TColor = clBlack;
                          Pattern  : Integer = $FFFFFF);
var PatRec:TPatRec;
begin
 case Pattern and $FFFFFF of
  $000000 : {nothing to draw};
  $FFFFFF : DrawLine(Canvas,Start,Stop,Color,psSolid);
  $FFFFC0 : DrawLine(Canvas,Start,Stop,Color,psDash);
  $E38E38 : DrawLine(Canvas,Start,Stop,Color,psDot);
  $FF81C0 : DrawLine(Canvas,Start,Stop,Color,psDashDot);
  $FF8E38 : DrawLine(Canvas,Start,Stop,Color,psDashDotDot);
  else begin
   PatRec.Mask:=StartMask;
   PatRec.Pattern:=Pattern;
   PatRec.Canvas:=Canvas;
   VirtualDrawLine(Start.x,Start.y,Stop.x,Stop.y,Color,PatternPixel,@PatRec);
  end;
 end;
end;

procedure DrawArrow(Canvas   : TCanvas;
              const e1       : TPoint2I;
              const e2       : TPoint2I;
                    Color    : TColor    = clBlack;
                    Style    : TPenStyle = psSolid;
                    Mode     : TPenMode  = pmCopy;
                    PenWidth : Integer   = 1;
                    d1       : Integer   = 3;
                    d2       : Integer   = 3);
var  e3,e4,e5,e6:record x,y:double end;  d3:double;
begin
  DrawLine(Canvas,e1,e2,Color,Style,Mode,PenWidth);
  e3.x:=e2.x-e1.x;
  e3.y:=e2.y-e1.y;
  d3:=sqrt(sqr(e3.x)+sqr(e3.y));
  if d3<8 then exit;
  e3.x:=e3.x/d3;
  e3.y:=e3.y/d3;
  e4.x:= e3.y;
  e4.y:=-e3.x;
  e5.x:=e2.x-(e3.x*d1-e4.x*d2);
  e5.y:=e2.y-(e3.y*d1-e4.y*d2);
  e6.x:=e2.x-(e3.x*d1+e4.x*d2);
  e6.y:=e2.y-(e3.y*d1+e4.y*d2);
  DrawLine(Canvas,Point2I(round(e5.x),round(e5.y)),e2,Color,Style,Mode,PenWidth);
  DrawLine(Canvas,Point2I(round(e6.x),round(e6.y)),e2,Color,Style,Mode,PenWidth);
end;

{$PUSH}
{$ASMMODE Intel}
procedure Markers;nostackframe;assembler;
asm
 {0}
 db 00000000b
 db 00000000b
 db 00000000b
 db 00010000b
 db 00000000b
 db 00000000b
 db 00000000b
 db 00000000b
 {1}
 db 10000010b
 db 01000100b
 db 00101000b
 db 00010000b
 db 00101000b
 db 01000100b
 db 10000010b
 db 00000000b
 {2}
 db 00010000b
 db 00010000b
 db 00010000b
 db 11111110b
 db 00010000b
 db 00010000b
 db 00010000b
 db 00000000b
 {3}
 db 11111110b
 db 10000010b
 db 10000010b
 db 10000010b
 db 10000010b
 db 10000010b
 db 11111110b
 db 00000000b
 {4}
 db 11111110b
 db 11111110b
 db 11111110b
 db 11111110b
 db 11111110b
 db 11111110b
 db 11111110b
 db 00000000b
 {5}
 db 00111000b
 db 01000100b
 db 10000010b
 db 10000010b
 db 10000010b
 db 01000100b
 db 00111000b
 db 00000000b
 {6}
 db 10000010b
 db 01000100b
 db 00111000b
 db 00101000b
 db 00111000b
 db 01000100b
 db 10000010b
 db 00000000b
 {7}
 db 00010000b
 db 00010000b
 db 00111000b
 db 11101110b
 db 00111000b
 db 00010000b
 db 00010000b
 db 00000000b
 {8}
 db 00111000b
 db 00010000b
 db 10010010b
 db 11111110b
 db 10010010b
 db 00010000b
 db 00111000b
 db 00000000b
 {9}
 db 00010000b
 db 00101000b
 db 01000100b
 db 10000010b
 db 01000100b
 db 00101000b
 db 00010000b
 db 00000000b
 {10}
 db 00010000b
 db 00111000b
 db 01111100b
 db 11111110b
 db 01111100b
 db 00111000b
 db 00010000b
 db 00000000b
 {11}
 db 00000000b
 db 00010000b
 db 00101000b
 db 01000100b
 db 11111110b
 db 00000000b
 db 00000000b
 db 00000000b
 {12}
 db 00000000b
 db 11111110b
 db 01000100b
 db 00101000b
 db 00010000b
 db 00000000b
 db 00000000b
 db 00000000b
 {13}
 db 01000000b
 db 01100000b
 db 01010000b
 db 01001000b
 db 01010000b
 db 01100000b
 db 01000000b
 db 00000000b
 {14}
 db 00000100b
 db 00001100b
 db 00010100b
 db 00100100b
 db 00010100b
 db 00001100b
 db 00000100b
 db 00000000b
 {15}
 db 00000000b
 db 00000000b
 db 00111000b
 db 00101000b
 db 00111000b
 db 00000000b
 db 00000000b
 db 00000000b
end;
{$POP}

type
 PMarker  = ^TMarker;
 TMarker  = packed array[0..7] of Byte;
 PMarkers = ^TMarkers;
 TMarkers = packed array[0..15] of TMarker;
const
 MarkerTable:PMarkers=@Markers;

procedure DrawPointMarker(Canvas : TCanvas;
                    const Where  : TPoint2I;
                          Color  : TColor = clBlack;
                          Style  : Byte   = 0);
var
 P : PMarker;
 i : Integer;
 j : Integer;
 d : Byte;
begin
 if (Style and $F)=0
 then Canvas.Pixels[Where.x,Where.y]:=Color
 else with Canvas,Where do begin
  P:=@MarkerTable[Style and $F];
  for i:=0 to 6 do begin
   d:=P[i];
   if d<>0 then
   for j:=0 to 6 do
   if d and ($80 shr j) <> 0 then Pixels[x+j-3,y+i-3]:=Color;
  end;
 end;
end;

procedure DrawLineMarker(Canvas : TCanvas;
                   const Start  : TPoint2I;
                   const Stop   : TPoint2I;
                         Color  : TColor = clBlack;
                         Style  : Byte   = 0);
begin
 case Style and $F of
  $0 : {nothing to draw};
  $1 : DrawLine(Canvas,Start,Stop,Color,psSolid,pmCopy,1);
  $2 : DrawLine(Canvas,Start,Stop,Color,psSolid,pmCopy,2);
  $3 : DrawLine(Canvas,Start,Stop,Color,psSolid,pmCopy,3);
  $4 : DrawLine(Canvas,Start,Stop,Color,psSolid,pmCopy,4);
  $5 : DrawLine(Canvas,Start,Stop,Color,psSolid,pmCopy,5);
  $6 : DrawLine(Canvas,Start,Stop,Color,psSolid,pmCopy,6);
  $7 : DrawLine(Canvas,Start,Stop,Color,psSolid,pmCopy,7);
  $8 : DrawLine(Canvas,Start,Stop,Color,psDot);
  $9 : DrawLine(Canvas,Start,Stop,Color,psDash);
  $A : DrawLine(Canvas,Start,Stop,Color,psDashDot);
  $B : DrawLine(Canvas,Start,Stop,Color,psDashDotDot);
  $C : DrawPatternLine(Canvas,Start,Stop,Color,LinePatternTable[$2]);
  $D : DrawPatternLine(Canvas,Start,Stop,Color,LinePatternTable[$3]);
  $E : DrawPatternLine(Canvas,Start,Stop,Color,LinePatternTable[$4]);
  $F : DrawPatternLine(Canvas,Start,Stop,Color,LinePatternTable[$5]);
  else DrawPatternLine(Canvas,Start,Stop,Color,LinePatternTable[Style and $F]);
 end;
end;

 {
 ************************
 Draw bars and rectangles
 ************************
 }
procedure DrawBar(Canvas : TCanvas;
            const Rect   : TRect2I;
                  Color  : TColor      = clBlack;
                  Style  : TBrushStyle = bsSolid);
var
 PenParams   : TPenParams;
 BrushParams : TBrushParams;
begin
 with Canvas do begin
  SavePen(Pen,PenParams);
  SaveBrush(Brush,BrushParams);
  SetPen(Pen,Color,psSolid,pmCopy,1);
  SetBrush(Brush,Color,Style);
  Rectangle(Rect.a.x,Rect.a.y,Rect.b.x,Rect.b.y);
  RestorePen(Pen,PenParams);
  RestoreBrush(Brush,BrushParams);
 end;
end;

procedure DrawRect(Canvas   : TCanvas;
             const Rect     : TRect2I;
                   Color    : TColor    = clBlack;
                   Style    : TPenStyle = psSolid;
                   Mode     : TPenMode  = pmCopy;
                   PenWidth : Integer   = 1);
var
 PenParams   : TPenParams;
 BrushParams : TBrushParams;
begin
 with Canvas do begin
  SavePen(Pen,PenParams);
  SaveBrush(Brush,BrushParams);
  SetPen(Pen,Color,Style,Mode,PenWidth);
  SetBrush(Brush,Color,bsClear);
  Rectangle(Rect.a.x,Rect.a.y,Rect.b.x,Rect.b.y);
  RestorePen(Pen,PenParams);
  RestoreBrush(Brush,BrushParams);
 end;
end;

procedure DrawCustomRect(Canvas     : TCanvas;
                   const Rect       : TRect2I;
                         PenColor   : TColor      = clBlack;
                         PenStyle   : TPenStyle   = psSolid;
                         PenMode    : TPenMode    = pmCopy;
                         PenWidth   : Integer     = 1;
                         BrushColor : TColor      = clBlack;
                         BrushStyle : TBrushStyle = bsClear);
var
 PenParams   : TPenParams;
 BrushParams : TBrushParams;
begin
 with Canvas do begin
  SavePen(Pen,PenParams);
  SaveBrush(Brush,BrushParams);
  SetPen(Pen,PenColor,PenStyle,PenMode,PenWidth);
  SetBrush(Brush,BrushColor,BrushStyle);
  Rectangle(Rect.a.x,Rect.a.y,Rect.b.x,Rect.b.y);
  RestorePen(Pen,PenParams);
  RestoreBrush(Brush,BrushParams);
 end;
end;

procedure DrawRoundRect(Canvas     : TCanvas;
                  const Rect       : TRect2I;
                  const Rounded    : TPoint2I;
                        PenColor   : TColor      = clBlack;
                        PenStyle   : TPenStyle   = psSolid;
                        PenMode    : TPenMode    = pmCopy;
                        PenWidth   : Integer     = 1;
                        BrushColor : TColor      = clBlack;
                        BrushStyle : TBrushStyle = bsClear);
var
 PenParams   : TPenParams;
 BrushParams : TBrushParams;
begin
 with Canvas do begin
  SavePen(Pen,PenParams);
  SaveBrush(Brush,BrushParams);
  SetPen(Pen,PenColor,PenStyle,PenMode,PenWidth);
  SetBrush(Brush,BrushColor,BrushStyle);
  RoundRect(Rect.a.x,Rect.a.y,Rect.b.x,Rect.b.y,Rounded.x,Rounded.y);
  RestorePen(Pen,PenParams);
  RestoreBrush(Brush,BrushParams);
 end;
end;

procedure DrawEllipse(Canvas     : TCanvas;
                const Rect       : TRect2I;
                      PenColor   : TColor      = clBlack;
                      PenStyle   : TPenStyle   = psSolid;
                      PenMode    : TPenMode    = pmCopy;
                      PenWidth   : Integer     = 1;
                      BrushColor : TColor      = clBlack;
                      BrushStyle : TBrushStyle = bsClear);
var
 PenParams   : TPenParams;
 BrushParams : TBrushParams;
begin
 with Canvas do begin
  SavePen(Pen,PenParams);
  SaveBrush(Brush,BrushParams);
  SetPen(Pen,PenColor,PenStyle,PenMode,PenWidth);
  SetBrush(Brush,BrushColor,BrushStyle);
  Ellipse(Rect.a.x,Rect.a.y,Rect.b.x,Rect.b.y);
  RestorePen(Pen,PenParams);
  RestoreBrush(Brush,BrushParams);
 end;
end;

procedure DrawEllipsePie(Canvas     : TCanvas;
                   const Rect       : TRect2I;
                   const PieRect    : TRect2I;
                         PenColor   : TColor      = clBlack;
                         PenStyle   : TPenStyle   = psSolid;
                         PenMode    : TPenMode    = pmCopy;
                         PenWidth   : Integer     = 1;
                         BrushColor : TColor      = clBlack;
                         BrushStyle : TBrushStyle = bsClear);
var
 PenParams   : TPenParams;
 BrushParams : TBrushParams;
begin
 with Canvas do begin
  SavePen(Pen,PenParams);
  SaveBrush(Brush,BrushParams);
  SetPen(Pen,PenColor,PenStyle,PenMode,PenWidth);
  SetBrush(Brush,BrushColor,BrushStyle);
  Pie(Rect.a.x,Rect.a.y,Rect.b.x,Rect.b.y,PieRect.a.x,PieRect.a.y,PieRect.b.x,PieRect.b.y);
  RestorePen(Pen,PenParams);
  RestoreBrush(Brush,BrushParams);
 end;
end;

procedure DrawEllipseArc(Canvas     : TCanvas;
                   const Rect       : TRect2I;
                   const ArcRect    : TRect2I;
                         PenColor   : TColor      = clBlack;
                         PenStyle   : TPenStyle   = psSolid;
                         PenMode    : TPenMode    = pmCopy;
                         PenWidth   : Integer     = 1);
var
 PenParams   : TPenParams;
begin
 with Canvas do begin
  SavePen(Pen,PenParams);
  SetPen(Pen,PenColor,PenStyle,PenMode,PenWidth);
  Arc(Rect.a.x,Rect.a.y,Rect.b.x,Rect.b.y,ArcRect.a.x,ArcRect.a.y,ArcRect.b.x,ArcRect.b.y);
  RestorePen(Pen,PenParams);
 end;
end;

procedure DrawEllipseChord(Canvas     : TCanvas;
                     const Rect       : TRect2I;
                     const ChordRect  : TRect2I;
                           PenColor   : TColor      = clBlack;
                           PenStyle   : TPenStyle   = psSolid;
                           PenMode    : TPenMode    = pmCopy;
                           PenWidth   : Integer     = 1;
                           BrushColor : TColor      = clBlack;
                           BrushStyle : TBrushStyle = bsClear);
var
 PenParams   : TPenParams;
 BrushParams : TBrushParams;
begin
 with Canvas do begin
  SavePen(Pen,PenParams);
  SaveBrush(Brush,BrushParams);
  SetPen(Pen,PenColor,PenStyle,PenMode,PenWidth);
  SetBrush(Brush,BrushColor,BrushStyle);
  Chord(Rect.a.x,Rect.a.y,Rect.b.x,Rect.b.y,ChordRect.a.x,ChordRect.a.y,ChordRect.b.x,ChordRect.b.y);
  RestorePen(Pen,PenParams);
  RestoreBrush(Brush,BrushParams);
 end;
end;

procedure DrawPolyLine(Canvas     : TCanvas;
                 const Points     : array of TPoint;
                       PenColor   : TColor      = clBlack;
                       PenStyle   : TPenStyle   = psSolid;
                       PenMode    : TPenMode    = pmCopy;
                       PenWidth   : Integer     = 1);
var
 PenParams   : TPenParams;
begin
 with Canvas do begin
  SavePen(Pen,PenParams);
  SetPen(Pen,PenColor,PenStyle,PenMode,PenWidth);
  PolyLine(Points);
  RestorePen(Pen,PenParams);
 end;
end;

procedure DrawPolyBezier(Canvas     : TCanvas;
                   const Points     : array of TPoint;
                         PenColor   : TColor      = clBlack;
                         PenStyle   : TPenStyle   = psSolid;
                         PenMode    : TPenMode    = pmCopy;
                         PenWidth   : Integer     = 1);
var
 PenParams   : TPenParams;
begin
 with Canvas do begin
  SavePen(Pen,PenParams);
  SetPen(Pen,PenColor,PenStyle,PenMode,PenWidth);
  PolyBezier(Points);
  RestorePen(Pen,PenParams);
 end;
end;

procedure DrawPolygon(Canvas     : TCanvas;
                const Points     : array of TPoint;
                      PenColor   : TColor      = clBlack;
                      PenStyle   : TPenStyle   = psSolid;
                      PenMode    : TPenMode    = pmCopy;
                      PenWidth   : Integer     = 1;
                      BrushColor : TColor      = clBlack;
                      BrushStyle : TBrushStyle = bsClear);
var
 PenParams   : TPenParams;
 BrushParams : TBrushParams;
begin
 with Canvas do begin
  SavePen(Pen,PenParams);
  SaveBrush(Brush,BrushParams);
  SetPen(Pen,PenColor,PenStyle,PenMode,PenWidth);
  SetBrush(Brush,BrushColor,BrushStyle);
  Polygon(Points);
  RestorePen(Pen,PenParams);
  RestoreBrush(Brush,BrushParams);
 end;
end;

procedure ClearClientArea(Form:TForm);
begin
 DrawBar(Form.Canvas,TRect2I(Form.ClientRect),Form.Color);
end;

 {
 *********
 Draw text
 *********
 }
procedure DrawText(Canvas : TCanvas;
             const Where  : TPoint2I;
             const Msg    : LongString;
                   Color  : TColor = clBlack;
                   Back   : TColor = clWhite;
                   aBrush : TBrushStyle = bsSolid);
var
 BrushParams : TBrushParams;
 FontParams  : TFontParams;
begin
 with Canvas do begin
  SaveBrush(Brush,BrushParams);
  SaveFont(Font,FontParams);
  SetBrush(Brush,Back,aBrush);
  Font.Color:=Color;
  TextOut(Where.x,Where.y,Msg);
  RestoreBrush(Brush,BrushParams);
  RestoreFont(Font,FontParams);
 end;
end;

function CreateTextBitmap(const Msg         : LongString;
                                FontCharSet : TFontCharSet = stdFontCharSet;
                                FontColor   : TColor       = stdFontColor;
                                FontHeight  : Integer      = stdFontHeight;
                          const FontName    : LongString   = stdFontName;
                                FontPitch   : TFontPitch   = stdFontPitch;
                                FontStyle   : TFontStyles  = stdFontStyle;
                                BackColor   : TColor       = stdFontBack):TBitmap;
begin
 Result:=TBitmap.Create;
 SetFont(Result.Canvas.Font,FontCharSet,FontColor,FontHeight,FontName,FontPitch,FontStyle);
 Result.Height:=Result.Canvas.TextHeight(Msg);
 Result.Width:=Result.Canvas.TextWidth(Msg);
 DrawText(Result.Canvas,Point2I(0,0),Msg,FontColor,BackColor);
end;

function CreateBarBmp(BarWidth,BarHeight,ColorDepth,FillColor:Integer):TBitmap;
var bmp:TBitmap;
begin
 Result:=nil;
 if (BarWidth>0) then if (BarHeight>0) then
 if (ColorDepth in [1,4,8,15,16,24]) then begin
  bmp:=TBitmap.Create;
  try
   bmp.Width:=BarWidth;
   bmp.Height:=BarHeight;
   case ColorDepth of
    1  : bmp.PixelFormat:=pf1bit;
    4  : bmp.PixelFormat:=pf4bit;
    8  : bmp.PixelFormat:=pf8bit;
    15 : bmp.PixelFormat:=pf15bit;
    16 : bmp.PixelFormat:=pf16bit;
    24 : bmp.PixelFormat:=pf24bit;
   end;
   bmp.Canvas.Brush.Color:=FillColor;
   bmp.Canvas.Brush.Style:=bsSolid;
   bmp.Canvas.Pen.Color:=FillColor;
   bmp.Canvas.Pen.Mode:=pmCopy;
   bmp.Canvas.Pen.Style:=psSolid;
   bmp.Canvas.Pen.Width:=3;
   bmp.Canvas.Rectangle(0,0,bmp.Width,bmp.Height);
  except
   on E:Exception do begin
    BugReport(E,bmp,'CreateBarBmp');
    FreeAndNil(bmp);
   end;
  end;
  Result:=bmp;
 end;
end;

function CreateLedBmp(TextWidth,FontSize,ColorDepth,FillColor:Integer; const FontName:LongString;
                      Caption:LongString=''; TextColor:TColor=clNone; FontStyle:TFontStyles=[];
                      xSpace:Integer=0; ySpace:Integer=0):TBitmap;
var bmp:TBitmap; px,py:Integer;
begin
 Result:=nil;
 if IsNonEmptyStr(FontName) then
 if (TextWidth>0) then if (FontSize>0) then
 if (ColorDepth in [1,4,8,15,16,24]) then begin
  TextWidth:=Max(TextWidth,Length(Caption));
  if (Caption='') then Caption:=StringOfChar('0',TextWidth) else begin
   if TextWidth>Length(Caption) then Caption:=Caption+StringOfChar(' ',(TextWidth-Length(Caption)) div 2);
   if TextWidth>Length(Caption) then Caption:=StringOfChar(' ',TextWidth-Length(Caption))+Caption;
  end;
  bmp:=TBitmap.Create;
  try
   bmp.Canvas.Font.Name:=FontName;
   bmp.Canvas.Font.Size:=FontSize;
   bmp.Canvas.Font.Style:=FontStyle;
   bmp.Width:=bmp.Canvas.TextWidth(Caption)+2*xSpace;
   bmp.Height:=bmp.Canvas.TextHeight(Caption)+2*ySpace;
   case ColorDepth of
    1  : bmp.PixelFormat:=pf1bit;
    4  : bmp.PixelFormat:=pf4bit;
    8  : bmp.PixelFormat:=pf8bit;
    15 : bmp.PixelFormat:=pf15bit;
    16 : bmp.PixelFormat:=pf16bit;
    24 : bmp.PixelFormat:=pf24bit;
   end;
   bmp.Canvas.Brush.Color:=FillColor;
   bmp.Canvas.Brush.Style:=bsSolid;
   bmp.Canvas.Pen.Color:=FillColor;
   bmp.Canvas.Pen.Mode:=pmCopy;
   bmp.Canvas.Pen.Style:=psSolid;
   bmp.Canvas.Pen.Width:=3;
   bmp.Canvas.Rectangle(0,0,bmp.Width,bmp.Height);
   Caption:=Trim(Caption);
   if (TextColor<>clNone) and (Caption<>'') then begin
    bmp.Canvas.Font.Color:=TextColor;
    px:=(bmp.Width-bmp.Canvas.TextWidth(Caption)) div 2;
    py:=(bmp.Height-bmp.Canvas.TextHeight(Caption)) div 2;
    bmp.Canvas.TextOut(px,py,Caption);
   end;
  except
   on E:Exception do begin
    BugReport(E,bmp,'CreateLedBmp');
    FreeAndNil(bmp);
   end;
  end;
  Result:=bmp;
 end;
end;

 {
 ***************************
 TSmartDrawer implementation
 ***************************
 }
constructor TSmartDrawer.Create;
begin
 inherited Create;
 myCount:=0;
 SafeFillChar(myList,sizeof(myList),0);
end;

destructor TSmartDrawer.Destroy;
begin
 myCount:=0;
 SafeFillChar(myList,sizeof(myList),0);
 inherited Destroy;
end;

procedure TSmartDrawer.StartDraw;
begin
 if Assigned(Self) then myCount:=0;
end;

procedure TSmartDrawer.StopDraw;
begin
 if Assigned(Self) then myCount:=0;
end;

function TSmartDrawer.LockRect(const R:TRect2I):Boolean;
begin
 Result:=false;
 if Assigned(Self) then
 if myCount<=high(myList) then begin
  myList[myCount]:=R;
  inc(myCount);
  Result:=true;
 end;
end;

function TSmartDrawer.LastRect:TRect2I;
begin
 if Assigned(Self) and (myCount>0)
 then Result:=myList[myCount-1]
 else Result:=Rect2I(0,0,0,0);
end;

function TSmartDrawer.NoIntersections(const R:TRect2I):Boolean;
var
 i  : Integer;
begin
 Result:=false;
 if Assigned(Self) then begin
  for i:=0 to myCount-1 do
  if not RectIsEmpty(RectIntersection(myList[i],R)) then exit;
  Result:=true;
 end;
end;

function TSmartDrawer.DrawText(Canvas : TCanvas;
                         const Where  : TPoint2I;
                         const Msg    : LongString;
                               Color  : TColor  = clBlack;
                               Back   : TColor  = clWhite;
                               SpaceX : Integer = 0;
                               SpaceY : Integer = 0):Boolean;
var
  R:TRect2I;
begin
 Result:=false;
 if Assigned(Self) then begin
  {find text rectangle}
  R:=Rect2I(Where.x,Where.y,Where.x+Canvas.TextWidth(Msg),Where.y+abs(Canvas.TextHeight(Msg)));
  {Some grow the rectangle}
  RectGrow(R,SpaceX,SpaceY);
  {text out only if no intersections found}
  if NoIntersections(R) then begin
   LockRect(R);
   _crw_eldraw.DrawBar(Canvas,R,Back);
   _crw_eldraw.DrawText(Canvas,Where,Msg,Color,Back);
   Result:=true;
  end;
 end;
end;

function TSmartDrawer.DrawBitmap(Canvas : TCanvas;
                           const Where  : TPoint2I;
                                 Bitmap : TBitmap):Boolean;
var
 R : TRect2I;
begin
 Result:=false;
 if Assigned(Self) then begin
  R:=Rect2I(Where.x,Where.y,Where.x+Bitmap.Width,Where.y+Bitmap.Height);
  if NoIntersections(R) then begin
   LockRect(R);
   Canvas.Draw(Where.x,Where.y,Bitmap);
   Result:=true;
  end;
 end;
end;

function  NewSmartDrawer:TSmartDrawer;
begin
 Result:=nil;
 try
  Result:=TSmartDrawer.Create;
 except
  on E:Exception do BugReport(E,nil,'NewSmartDrawer');
 end;
end;

procedure Kill(var TheObject:TSmartDrawer); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E,nil,'Kill');
 end;
end;

 {
 ***************************
 TXorSelector implementation
 ***************************
 }
constructor TXorSelector.Create(aMode  : TXorSelectorMode = sm_Rect;
                                aWidth : Integer = 1);
begin
 inherited Create;
 myStart:=false;
 myRect:=Rect2I(0,0,0,0);
 Mode:=aMode;
 Width:=aWidth;
 ArrowSize:=Point2I(6,3);
end;

destructor TXorSelector.Destroy;
begin
 inherited Destroy;
end;

function  TXorSelector.GetIsStart:Boolean;
begin
 if Assigned(Self) then Result:=myStart else Result:=false;
end;

function  TXorSelector.GetSelection:TRect2I;
begin
 if Assigned(Self) then Result:=myRect else Result:=Rect2I(0,0,0,0);
end;

function   TXorSelector.GetMode:TXorSelectorMode;
begin
 if Assigned(Self) then Result:=myMode else Result:=sm_Rect;
end;

procedure  TXorSelector.SetMode(m:TXorSelectorMode);
begin
 if Assigned(Self) then myMode:=m;
end;

function  TXorSelector.GetWidth:Integer;
begin
 if Assigned(Self) then Result:=myWidth else Result:=0;
end;

procedure TXorSelector.SetWidth(w:Integer);
begin
 if Assigned(Self) then myWidth:=max(1,w);
end;

function   TXorSelector.GetArrowSize:TPoint2I;
begin
 if Assigned(Self) then Result:=myArrSiz else Result:=Point2I(0,0);
end;

procedure  TXorSelector.SetArrowSize(const s:TPoint2I);
begin
 if Assigned(Self) then myArrSiz:=s;
end;

procedure TXorSelector.Plot(Canvas:TCanvas; const r:TRect2I);
begin
 if Assigned(Self) and Assigned(Canvas) then begin
  case myMode of
   sm_Rect      : DrawCustomRect(Canvas, RectValidate(r), clWhite, psSolid, pmNot, myWidth, clWhite, bsClear);
   sm_Line      : DrawLine(Canvas,  r.a, r.b, clWhite, psSolid, pmNot, myWidth);
   sm_ArrowFrom : DrawArrow(Canvas, r.b, r.a, clWhite, psSolid, pmNot, myWidth, myArrSiz.x, myArrSiz.y);
   sm_ArrowTo   : DrawArrow(Canvas, r.a, r.b, clWhite, psSolid, pmNot, myWidth, myArrSiz.x, myArrSiz.y);
   sm_BigCross  : begin
                   DrawLine(Canvas, Point2I(Canvas.ClipRect.Left,  r.b.y),
                                    Point2I(Canvas.ClipRect.Right, r.b.y),
                                    clWhite, psSolid, pmNot, myWidth);
                   DrawLine(Canvas, Point2I(r.b.x, Canvas.ClipRect.Top),
                                    Point2I(r.b.x, Canvas.ClipRect.Bottom),
                                    clWhite, psSolid, pmNot, myWidth);
                  end;
   sm_HorzLine  : DrawLine(Canvas, Point2I(Canvas.ClipRect.Left,  r.b.y),
                                   Point2I(Canvas.ClipRect.Right, r.b.y),
                                   clWhite, psSolid, pmNot, myWidth);
   sm_VertLine  : DrawLine(Canvas, Point2I(r.b.x, Canvas.ClipRect.Top),
                                   Point2I(r.b.x, Canvas.ClipRect.Bottom),
                                   clWhite, psSolid, pmNot, myWidth);
  end;
 end;
end;

function TXorSelector.Start(Canvas:TCanvas; const At:TPoint2I):Boolean;
begin
 Result:=StartXY(Canvas, At.x, At.y);
end;

function TXorSelector.StartXY(Canvas:TCanvas; x,y:Integer):Boolean;
begin
 Result:=false;
 if Assigned(Self) then
 if not myStart then begin
  Result:=true;
  myStart:=true;
  myRect:=Rect2I(x,y,x,y);
  Plot(Canvas,myRect);
 end;
end;

function TXorSelector.Replace(Canvas:TCanvas; const At:TPoint2I):Boolean;
begin
 Result:=ReplaceXY(Canvas, At.x, At.y);
end;

function TXorSelector.ReplaceXY(Canvas:TCanvas; x,y:Integer):Boolean;
begin
 Result:=false;
 if Assigned(Self) then
 if myStart then begin
  Result:=true;
  Plot(Canvas,myRect);
  myRect:=Rect2I(myRect.a.x, myRect.a.y, x, y);
  Plot(Canvas,myRect);
 end;
end;

function TXorSelector.Stop(Canvas:TCanvas):Boolean;
begin
 Result:=false;
 if Assigned(Self) then
 if myStart then begin
  Result:=true;
  myStart:=false;
  Plot(Canvas,myRect);
 end;
end;

function  NewXorSelector:TXorSelector;
begin
 Result:=nil;
 try
  Result:=TXorSelector.Create;
 except
  on E:Exception do BugReport(E,nil,'NewXorSelector');
 end;
end;

procedure Kill(var TheObject:TXorSelector); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E,nil,'Kill');
 end; 
end;

 {
 *******************************************************************************
 TSmartBitmap implementation
 *******************************************************************************
 }
function TSmartBitmap.CurrentBmp:TBitmap;
begin
 Result:=nil;
 if Assigned(Self) then begin
  if Assigned(myCacheBmp)
  then Result:=myCacheBmp
  else Result:=myOwnedBmp;
 end;
end;

function TSmartBitmap.HasBitmap:Boolean;
begin
 if Assigned(Self)
 then Result:=Assigned(myCacheBmp) or Assigned(myOwnedBmp)
 else Result:=False;
end;

function TSmartBitmap.GetSource:LongString;
begin
 if Assigned(Self) then Result:=mySource else Result:='';
end;

procedure TSmartBitmap.SetSource(const aSource:LongString);
begin
 if Assigned(Self) then mySource:=aSource;
end;

function TSmartBitmap.GetTitle:LongString;
begin
 if Assigned(Self) then Result:=myTitle else Result:='';
end;

procedure TSmartBitmap.SetTitle(const aTitle:LongString);
begin
 if Assigned(Self) then myTitle:=aTitle;
end;

function TSmartBitmap.GetIdent:Integer;
begin
 if Assigned(Self) then Result:=myIdent else Result:=0;
end;

procedure TSmartBitmap.SetIdent(aIdent:Integer);
begin
 if Assigned(Self) then myIdent:=aIdent;
end;

function TSmartBitmap.GetWidth:Integer;
begin
 if Assigned(Self) then Result:=myWidth else Result:=0;
end;

function TSmartBitmap.GetHeight:Integer;
begin
 if Assigned(Self) then Result:=myHeight else Result:=0;
end;

function TSmartBitmap.CheckOk:Boolean;
begin
 Result:=Assigned(myCacheBmp) or Assigned(myOwnedBmp);
end;

procedure TSmartBitmap.KillBitmap;
begin
 if Assigned(Self) then begin
  Kill(myOwnedBmp);
  myCacheBmp:=nil;
  mySource:='';
  myHeight:=0;
  myWidth:=0;
 end;
end;

procedure TSmartBitmap.ClearLinks;
begin
 if Assigned(Self) then begin
  myTitle:='';
  myIdent:=0;
 end;
end;

constructor TSmartBitmap.Create;
begin
 inherited Create;
 BmpCache.Capture;
 myCacheBmp:=nil;
 myOwnedBmp:=nil;
 KillBitmap;
 ClearLinks;
end;

destructor TSmartBitmap.Destroy;
begin
 KillBitmap;
 ClearLinks;
 BmpCache.Uncapture;
 inherited Destroy;
end;

function TSmartBitmap.Clone:TSmartBitmap;
begin
 Result:=nil;
 if Assigned(Self) then
 try
  Result:=TSmartBitmap.Create;
  Result.mySource:=mySource;
  Result.myTitle:=myTitle;
  Result.myIdent:=myIdent;
  Result.myWidth:=myWidth;
  Result.myHeight:=myHeight;
  Result.myCacheBmp:=myCacheBmp;
  if Assigned(myOwnedBmp) then begin
   Result.myOwnedBmp:=TBitmap.Create;
   Result.myOwnedBmp.Assign(myOwnedBmp);
  end;
 except
  on E:Exception do begin
   BugReport(E,Self,'Clone');
   Kill(Result);
  end;
 end;
end;

procedure TSmartBitmap.Assign(Bitmap:TBitmap);
begin
 if Assigned(Self) then
 try
  KillBitmap;
  if Bitmap is TBitmap then begin
   myOwnedBmp:=TBitmap.Create;
   myOwnedBmp.Assign(Bitmap);
   myWidth:=Bitmap.Width;
   myHeight:=Bitmap.Height;
  end;
 except
  on E:Exception do begin
   BugReport(E,Self,'Assign');
   KillBitmap;
  end;
 end;
end;

procedure TSmartBitmap.LoadFromFile(const FileName:LongString; NoCache:Boolean=False);
var FName:LongString;
begin
 if Assigned(Self) then
 try
  KillBitmap;
  FName:=UnifyFileAlias(FileName);
  if NoCache then begin
   if FileIsReadable(FName) then begin
    myOwnedBmp:=TBitmap.Create;
    myOwnedBmp.LoadFromFile(FName);
    myHeight:=myOwnedBmp.Height;
    myWidth:=myOwnedBmp.Width;
    mySource:=FName;
   end;
  end else begin
   myCacheBmp:=BmpCache.Find(FName,True);
   if Assigned(myCacheBmp) then begin
    myHeight:=myCacheBmp.Height;
    myWidth:=myCacheBmp.Width;
    mySource:=FName;
   end;
  end;
 except
  on E:Exception do begin
   BugReport(E,Self,'LoadFromFile');
   KillBitmap;
  end;
 end;
end;

function TSmartBitmap.CopyBitmapTo(aTarget:TBitmap):Boolean;
var aSource:TBitmap;
begin
 Result:=False;
 if Assigned(Self) then
 try
  aSource:=CurrentBmp;
  if Assigned(aSource) then
  if Assigned(aTarget) then begin
   aTarget.Assign(aSource);
   Result:=True;
  end;
 except
  on E:Exception do BugReport(E,Self,'CopyBitmapTo');
 end;
end;

function TSmartBitmap.CreateBitmap:TBitmap;
begin
 Result:=nil;
 if Ok then
 try
  Result:=TBitmap.Create;
  Result.Assign(CurrentBmp);
 except
  on E:Exception do begin
   BugReport(E,Self,'CreateBitmap');
   Kill(Result);
  end;
 end;
end;

procedure TSmartBitmap.Draw(Canvas:TCanvas; X,Y:Integer);
var Bitmap:TBitmap;
begin
 if Ok and (Canvas is TCanvas) then
 try
  Bitmap:=CurrentBmp;
  if Bitmap is TBitmap then Canvas.Draw(X,Y,Bitmap);
 except
  on E:Exception do BugReport(E,Self,'Draw');
 end;
end;

function TSmartBitmap.GetRect(X:Integer=0; Y:Integer=0):TRect2I;
begin
 if Ok then Result:=Rect2I(X, Y, X + Width, Y + Height) else Result:=Rect2I(X,Y,X,Y);
end;

function TSmartBitmap.ExposedInsideOf(Canvas:TCanvas; X,Y:Integer):Boolean;
begin
 if Ok and (Canvas is TCanvas)
 then Result:=not RectIsEmpty(RectIntersection(GetRect(X,Y), Rect2I(Canvas.ClipRect)))
 else Result:=false;
end;

function NewSmartBitmap(const FileName : LongString = '';
                              Bitmap   : TBitmap    = nil;
                              Ident    : Integer    = 0;
                              Title    : LongString = '') : TSmartBitmap;
begin
 Result:=nil;
 try
  Result:=TSmartBitmap.Create;
  Result.Title:=Title;
  Result.Ident:=Ident;
  if IsNonEmptyStr(FileName) then begin
   Result.LoadFromFile(FileName);
   if not Result.Ok then Kill(Result);
  end else
  if (Bitmap is TBitmap) then begin
   Result.Assign(Bitmap);
   if not Result.Ok then Kill(Result);
  end;
 except
  on E:Exception do begin
   BugReport(E,nil,'NewSmartBitmap');
   Kill(Result);
  end;
 end;
end;

procedure Kill(var TheObject:TSmartBitmap); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E,nil,'Kill');
 end;
end;

 {
 *******************************************************************************
 Convert color bitmap to black and white.
 White1, White2 is colors which should be white, all other colors will be black.
 *******************************************************************************
 }
{$PUSH}
{$WARN 5044 off : Symbol "$1" is not portable}
function ConvertBmpToBlackAndWhite(Bmp:TBitmap; White1,White2:TColor; Mode:Integer=1):Boolean;
var row,col,step,gray:Integer; rgb:TColor; prow,prgb:PChar; IsFast,IsGray:Boolean;
begin
 Result:=false;
 if Assigned(Bmp) then
 try
  if (Bmp.Width<=0) or (Bmp.Height<=0) then Exit;
  if Bmp.Monochrome or (Bmp.PixelFormat=pf1Bit) then begin
   Result:=true;
   Exit;
  end;
  IsFast:=HasFlags(Mode,1);
  IsGray:=HasFlags(Mode,2);
  Bmp.PixelFormat:=pf24Bit;
  if (Bmp.PixelFormat<>pf24Bit) then Exit;
  rgb:=0; prgb:=@rgb; // NB!
  if IsFast then begin
   step:=(Bmp.RawImage.Description.BytesPerLine div Bmp.Width);
   if not InRange(step,3,4) then Exit; // Check bytes per pixel
   for row:=0 to Bmp.Height-1 do begin
    prow:=Bmp.ScanLine[row];
    if not Assigned(prow) then Exit;
    for col:=0 to Bmp.Width-1 do begin
     prgb[0]:=prow[0]; prgb[1]:=prow[1]; prgb[2]:=prow[2];
     if IsGray then begin
      gray:=(Ord(prgb[0])+Ord(prgb[1])+Ord(prgb[2])) div 3;
      prgb[0]:=Chr(gray); prgb[1]:=Chr(gray); prgb[2]:=Chr(gray);
     end else begin
      if (rgb=White1) or (rgb=White2)
      then rgb:=clWhite
      else rgb:=clBlack;
     end;
     prow[0]:=prgb[0]; prow[1]:=prgb[1]; prow[2]:=prgb[2];
     Inc(prow,step);
    end;
   end;
  end else begin
   for col:=0 to Bmp.Width-1 do
   for row:=0 to Bmp.Height-1 do begin
    rgb:=Bmp.Canvas.Pixels[col,row];
    if IsGray then begin
     gray:=(Ord(prgb[0])+Ord(prgb[1])+Ord(prgb[2])) div 3;
     prgb[0]:=Chr(gray); prgb[1]:=Chr(gray); prgb[2]:=Chr(gray);
    end else begin
     if (rgb=White1) or (rgb=White2)
     then rgb:=clWhite
     else rgb:=clBlack;
    end;
    Bmp.Canvas.Pixels[col,row]:=rgb;
   end;
  end;
  Result:=true;
 except
  on E:Exception do BugReport(E,nil,'ConvertBmpToBlackAndWhite');
 end;
end;
{$POP}

procedure SetDefaultFonts;
begin
 StandardFont.Name:=GetAvailableFontName(DefaultMonoFonts,FallbackMonoFont);
 DefaultSansFont.Name:=GetAvailableFontName(DefaultSansFonts,FallbackSansFont);
 DefaultSansNarrowFont.Name:=GetAvailableFontName(DefaultNarrowFonts,FallbackNarrowFont);
end;

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_eldraw;
begin
 SetDefaultFonts;
end;

procedure Free_crw_eldraw;
begin
 FreeFontNameByAliasHashList;
end;

initialization

 Init_crw_eldraw;

finalization

 Free_crw_eldraw;

end.

//////////////
// END OF FILE
//////////////

