 {
 ****************************************************************************
 CRW32 project
 Copyright (C) by Kuryakin Alexey, Sarov, Russia, 2001, <kouriakine@mail.ru>
 Elementary drawing utilites.
 Modifications:
  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
 ****************************************************************************
 }
unit _eldraw; { elementary drawing }

{$I ..\syslib\_sysdef}

interface

uses
 sysutils, windows, messages, classes, graphics, controls, forms, dialogs, actnlist,
 stdctrls, extctrls, comctrls, RichEdit, math, checklst, _alloc, _fpu, _fifo, _str,
 _snd, _fio, _plut, _colors, _fonts, _hl;

 {
 ***************************************************
 SmartUpdate(...) change a property and updates some
 VCL object with some checking for safety and speed.
 ***************************************************
 }
procedure SmartUpdate(aLabel:TLabel; const aCaption:ShortString); overload;
procedure SmartUpdate(aPanel:TPanel; const aCaption:ShortString); overload;
procedure SmartUpdate(aGroupBox:TGroupBox; const aCaption:ShortString); overload;
procedure SmartUpdate(aRadioGroup:TRadioGroup; const aCaption:ShortString); overload;
procedure SmartUpdate(aEdit:TEdit; const aText:ShortString); overload;
procedure SmartUpdate(aMemo:TMemo; const aText:LongString); overload;
procedure SmartUpdate(aButton:TButton; const aCaption:ShortString); overload;
procedure SmartUpdate(aListBox:TListBox; const aItems:LongString); overload;
procedure SmartUpdate(aListBox:TCheckListBox; const aItems:LongString); overload;
procedure SmartUpdate(aCheckBox:TCheckBox; const aCaption:ShortString); overload;
procedure SmartUpdate(aStatusBar:TStatusBar; aPanel:Integer; const aText:ShortString); overload;
procedure SmartUpdate(aAction:TAction; const aCaption:ShortString); 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; var 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; var 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=record
  CharSet : TFontCharSet;
  Color   : TColor;
  Height  : Integer;
  Name    : ShortString;
  Pitch   : TFontPitch;
  Style   : TFontStyles;
 end;

const
 stdFontCharSet = RUSSIAN_CHARSET;
 stdFontColor   = clBlack;
 stdFontBack    = clWhite;
 stdFontHeight  = -13;
 stdFontName    = 'Fixedsys';
 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    : 'Arial';
  Pitch   : stdFontPitch;
  Style   : stdFontStyle;
 );
 DefaultSansNarrowFont : TFontParams = (
  CharSet : stdFontCharSet;
  Color   : stdFontColor;
  Height  : stdFontHeight;
  Name    : 'Arial 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; var FontParams:TFontParams); overload;
procedure SaveFont(Source:TTextAttributes; var FontParams:TFontParams); overload;
procedure RestoreFont(Dest:TFont; const FontParams:TFontParams); overload;
procedure RestoreFont(Dest:TTextAttributes; const FontParams:TFontParams); overload;
procedure SetFont(Dest    : TFont;
                  CharSet : TFontCharSet = stdFontCharSet;
                  Color   : TColor       = stdFontColor;
                  Height  : Integer      = stdFontHeight;
            const Name    : ShortString  = stdFontName;
                  Pitch   : TFontPitch   = stdFontPitch;
            const Style   : TFontStyles  = stdFontStyle); overload;
procedure SetFont(Dest    : TTextAttributes;
                  CharSet : TFontCharSet = stdFontCharSet;
                  Color   : TColor       = stdFontColor;
                  Height  : Integer      = stdFontHeight;
            const Name    : ShortString  = 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(var Font:TFontParams; Buffer:LongString; Replacement:Boolean; const Default:TFontParams):Boolean;
function  ReadIniFileFont(var Font:TFontParams; const IniFile,Section:ShortString):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:AnsiString='_CHARSET'):AnsiString;
function  PitchToString(Pitch:TFontPitch; Suffix:AnsiString='_PITCH'):AnsiString; overload;
function  PitchToString(Pitch:Integer):AnsiString; overload;
function  FontStylesToString(const FontStyles:TFontStyles):AnsiString;
function  StringToCharset(S:AnsiString; Default:TFontCharSet):TFontCharSet;
function  StringToPitch(S:AnsiString; Default:TFontPitch):TFontPitch;
function  StringToFontStyles(S:AnsiString; 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;
                   Width  : 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;
                    Width  : 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, {000000000000000000000000b - 0  psClear}
  $FFFFFF, {111111111111111111111111b - 1  psSolid}
  $AAAAAA, {101010101010101010101010b - 2  User}
  $DDDDDD, {111011101110111011101110b - 3  User}
  $CCCCCC, {110011001100110011001100b - 4  User}
  $888888, {100010001000100010001000b - 5  User}
  $808080, {100000001000000010000000b - 6  User}
  $800000, {100000000000000000000000b - 7  User}
  $F0F0F0, {111100001111000011110000b - 8  User}
  $FF00F0, {111111110000000011110000b - 9  User}
  $FFF000, {111111111111000000000000b - 10 User}
  $FFFFC0, {111111111111111111000000b - 11 psDash}
  $E38E38, {111000111000111000111000b - 12 psDot}
  $FF81C0, {111111111000000111000000b - 13 psDashDot}
  $FF8E38, {111111111000111000111000b - 14 psDashDotDot}
  $FF0FF0);{111111110000111111110000b - 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;
                   Width  : 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    : ShortString;
                   Color  : TColor = clBlack;
                   Back   : TColor = clWhite;
                   aBrush : TBrushStyle = bsSolid);
function CreateTextBitmap(const Msg         : ShortString;
                                FontCharSet : TFontCharSet = stdFontCharSet;
                                FontColor   : TColor       = stdFontColor;
                                FontHeight  : Integer      = stdFontHeight;
                          const FontName    : ShortString  = 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:ShortString;
                      Caption:ShortString=''; 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    : ShortString;
                       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 in private memory stream and quickly
 create or draw TBitmap any time you need it. What reason to keep TBitmap in
 memory stream? Windows have limits on GDI resources. You could not create more
 then some handred TBitmap simultaneously. To read bitmaps from hard disk is too
 slow way. But if you keep bitmaps in memory stream, create and destroy TBitmap
 every time you need to draw it, you have no limits and have enough speed.
 SmartBitmap also keep filename of bitmap, identifier (any user data) and size
 of bitmap.
 *******************************************************************************
 }
type
 TSmartBitmap = class(TMasterObject)
 private
  myStream  : TMemoryStream;
  mySource  : LongString;
  myTitle   : LongString;
  myIdent   : Integer;
  myWidth   : Integer;
  myHeight  : Integer;
  function    GetSource:ShortString;
  procedure   SetSource(const aSource:ShortString);
  function    GetTitle:ShortString;
  procedure   SetTitle(const aTitle:ShortString);
  function    GetIdent:Integer;
  procedure   SetIdent(aIdent:Integer);
  function    GetWidth:Integer;
  function    GetHeight:Integer;
 protected
  function    CheckOk:Boolean; override;
 public
  constructor Create;
  destructor  Destroy; override;
  function    Clone:TSmartBitmap;
  procedure   Assign(Bitmap:TBitmap);
  procedure   LoadFromFile(const FileName:ShortString);
  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;
 public
  property    Source:ShortString    read GetSource write SetSource;  {bitmap filename}
  property    Title:ShortString     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 : ShortString = '';
                              Bitmap   : TBitmap     = nil;
                              Ident    : Integer     = 0;
                              Title    : ShortString = '') : 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.
 *******************************************************************************
 }
function ConvertBmpToBlackAndWhite(Bmp:TBitmap; White1,White2:TColor):Boolean;

implementation

 {
 ********************
 SmartUpdate routines
 ********************
 }
procedure SmartUpdate(aLabel:TLabel; const aCaption:ShortString); 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:ShortString); 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:ShortString); 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:ShortString); 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:ShortString); 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:ShortString); 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:ShortString); 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:ShortString); 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:ShortString); overload;
begin
 if Assigned(aAction) then
 if aAction.Caption<>aCaption then begin
  aAction.Caption:=aCaption;
  aAction.Update;
 end;
end;

procedure SmartFocus(Control:TWinControl);
begin
 try
  if (Control is TWinControl) and Control.CanFocus then Control.SetFocus;
 except
  on E:Exception do BugReport(E);
 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);
var
 Format : TCharFormat;
begin
 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(@Format));
  SendMessage(Handle, EM_SETCHARFORMAT, WPARAM(SCF), LPARAM(@Format))
 end;
end;

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

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

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

 {
 ************
 Pen routines
 ************
 }
procedure SavePen(Pen:TPen; var PenParams:TPenParams);
begin
 with PenParams do begin
  Color:=Pen.Color;
  Style:=Pen.Style;
  Mode :=Pen.Mode;
  Width:=Pen.Width;
 end;
end;

procedure RestorePen(Pen:TPen; const PenParams:TPenParams);
begin
 with PenParams do 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
 Pen.Color:=Color;
 Pen.Style:=Style;
 Pen.Mode:=Mode;
 Pen.Width:=Width;
end;

 {
 **************
 Brush routines
 **************
 }
procedure SaveBrush(Brush:TBrush; var BrushParams:TBrushParams);
begin
 with BrushParams do begin
  Color:=Brush.Color;
  Style:=Brush.Style;
 end;
end;

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

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

 {
 *************
 Font routines
 *************
 }
procedure SaveFont(Source:TFont; var FontParams:TFontParams); overload;
begin
 if Source is TFont then
 with FontParams do begin
  Color:=Source.Color;
  Name:=Source.Name;
  CharSet:=Source.CharSet;
  Style:=Source.Style;
  Height:=Source.Height;
  Pitch:=Source.Pitch;
 end;
end;

procedure SaveFont(Source:TTextAttributes; var FontParams:TFontParams); overload;
begin
 if Source is TTextAttributes then
 with FontParams do begin
  Color:=Source.Color;
  Name:=Source.Name;
  CharSet:=Source.CharSet;
  Style:=Source.Style;
  Height:=Source.Height;
  Pitch:=Source.Pitch;
 end;
end;

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

procedure RestoreFont(Dest:TTextAttributes; const FontParams:TFontParams); overload;
begin
 if Dest is TTextAttributes then
 with FontParams do 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    : ShortString  = 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 SetFont(Dest    : TTextAttributes;
                  CharSet : TFontCharSet = stdFontCharSet;
                  Color   : TColor       = stdFontColor;
                  Height  : Integer      = stdFontHeight;
            const Name    : ShortString  = stdFontName;
                  Pitch   : TFontPitch   = stdFontPitch;
            const Style   : TFontStyles  = stdFontStyle); overload;
begin
 if Dest is TTextAttributes 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]);
 for i:=0 to FullEmbeddedFontList.Count-1 do begin
  AddItem(FullEmbeddedFontList[i].FontName,FullEmbeddedFontList[i].FontFamily);
  AddItem(FullEmbeddedFontList[i].FontFamily,FullEmbeddedFontList[i].FontFamily);
 end;
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
  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;
  // 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(var Font:TFontParams; Buffer:LongString; Replacement:Boolean; const Default:TFontParams):Boolean;
var s:ShortString; d,n:LongInt;
 function AdjustName(const s:ShortString):ShortString;
 begin
  Result:=FindFontNameByAlias(Trim(StringReplace(s,'_',' ',[rfReplaceAll])),Font.Name);
 end;
begin
 Result:=False;
 Font:=Default;
 Buffer:=SysUtils.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,'\',CRLF,[rfReplaceAll]);
  if Pos('/',Buffer)>0 then Buffer:=StringReplace(Buffer,'/',CRLF,[rfReplaceAll]);
  if Pos('|',Buffer)>0 then Buffer:=StringReplace(Buffer,'|',CRLF,[rfReplaceAll]);
  if Pos(':',Buffer)>0 then Buffer:=StringReplace(Buffer,':',' = ',[rfReplaceAll]);
 end;
 n:=0;
 if ScanVar(svConfig,PChar(Buffer),'CharSet%s',s)<>nil then begin inc(n); Font.CharSet:=StringToCharset(s,Font.CharSet); end;
 if ScanVar(svConfig,PChar(Buffer),'Color%s',s)<>nil   then begin inc(n); Font.Color:=StringToColor(s,Font.Color);       end;
 if ScanVar(svConfig,PChar(Buffer),'Size%d',d)<>nil    then begin inc(n); if d<>0 then Font.Height:=FontSizeToHeight(d); end;
 if ScanVar(svConfig,PChar(Buffer),'Height%d',d)<>nil  then begin inc(n); if d<>0 then Font.Height:=d;                   end;
 if ScanVar(svConfig,PChar(Buffer),'Name%s',s)<>nil    then begin inc(n); Font.Name:=AdjustName(s);                      end;
 if ScanVar(svConfig,PChar(Buffer),'Pitch%a',s)<>nil   then begin inc(n); Font.Pitch:=StringToPitch(s,Font.Pitch);       end;
 if ScanVar(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:ShortString):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,'')])+CRLF+
         Format('Color   = %s',[ColorToString(Font.Color)])+CRLF+
         Format('Height  = %d',[Font.Height])+CRLF+
         Format('Name    = %s',[Font.Name])+CRLF+
         Format('Pitch   = %s',[PitchToString(Font.Pitch,'')])+CRLF+
         Format('Style   = %s',[FontStylesToString(Font.Style)])+CRLF;
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:AnsiString='_CHARSET'):AnsiString;
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:AnsiString='_PITCH'):AnsiString; 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):AnsiString; 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):AnsiString;
 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:AnsiString; Default:TFontCharSet):TFontCharSet;
var id:AnsiString;
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:AnsiString; 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:AnsiString; Default:TFontStyles):TFontStyles;
var i:Integer; w:ShortString;
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;
                   Width  : Integer   = 1);
var PenParams:TPenParams; BrushParams:TBrushParams;
begin
 with Canvas do begin
  SavePen(Pen,PenParams);
  SaveBrush(Brush,BrushParams);
  SetPen(Pen,Color,Style,Mode,Width);
  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;
                    Width  : 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,Width);
  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,Width);
  DrawLine(Canvas,Point2I(round(e6.x),round(e6.y)),e2,Color,Style,Mode,Width);
end;

procedure Markers;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;

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;
                   Width  : Integer   = 1);
var
 PenParams   : TPenParams;
 BrushParams : TBrushParams;
begin
 with Canvas do begin
  SavePen(Pen,PenParams);
  SaveBrush(Brush,BrushParams);
  SetPen(Pen,Color,Style,Mode,Width);
  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    : ShortString;
                   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         : ShortString;
                                FontCharSet : TFontCharSet = stdFontCharSet;
                                FontColor   : TColor       = stdFontColor;
                                FontHeight  : Integer      = stdFontHeight;
                          const FontName    : ShortString  = 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:=1;
   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:ShortString;
                      Caption:ShortString=''; TextColor:TColor=clNone; FontStyle:TFontStyles=[];
                      xSpace:Integer=0; ySpace:Integer=0):TBitmap;
var bmp:TBitmap; px,py:Integer;
begin
 Result:=nil;
 if not IsEmptyStr(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:=1;
   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    : ShortString;
                               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);
   _eldraw.DrawBar(Canvas,R,Back);
   _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);
 end;
end;

procedure Kill(var TheObject:TSmartDrawer); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E);
 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);
 end;
end;

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

 {
 *******************************************************************************
 TSmartBitmap implementation
 *******************************************************************************
 }
function TSmartBitmap.GetSource:ShortString;
begin
 if Assigned(Self) then Result:=mySource else Result:='';
end;

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

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

procedure TSmartBitmap.SetTitle(const aTitle:ShortString);
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(myStream);
end;

constructor TSmartBitmap.Create;
begin
 inherited Create;
 myStream:=nil;
 mySource:='';
 myTitle:='';
 myIdent:=0;
 myWidth:=0;
 myHeight:=0;
end;

destructor TSmartBitmap.Destroy;
begin
 Kill(myStream);
 mySource:='';
 myTitle:='';
 myIdent:=0;
 myWidth:=0;
 myHeight:=0;
 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;
  if Assigned(myStream) then begin
   myStream.Position:=0;
   Result.myStream:=TMemoryStream.Create;
   Result.myStream.CopyFrom(myStream,myStream.Size);
  end;
 except
  on E:Exception do begin
   BugReport(E,Self);
   Kill(Result);
  end;
 end;
end;

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

procedure TSmartBitmap.LoadFromFile(const FileName:ShortString);
var Bitmap:TBitmap;
begin
 if Assigned(Self) then
 try
  Kill(myStream);
  myWidth:=0;
  myHeight:=0;
  mySource:=FileName;
  Bitmap:=TBitmap.Create;
  try
   if Bitmap is TBitmap then begin
    myStream:=TMemoryStream.Create;
    Bitmap.LoadFromFile(FileName);
    Bitmap.SaveToStream(myStream);
    myWidth:=Bitmap.Width;
    myHeight:=Bitmap.Height;
   end;
  finally
   Kill(Bitmap);
  end;
 except
  on E:Exception do begin
   BugReport(E,Self);
   Kill(myStream);
   myWidth:=0;
   myHeight:=0;
   mySource:='';
  end;
 end;
end;

function TSmartBitmap.CreateBitmap:TBitmap;
begin
 Result:=nil;
 if Ok then
 try
  Result:=TBitmap.Create;
  myStream.Position:=0;
  Result.LoadFromStream(myStream);
 except
  on E:Exception do begin
   BugReport(E,Self);
   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:=CreateBitmap;
  try
   if Bitmap is TBitmap then Canvas.Draw(X,Y,Bitmap);
  finally
   Kill(Bitmap);
  end;
 except
  on E:Exception do BugReport(E,Self);
 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 : ShortString = '';
                              Bitmap   : TBitmap     = nil;
                              Ident    : Integer     = 0;
                              Title    : ShortString = '') : TSmartBitmap;
begin
 Result:=nil;
 try
  Result:=TSmartBitmap.Create;
  Result.Title:=Title;
  Result.Ident:=Ident;
  if 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);
   Kill(Result);
  end;
 end;
end;

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

 {
 *******************************************************************************
 Convert color bitmap to black and white.
 White1, White2 is colors which should be white, all other colors will be black.
 *******************************************************************************
 }
function ConvertBmpToBlackAndWhite(Bmp:TBitmap; White1,White2:TColor):Boolean;
var
 row  : Integer;
 col  : Integer;
 rgb  : TColor;
 prow : PChar;
 prgb : PChar;
begin
 Result:=false;
 if Assigned(Bmp) then
 try
  if Bmp.PixelFormat=pf1Bit then begin
   Result:=true;
   Exit;
  end;
  Bmp.PixelFormat:=pf24Bit;
  if Bmp.PixelFormat<>pf24Bit then Exit;
  rgb:=0;
  prgb:=@rgb;
  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 (rgb=White1) or (rgb=White2) then rgb:=$FFFFFF else rgb:=0;
    prow[0]:=prgb[0];
    prow[1]:=prgb[1];
    prow[2]:=prgb[2];
    Inc(prow,3);
   end;
  end;
  Result:=true;
 except
  on E:Exception do BugReport(E);
 end;
end;

initialization

finalization

 FreeFontNameByAliasHashList;

end.
