unit GraphicUtils;
interface
uses
	Graphics, Classes, Windows, Geomet, Contnrs, WinSpool, SimpleXml;

type
	TPalColor = class
		Color: TColor;
		Count: Integer;
	end;

	TPalColors = class
	private
		FList: TObjectList;
		FDC: HDC;
		FSavePalette: HPalette;

	public
		constructor Create(aDC: HDC);
		destructor Destroy; override;

		procedure Add(aColor: TColor);
		procedure PrepareDC;
		class function  SupportPallete(aDC: HDC): Boolean;
	end;

	PPenAttrsEx = ^TPenAttrsEx;
  {$A-}
	TPenAttrsEx = object
		Style: TPenStyle;
		WidthInMM: Double;
		ForZoomScale: Double;
		Color: TColor;
		Mode: TPenMode;

		procedure SetDefault;
		function GetWidthInMeters(aZoomScale: Double): Double;
		procedure AssignToCanvas(aCanvas: TCanvas; aZoomScale, aMetersToPixels: Double);
		procedure LoadFromStream(aStm: TStream);
		procedure SaveToStream(aStm: TStream);
		procedure LoadVersion102(aStm: TStream);
		procedure LoadVersion105(aStm: TStream);

		procedure LoadFromXML(aNode: IXmlNode);
		procedure SaveToXML(aNode: IXmlNode);

		procedure AddPalColors(aColors: TPalColors);
	end;
  {$A+}

const
	baOpaque = 0;
	baTransparent = 1;
	baHalfTransparent = 6;
	baMinTransparent = 10;

type
	PBrushAttrsEx = ^TBrushAttrsEx;
  {$A-}
	TBrushAttrsEx = object
		Style: TBrushStyle;
		BackColor,
		HatchColor: TColor;
		Transparency: Byte;

		procedure SetDefault;
		procedure AssignToCanvas(aCanvas: TCanvas);
		procedure LoadFromStream(aStm: TStream);
		procedure SaveToStream(aStm: TStream);
		procedure LoadVersion102(aStm: TStream);
		procedure LoadVersion105(aStm: TStream);

		procedure LoadFromXML(aNode: IXmlNode);
		procedure SaveToXML(aNode: IXmlNode);

		procedure AddPalColors(aColors: TPalColors);
	end;
  {$A+}

	PFontAttrsEx = ^TFontAttrsEx;
  {$A-}
	TFontAttrsEx = object
		Name: string[64];
		Style: TFontStyles;
		Color: TColor;
		Size: SmallInt;
		ForZoomScale: Double;
		Pitch: TFontPitch;
		CharSet: Byte;

		procedure SetDefault;
		procedure GetLogFont(aZoomScale, aMetersToPixels: Double; var aLogFont: TLogFont);
		procedure AssignToCanvas(aCanvas: TCanvas; aZoomScale, aMetersToPixels: Double);
		procedure LoadFromStream(aStm: TStream);
		procedure SaveToStream(aStm: TStream);
		procedure LoadVersion105(aStm: TStream);

		procedure LoadFromXML(aNode: IXmlNode);
		procedure SaveToXML(aNode: IXmlNode);

		function ChooseFont: Boolean;

		procedure AddPalColors(aColors: TPalColors);
	end;
  {$A+}


type
	PPointArray = ^TPointArray;
	TPointArray = array [0..MaxInt div sizeof(TPoint) - 1] of TPoint;

	TPointList = class
	private
		FClosed: Boolean;

		FPointsLimit,
		FPointsCount: Integer;
		FPoints: PPointArray;

		OptP1,
		OptP2: TPoint;
		FLastPt: TPoint;

		FCurPointPtr: PPoint;

		procedure SetPointsLimit(aValue: Integer);
		function AllocatePoints(aCount: Integer): PPointArray;

	public
		property PointsCount: Integer read FPointsCount;
		property Points: PPointArray read FPoints;
		property Closed: Boolean read FClosed write FClosed;

		procedure Clear;
		procedure AddPoint(aP: TPoint; aPixelVarianceWidth: Integer = 1);

		constructor Create;
		destructor Destroy; override;
		function GetBounds(var aBounds: TRect): Boolean;
	end;

	PIntegerArray = ^TIntegerArray;
	TIntegerArray = array [0..MaxInt div sizeof(Integer) - 1] of Integer;

	TPolyPointList = class(TPointList)
	private
		FCountsLimit,
		FCountsCount: Integer;
		FCounts: PIntegerArray;
		FCurCountPtr: PInteger;

		procedure SetCountsLimit(aValue: Integer);


	public
		property CountsCount: Integer read FCountsCount;
		property Counts: PIntegerArray read FCounts;

		constructor Create;
		destructor Destroy; override;

		procedure Clear;
		function AllocateCounts(aCount: Integer): PIntegerArray;
	end;

	TDevPoints = class
	private
		FPolygons: TPolyPointList;
		FPolylines: TPolyPointList;
		FSegment: TPointList;

	protected

		procedure PaintPolygons(aCanvas: TCanvas);
		procedure PaintPolylines(aCanvas: TCanvas);
		function  CanUseAlphaBlend(aCanvas: TCanvas): Boolean;
	public
		property Polygons: TPolyPointList read FPolygons;
		property Polylines: TPolyPointList read FPolylines;
		property Segment: TPointList read FSegment;

		constructor Create;
		destructor Destroy; override;

		procedure Free;

		procedure BeginUpdate;
		procedure NewSegment;
		procedure NewRectSegment(aRect: TRect; aClosed: Boolean);
		procedure EndUpdate;

		procedure Paint(aCanvas: TCanvas; const aPen: TPenAttrsEx;
			const aBrush: TBrushAttrsEx;
			const aZoomScale: Double;
			const aMetersToPixels: Double;
			anUseAlphaBled: Boolean = False); overload;

		procedure Paint(aCanvas: TCanvas); overload;

		function GetBounds(var aBounds: TRect): Boolean;
	end;


function GetDevPoints: TDevPoints;

function SetFontAttrsEx(var aDst: TFontAttrsEx; const aSrc: TFontAttrsEx): Boolean;

function FontAttrsEx(const AName: string; AStyle: TFontStyles; AColor: TColor;
	ASize: SmallInt; AForZoomScale: Double; APitch: TFontPitch; ACharSet: Byte): TFontAttrsEx;
function PenAttrsEx(aStyle: TPenStyle; aWindthInMM, aForZoomScale: Double;
	aColor: TColor; aMode: TPenMode = pmCopy): TPenAttrsEx;
function BrushAttrsEx(aStyle: TBrushStyle; aBackColor, aHatchColor: TColor;
	aTransparency: Byte): TBrushAttrsEx;
function PenAttrsEquals(const p1, p2: TPenAttrsEx): Boolean;
function BrushAttrsEquals(const b1, b2: TBrushAttrsEx): Boolean;
function FontAttrsEquals(const f1, f2: TFontAttrsEx): Boolean;

procedure ResetCanvas(aCanvas: TCanvas);
function GetMetersToPixels(aCanvas: TCanvas): TDPoint;

function GetPen(const aStyle: TPenStyle; aColor: TColor; aWidth: Integer; aMode: TPenMode): TPen;
function GetBrush(aStyle: TBrushStyle; aColor: TColor): TBrush;

type
	THSV = object
		Hue, Sat, Val: Double;
		function GetRGB: TColor;
		procedure AssignRGB(aRGB: TColor);
	end;


function ZoomScaleToStr(aZoomScale: Double): String;
function StrToZoomScale(const s: String): Double;


function CreateSafeBitmapObject: Graphics.TBitmap;
procedure FreeSafeBitmapObject(aBitmap: Graphics.TBitmap);

function CreateSafeBitmap(nWidth,	nHeight: Integer; cPlanes, cBitsPerPel: UINT;
	lpvBits: Pointer): HBITMAP;
function CreateSafeCompatibleBitmap(aDc: HDC; nWidth, nHeight: Integer): HBITMAP;
function DeleteSafeBitmap(aBmp: HBITMAP): BOOL;

const
	ClearBrush: TBrushAttrsEx = (
		Style: bsClear;
		BackColor: clWhite;
		HatchColor: clWhite;
		Transparency: baOpaque
	);
	ClearPen: TPenAttrsEx = (
		Style: psClear;
		WidthInMM: 0;
		ForZoomScale: 0;
		Color: clBlack
	);

	TransparentBrush: TBrushAttrsEx = (
		Style: bsClear;
		BackColor: clWhite;
		HatchColor: clWhite;
		Transparency: baTransparent
	);

const
	PenStyleNames: array [TPenStyle] of String = (
		'Solid', 'Dash', 'Dot', 'DashDot', 'DashDotDot', 'Clear', 'InsideFrame',
    'UserStyle', 'Alternate');
	PenModeNames: array [TPenMode] of String = (
		'Black', 'White', 'Nop', 'Not', 'Copy', 'NotCopy', 'MergePenNot',
		'MaskPenNot', 'MergeNotPen', 'MaskNotPen', 'Merge', 'NotMerge',
		'Mask', 'NotMask', 'Xor', 'NotXor');
	BrushStyleNames: array [TBrushStyle] of String = (
		'Solid', 'Clear', 'Horizontal', 'Vertical',
		'FDiagonal', 'BDiagonal', 'Cross', 'DiagCross');
	FontPitchNames: array [TFontPitch] of String = (
		'Default', 'Variable', 'Fixed');

const
	ColorTable: array[0..167] of record	Name: String; Color: TColor end = (
		(Name: 'aliceblue'; Color: $F0F8FF),
		(Name: 'antiquewhite'; Color: $FAEBD7),
		(Name: 'aqua'; Color: $00FFFF),
		(Name: 'aquamarine'; Color: $7FFFD4),
		(Name: 'azure'; Color: $F0FFFF),
		(Name: 'beige'; Color: $F5F5DC),
		(Name: 'bisque'; Color: $FFE4C4),
		(Name: 'black'; Color: $000000),
		(Name: 'blanchedalmond'; Color: $FFEBCD),
		(Name: 'blue'; Color: $0000FF),
		(Name: 'blueviolet'; Color: $8A2BE2),
		(Name: 'brown'; Color: $A52A2A),
		(Name: 'burlywood'; Color: $DEB887),
		(Name: 'cadetblue'; Color: $5F9EA0),
		(Name: 'chartreuse'; Color: $7FFF00),
		(Name: 'chocolate'; Color: $D2691E),
		(Name: 'coral'; Color: $FF7F50),
		(Name: 'cornflowerblue'; Color: $6495ED),
		(Name: 'cornsilk'; Color: $FFF8DC),
		(Name: 'crimson'; Color: $DC143C),
		(Name: 'cyan'; Color: $00FFFF),
		(Name: 'darkblue'; Color: $00008B),
		(Name: 'darkcyan'; Color: $008B8B),
		(Name: 'darkgoldenrod'; Color: $B8860B),
		(Name: 'darkgray'; Color: $A9A9A9),
		(Name: 'darkgreen'; Color: $006400),
		(Name: 'darkkhaki'; Color: $BDB76B),
		(Name: 'darkmagenta'; Color: $8B008B),
		(Name: 'darkolivegreen'; Color: $556B2F),
		(Name: 'darkorange'; Color: $FF8C00),
		(Name: 'darkorchid'; Color: $9932CC),
		(Name: 'darkred'; Color: $8B0000),
		(Name: 'darksalmon'; Color: $E9967A),
		(Name: 'darkseagreen'; Color: $8FBC8B),
		(Name: 'darkslateblue'; Color: $483D8B),
		(Name: 'darkslategray'; Color: $2F4F4F),
		(Name: 'darkturquoise'; Color: $00CED1),
		(Name: 'darkviolet'; Color: $9400D3),
		(Name: 'deeppink'; Color: $FF1493),
		(Name: 'deepskyblue'; Color: $00BFFF),
		(Name: 'dimgray'; Color: $696969),
		(Name: 'dodgerblue'; Color: $1E90FF),
		(Name: 'firebrick'; Color: $B22222),
		(Name: 'floralwhite'; Color: $FFFAF0),
		(Name: 'forestgreen'; Color: $228B22),
		(Name: 'fuchsia'; Color: $FF00FF),
		(Name: 'gainsboro'; Color: $DCDCDC),
		(Name: 'ghostwhite'; Color: $F8F8FF),
		(Name: 'gold'; Color: $FFD700),
		(Name: 'goldenrod'; Color: $DAA520),
		(Name: 'gray'; Color: $808080),
		(Name: 'green'; Color: $008000),
		(Name: 'greenyellow'; Color: $ADFF2F),
		(Name: 'honeydew'; Color: $F0FFF0),
		(Name: 'hotpink'; Color: $FF69B4),
		(Name: 'indianred'; Color: $CD5C5C),
		(Name: 'indigo'; Color: $4B0082),
		(Name: 'ivory'; Color: $FFFFF0),
		(Name: 'khaki'; Color: $F0E68C),
		(Name: 'lavender'; Color: $E6E6FA),
		(Name: 'lavenderblush'; Color: $FFF0F5),
		(Name: 'lawngreen'; Color: $7CFC00),
		(Name: 'lemonchiffon'; Color: $FFFACD),
		(Name: 'lightblue'; Color: $ADD8E6),
		(Name: 'lightcoral'; Color: $F08080),
		(Name: 'lightcyan'; Color: $E0FFFF),
		(Name: 'lightgoldenrodyellow'; Color: $FAFAD2),
		(Name: 'lightgreen'; Color: $90EE90),
		(Name: 'lightgrey'; Color: $D3D3D3),
		(Name: 'lightpink'; Color: $FFB6C1),
		(Name: 'lightsalmon'; Color: $FFA07A),
		(Name: 'lightseagreen'; Color: $20B2AA),
		(Name: 'lightskyblue'; Color: $87CEFA),
		(Name: 'lightslategray'; Color: $778899),
		(Name: 'lightsteelblue'; Color: $B0C4DE),
		(Name: 'lightyellow'; Color: $FFFFE0),
		(Name: 'lime'; Color: $00FF00),
		(Name: 'limegreen'; Color: $32CD32),
		(Name: 'linen'; Color: $FAF0E6),
		(Name: 'magenta'; Color: $FF00FF),
		(Name: 'maroon'; Color: $800000),
		(Name: 'mediumaquamarine'; Color: $66CDAA),
		(Name: 'mediumblue'; Color: $0000CD),
		(Name: 'mediumorchid'; Color: $BA55D3),
		(Name: 'mediumpurple'; Color: $9370DB),
		(Name: 'mediumseagreen'; Color: $3CB371),
		(Name: 'mediumslateblue'; Color: $7B68EE),
		(Name: 'mediumspringgreen'; Color: $00FA9A),
		(Name: 'mediumturquoise'; Color: $48D1CC),
		(Name: 'mediumvioletred'; Color: $C71585),
		(Name: 'midnightblue'; Color: $191970),
		(Name: 'mintcream'; Color: $F5FFFA),
		(Name: 'mistyrose'; Color: $FFE4E1),
		(Name: 'moccasin'; Color: $FFE4B5),
		(Name: 'navajowhite'; Color: $FFDEAD),
		(Name: 'navy'; Color: $000080),
		(Name: 'oldlace'; Color: $FDF5E6),
		(Name: 'olive'; Color: $808000),
		(Name: 'olivedrab'; Color: $6B8E23),
		(Name: 'orange'; Color: $FFA500),
		(Name: 'orangered'; Color: $FF4500),
		(Name: 'orchid'; Color: $DA70D6),
		(Name: 'palegoldenrod'; Color: $EEE8AA),
		(Name: 'palegreen'; Color: $98FB98),
		(Name: 'paleturquoise'; Color: $AFEEEE),
		(Name: 'palevioletred'; Color: $DB7093),
		(Name: 'papayawhip'; Color: $FFEFD5),
		(Name: 'peachpuff'; Color: $FFDAB9),
		(Name: 'peru'; Color: $CD853F),
		(Name: 'pink'; Color: $FFC0CB),
		(Name: 'plum'; Color: $DDA0DD),
		(Name: 'powderblue'; Color: $B0E0E6),
		(Name: 'purple'; Color: $800080),
		(Name: 'red'; Color: $FF0000),
		(Name: 'rosybrown'; Color: $BC8F8F),
		(Name: 'royalblue'; Color: $4169E1),
		(Name: 'saddlebrown'; Color: $8B4513),
		(Name: 'salmon'; Color: $FA8072),
		(Name: 'sandybrown'; Color: $F4A460),
		(Name: 'seagreen'; Color: $2E8B57),
		(Name: 'seashell'; Color: $FFF5EE),
		(Name: 'sienna'; Color: $A0522D),
		(Name: 'silver'; Color: $C0C0C0),
		(Name: 'skyblue'; Color: $87CEEB),
		(Name: 'slateblue'; Color: $6A5ACD),
		(Name: 'slategray'; Color: $708090),
		(Name: 'snow'; Color: $FFFAFA),
		(Name: 'springgreen'; Color: $00FF7F),
		(Name: 'steelblue'; Color: $4682B4),
		(Name: 'tan'; Color: $D2B48C),
		(Name: 'teal'; Color: $008080),
		(Name: 'thistle'; Color: $D8BFD8),
		(Name: 'tomato'; Color: $FF6347),
		(Name: 'turquoise'; Color: $40E0D0),
		(Name: 'violet'; Color: $EE82EE),
		(Name: 'wheat'; Color: $F5DEB3),
		(Name: 'white'; Color: $FFFFFF),
		(Name: 'whitesmoke'; Color: $F5F5F5),
		(Name: 'yellow'; Color: $FFFF00),
		(Name: 'yellowgreen'; Color: $9ACD32),

		(Name: 'activeborder'; Color: clActiveBorder),
		(Name: 'activecaption'; Color: clActiveCaption),
		(Name: 'appworkspace'; Color: clAppWorkSpace),
		(Name: 'background'; Color: clBackground),
		(Name: 'buttonface'; Color: clBtnFace),
		(Name: 'buttonhighlight'; Color: clBtnHighlight),
		(Name: 'buttonshadow'; Color: clBtnShadow),
		(Name: 'buttontext'; Color: clBtnText),
		(Name: 'captiontext'; Color: clCaptionText),
		(Name: 'graytext'; Color: clGrayText),
		(Name: 'highlight'; Color: clHighlight),
		(Name: 'highlighttext'; Color: clHighlightText),
		(Name: 'inactiveborder'; Color: clInactiveBorder),
		(Name: 'inactivecaption'; Color: clInactiveCaption),
		(Name: 'inactivecaptiontext'; Color: clInactiveCaptionText),
		(Name: 'infobackground'; Color: clInfoBk),
		(Name: 'infotext'; Color: clInfoText),
		(Name: 'menu'; Color: clMenu),
		(Name: 'menutext'; Color: clMenuText),
		(Name: 'scrollbar'; Color: clScrollBar),
		(Name: 'threeddarkshadow'; Color: cl3DDkShadow),
		(Name: 'threedface'; Color: clBtnFace),
		(Name: 'threedhighlight'; Color: clBtnHighlight),
		(Name: 'threedlightshadow'; Color: cl3DLight),
		(Name: 'threedshadow'; Color: clBtnShadow),
		(Name: 'window'; Color: clWindow),
		(Name: 'windowframe'; Color: clWindowFrame),
		(Name: 'windowtext'; Color: clWindowText));

var
	SafeBitmapObjectCount: Integer = 0;
	SafeBitmapCount: Integer = 0;

{$IFDEF DEBUG}
type
	TGDIContextData = object
		Pen: TPenData;
		Brush: TBrushData;
		BKColor: TColor;
		BKMode: String;
		ROP2: Integer;
	end;


function GetCurrentPenData(aCanvas: TCanvas): TPenData;
function GetCurrentBrushData(aCanvas: TCanvas): TBrushData;
function GetGDIContextData(aCanvas: TCanvas): TGDIContextData;
{$ENDIF}

function ColorToStr(aColor: TColor): String;
function StrToColor(const aValue: String): TColor;

implementation

{$WARN UNIT_PLATFORM OFF}
{$WARN SYMBOL_PLATFORM OFF}

uses
	InSysUtils, Dialogs, SysUtils, Versions, Math;

function ColorToStr(aColor: TColor): String;
var
	i: Integer;
begin
	for i := Low(ColorTable) to High(ColorTable) do
		if ColorTable[i].Color = aColor then begin
			Result := ColorTable[i].Name;
			Exit;
		end;

	Result := IntToHex(aColor, 8);
end;

function StrToColor(const aValue: String): TColor;
var
	aColor: Integer;
	i: Integer;

	function HexCharToByte(c: Char): Byte;
	begin
		if c in ['0'..'9'] then
			Result := Ord(c) - Ord('0')
		else if c in ['A'..'F'] then
			Result := Ord(c) - Ord('A') + 10
		else if c in ['a'..'f'] then
			Result := Ord(c) - Ord('a') + 10
		else
			raise Exception.Create('Некорректный формат цвета');
	end;

	function GetColorPart(const s: String; i: Integer): Byte;
	begin
		Result := (HexCharToByte(s[i]) shl 4) or HexCharToByte(s[i + 1]);
	end;

begin
	if (Length(aValue) = 7) and (aValue[1] = '#') then
		Result := RGB(GetColorPart(aValue, 2), GetColorPart(aValue, 4), GetColorPart(aValue, 6))
	else begin
		if not TryStrToInt('$' + aValue, aColor) then begin
			for i := Low(ColorTable) to High(ColorTable) do
				if ColorTable[i].Name = aValue then begin
					Result := ColorTable[i].Color;
					Exit;
				end;

			raise Exception.CreateFmt('Can''t convert string <%s> to color', [aValue]);
		end
		else
			Result := TColor(aColor);
	end
end;

{$R HollowMasks.Res}

var
	CachedDevPoints: TDevPoints = nil;
	CachedDevPointsInUse: Boolean = False;

var
	TransparencyMasks: array [2..10] of Graphics.TBitmap;

	OnePen: TPen;
	OneBrush: TBrush;

{$IFDEF DEBUG}
function GetCurrentPenData(aCanvas: TCanvas): TPenData;
var
	aPenData: LOGPEN;
begin
	if not Assigned(aCanvas) then
		Exit;

	Result.Handle := GetCurrentObject(aCanvas.Handle, OBJ_PEN);

	FillChar(aPenData, SizeOf(aPenData), 0);
	if GetObject(Result.Handle, SizeOf(aPenData), @aPenData) <> 0 then begin
		Result.Color := aPenData.lopnColor;
		Result.Style := TPenStyle(aPenData.lopnStyle);
		Result.Width := aPenData.lopnWidth.X;
	end
	else
		Result.Handle := HPen(-1);
end;

function GetCurrentBrushData(aCanvas: TCanvas): TBrushData;
var
	aBrushData: LOGBRUSH;
begin
	if not Assigned(aCanvas) then
		Exit;

	Result.Handle := GetCurrentObject(aCanvas.Handle, OBJ_BRUSH);
	if GetObject(Result.Handle, SizeOf(aBrushData), @aBrushData) <> 0 then begin
		Result.Color := aBrushData.lbColor;
		if aBrushData.lbStyle = BS_HATCHED then begin
			case aBrushData.lbHatch of
				HS_BDIAGONAL: Result.Style := bsBDiagonal;
				HS_CROSS: Result.Style := bsCross;
				HS_DIAGCROSS: Result.Style := bsDiagCross;
				HS_FDIAGONAL: Result.Style := bsFDiagonal;
				HS_HORIZONTAL: Result.Style := bsHorizontal;
				HS_VERTICAL: Result.Style := bsVertical;
			end;
		end
		else if aBrushData.lbStyle = BS_SOLID then
			Result.Style := bsSolid
		else if aBrushData.lbStyle = BS_NULL then
			Result.Style := bsClear
		else
			Result.Style := TBrushStyle(-1)
	end else
		Result.Handle := HBrush(-1);
end;

function GetGDIContextData(aCanvas: TCanvas): TGDIContextData;
begin
	if not Assigned(aCanvas) then
		Exit;

	Result.Pen := GetCurrentPenData(aCanvas);
	Result.Brush := GetCurrentBrushData(aCanvas);
	Result.BKColor := GetBkColor(aCanvas.Handle);
	case GetBkMode(aCanvas.Handle) of
		OPAQUE: Result.BKMode := 'OPAQUE';
		TRANSPARENT: Result.BKMode := 'TRANSPARENT';
	else
		Result.BKMode := 'OTHER'
	end;
	Result.ROP2 := GetROP2(aCanvas.Handle);
end;
{$ENDIF}

function CreateSafeBitmapObject: Graphics.TBitmap;
begin
	Result := Graphics.TBitmap.Create;
	Inc(SafeBitmapObjectCount);
end;

procedure FreeSafeBitmapObject(aBitmap: Graphics.TBitmap);
begin
	Dec(SafeBitmapObjectCount);
	aBitmap.Free;
end;


function CreateSafeBitmap(nWidth,	nHeight: Integer; cPlanes, cBitsPerPel: UINT;
	lpvBits: Pointer): HBITMAP;
begin
	Result := CreateBitmap(nWidth, nHeight, cPlanes, cBitsPerPel, lpvBits);
	Inc(SafeBitmapCount)
end;

function CreateSafeCompatibleBitmap(aDc: HDC; nWidth, nHeight: Integer): HBITMAP;
begin
	Result := CreateCompatibleBitmap(aDc, nWidth, nHeight);
	Inc(SafeBitmapCount)
end;

function DeleteSafeBitmap(aBmp: HBITMAP): BOOL;
begin
	Dec(SafeBitmapCount);
	Result := DeleteObject(aBmp);
end;

function ZoomScaleToStr(aZoomScale: Double): String;
begin
	if aZoomScale = 0 then
		Result := '0'
	else
		Result := FloatToStr(1/aZoomScale)
end;

function StrToZoomScale(const s: String): Double;
begin
	Result := StringToFloat(s);
	if Result <> 0 then
		Result := 1/Result;
end;

procedure THSV.AssignRGB(aRGB: TColor);
var
	aT, aMin, aMax, aR, aG, aB: Double;
begin
	aR := aRGB and $000000FF / 255;
	aG := aRGB and $0000FF00 shr 8 / 255;
	aB := aRGB and $00FF0000 shr 16 / 255;
	aMax := Max(aR, Max(aG, aB));
	aMin := Min(aR, Min(aG, aB));
	Val := aMax;
	if aMax <> 0 then
		Sat := (aMax - aMin)/aMax
	else
		Sat := 0;
	if Sat = 0 then
		Hue := 0
	else begin
		if aR = aMax then
			aT := (aG - aB)/(aMax - aMin)
		else if aG = aMax then
			aT := 2 + (aB - aR)/(aMax - aMin)
		else
			aT := 4 + (aR - aG)/(aMax - aMin);
		aT := aT / 6;
		if aT < 0 then
			aT := aT + 1;
		Hue := aT
	end
end;

function THSV.GetRGB: TColor;
var
	i: Integer;
	aH, aF, aP, aQ, aT: Double;
begin
	if Val = 0 then
		Result := $00000000
	else if Sat = 0 then
		Result := Round(255*Val) + Round(255*Val) shl 8 + Round(255*Val) shl 16
	else begin
		if Hue = 1 then
			aH := 0
		else
			aH := Hue;
		i := Trunc(6*aH);
		aF := 6*aH - i;
		aP := Val*(1 - Sat);
		aQ := Val*(1 - Sat*aF);
		aT := Val*(1 - Sat*(1 - aF));
		case i of
			0: Result := Round(255*Val) + Round(255*aT) shl 8 + Round(255*aP) shl 16;
			1: Result := Round(255*aQ) + Round(255*Val) shl 8 + Round(255*aP) shl 16;
			2: Result := Round(255*aP) + Round(255*Val) shl 8 + Round(255*aT) shl 16;
			3: Result := Round(255*aP) + Round(255*aQ) shl 8 + Round(255*Val) shl 16;
			4: Result := Round(255*aT) + Round(255*aP) shl 8 + Round(255*Val) shl 16;
		else
			Result := Round(255*Val) + Round(255*aP) shl 8 + Round(255*aQ) shl 16;
		end
	end
end;

function FontAttrsEx(const AName: string; AStyle: TFontStyles; AColor: TColor;
	ASize: SmallInt; AForZoomScale: Double; APitch: TFontPitch; ACharSet: Byte): TFontAttrsEx;
begin
	with Result do begin
		Name := AName;
		Style := AStyle;
		Color := AColor;
		Size := ASize;
		ForZoomScale := AForZoomScale;
		Pitch := APitch;
		CharSet := ACharSet;
	end;
end;

function PenAttrsEx(aStyle: TPenStyle; aWindthInMM, aForZoomScale: Double;
	aColor: TColor; aMode: TPenMode): TPenAttrsEx;
begin
	with Result do begin
		Style := aStyle;
		WidthInMM := aWindthInMM;
		ForZoomScale := aForZoomScale;
		Color := aColor;
		Mode := aMode
	end;
end;

function BrushAttrsEx(aStyle: TBrushStyle; aBackColor, aHatchColor: TColor;
	aTransparency: Byte): TBrushAttrsEx;
begin
	with Result do begin
		Style := aStyle;
		BackColor := aBackColor;
		HatchColor := aHatchColor;
		Transparency := aTransparency;
	end;
end;

function PenAttrsEquals(const p1, p2: TPenAttrsEx): Boolean;
begin
	Result :=
		(p1.Style = p2.Style) and
		(p1.WidthInMM = p2.WidthInMM) and
		(p1.ForZoomScale = p2.ForZoomScale) and
		(p1.Color = p2.Color) and
		(p1.Mode = p2.Mode);
end;

function BrushAttrsEquals(const b1, b2: TBrushAttrsEx): Boolean;
begin
	Result :=
		(b1.Style = b2.Style) and
		(b1.BackColor = b2.BackColor) and
		(b1.HatchColor = b2.HatchColor) and
		(b1.Transparency = b2.Transparency);
end;

function FontAttrsEquals(const f1, f2: TFontAttrsEx): Boolean;
begin
	Result :=
		(f1.Name = f2.Name) and
		(f1.Style = f2.Style) and
		(f1.Color = f2.Color) and
		(f1.Size = f2.Size) and
		(f1.ForZoomScale = f2.ForZoomScale) and
		(f1.Pitch = f2.Pitch) and
		(f1.CharSet = f2.CharSet)
end;

function SetFontAttrsEx(var aDst: TFontAttrsEx; const aSrc: TFontAttrsEx): Boolean;
begin
	with aDst do
		Result := HasChanges([
			SetShortString(Name, sizeof(Name), aSrc.Name),
			SetFontStyle(Style, aSrc.Style),
			SetColor(Color, aSrc.Color),
			SetSmallint(Size, aSrc.Size),
			SetDouble(ForZoomScale, aSrc.ForZoomScale),
			SetFontPitch(Pitch, aSrc.Pitch),
			SetByte(CharSet, aSrc.CharSet)]);
end;

function GetPen(const aStyle: TPenStyle; aColor: TColor;
	aWidth: Integer; aMode: TPenMode): TPen;
begin
	Result := OnePen;
	with Result do begin
		Color := aColor;
		Width := aWidth;
		Style := aStyle;
		Mode := aMode;
	end;
end;

function GetBrush(aStyle: TBrushStyle; aColor: TColor): TBrush;
begin
	Result := OneBrush;
	with Result do begin
		Color := aColor;
		Style := aStyle;
	end;
end;

{	TPenAttrsEx }

procedure TPenAttrsEx.SetDefault;
begin
	Style := psSolid;
	WidthInMM := 0;
	ForZoomScale := 1;
	Color := clBlack;
	Mode := pmCopy;
end;

function TPenAttrsEx.GetWidthInMeters(aZoomScale: Double): Double;
begin
	if (Style in [psSolid, psInsideFrame]) and (WidthInMM <> 0) then
		if ForZoomScale = 0 then
			Result := WidthInMM/1000
		else
			Result := WidthInMM*(aZoomScale/ForZoomScale)/1000.0
	else
		Result := 0;
end;

procedure TPenAttrsEx.AssignToCanvas(aCanvas: TCanvas;
	aZoomScale, aMetersToPixels: Double);
var
	aStyle: TPenStyle;
	aWidth: Integer;
begin
	aWidth := Round(GetWidthInMeters(aZoomScale)*aMetersToPixels);

	if Style = psInsideFrame then
		aStyle := psSolid
	else
		aStyle := Style;

	aCanvas.Pen := GetPen(aStyle, Color, aWidth, Mode);
	SetBkMode(aCanvas.Handle, TRANSPARENT);
end;

procedure TPenAttrsEx.LoadFromStream(aStm: TStream);
begin
	if DataVersion < $0119 then begin
		aStm.ReadBuffer(Self, sizeof(Self) - sizeof(TPenMode));
		if DataVersion < $010F then
			if ForZoomScale <> 0 then
				ForZoomScale := 1/ForZoomScale;
		Mode := pmCopy;
	end
	else begin
		aStm.ReadBuffer(Self, sizeof(Self));
		if (Ord(Mode) < Ord(Low(Mode))) or (Ord(Mode) > Ord(High(Mode))) then begin
			{todo: нужна проверка при загрузке структуры карты}
			Mode := pmCopy
		end
	end;
end;

procedure TPenAttrsEx.SaveToStream(aStm: TStream);
begin
	aStm.WriteBuffer(Self, sizeof(Self));
end;

procedure TPenAttrsEx.LoadFromXML(aNode: IXmlNode);
begin
	if aNode = nil then
		SetDefault
	else begin
		Style := TPenStyle(aNode.GetEnumAttr('Style', PenStyleNames, Ord(psSolid)));
		WidthInMM := aNode.GetFloatAttr('Width', 0);
		ForZoomScale := aNode.GetFloatAttr('WidthScale', 0);
		Color := StrToColor(aNode.GetAttr('Color',  'black'));
		Mode := TPenMode(aNode.GetEnumAttr('Mode', PenModeNames, Ord(pmCopy)));
	end
end;

procedure TPenAttrsEx.SaveToXML(aNode: IXmlNode);
begin
	aNode.SetAttr('Style', PenStyleNames[Style]);
	aNode.SetFloatAttr('Width', WidthInMM);
	aNode.SetFloatAttr('WidthScale', ForZoomScale);
	aNode.SetAttr('Color', ColorToStr(Color));
	aNode.SetAttr('Mode', PenModeNames[Mode]);
end;

procedure TPenAttrsEx.LoadVersion102(aStm: TStream);
var
	anAttrs102: packed record
		Color: TColor;
		Mode: TPenMode;
		Style: TPenStyle;
		Width: SmallInt;
	end;
begin
	aStm.Read(anAttrs102, sizeof(anAttrs102));
	Style := anAttrs102.Style;
	WidthInMM := 0;
	ForZoomScale := 0;
	Color := anAttrs102.Color;
	Mode := pmCopy;
end;

procedure TPenAttrsEx.LoadVersion105(aStm: TStream);
var
	anAttrs105: packed record
		Style: TPenStyle;
		Color: TColor;
		Width: SmallInt;
		Mode: TPenMode;
	end;
begin
	aStm.Read(anAttrs105, sizeof(anAttrs105));
	Style := TPenStyle(anAttrs105.Style);
	WidthInMM := 0;
	ForZoomScale := 0;
	Color := anAttrs105.Color;
	Mode := pmCopy;
end;

procedure TPenAttrsEx.AddPalColors(aColors: TPalColors);
begin
	if Style <> psClear then
		aColors.Add(Color);
end;

{	TBrushAttrsEx }

procedure TBrushAttrsEx.SetDefault;
begin
	Style := bsSolid;
	BackColor := clWhite;
	HatchColor := clBlack;
	Transparency := baOpaque;
end;

procedure TBrushAttrsEx.AssignToCanvas(aCanvas: TCanvas);
var
	aStyle: TBrushStyle;
begin
	if (Style = bsSolid) and (Transparency > baOpaque) then
		aStyle := bsClear
	else
		aStyle := Style;

	case aStyle of
		bsClear: aCanvas.Brush := GetBrush(bsClear, clWhite);
		bsSolid: begin
				aCanvas.Pen.Mode := pmCopy;
				aCanvas.Brush := GetBrush(bsSolid, BackColor);
				SetBkMode(aCanvas.Handle, OPAQUE);
			end;
		else begin
			aCanvas.Pen.Mode := pmCopy;
			aCanvas.Brush := GetBrush(aStyle, HatchColor);
			if Transparency > baOpaque then begin
				SetBkColor(aCanvas.Handle, $FFFFFF);
				SetBkMode(aCanvas.Handle, TRANSPARENT)
			end
			else begin
				SetBkMode(aCanvas.Handle, OPAQUE);
				SetBkColor(aCanvas.Handle, ColorToRGB(BackColor));
			end;
		end;
	end;
end;

procedure TBrushAttrsEx.LoadFromStream(aStm: TStream);
begin
	aStm.ReadBuffer(Self, sizeof(Self));
	if Transparency > baMinTransparent then
		Transparency := baTransparent;
end;

procedure TBrushAttrsEx.SaveToStream(aStm: TStream);
begin
	aStm.WriteBuffer(Self, sizeof(Self));
end;

procedure TBrushAttrsEx.LoadFromXML(aNode: IXmlNode);
begin
	if aNode = nil then
		SetDefault
	else begin
		Style := TBrushStyle(aNode.GetEnumAttr('Style', BrushStyleNames, Ord(bsSolid)));
		BackColor := StrToColor(aNode.GetAttr('BackColor', 'white'));
		HatchColor := StrToColor(aNode.GetAttr('HatchColor', 'black'));
		Transparency := aNode.GetIntAttr('Transparency', baOpaque);
	end
end;

procedure TBrushAttrsEx.SaveToXML(aNode: IXmlNode);
begin
	aNode.SetAttr('Style', BrushStyleNames[Style]);
	aNode.SetAttr('BackColor', ColorToStr(BackColor));
	aNode.SetAttr('HatchColor', ColorToStr(HatchColor));
	aNode.SetIntAttr('Transparency', Transparency);
end;

procedure TBrushAttrsEx.LoadVersion102(aStm: TStream);
var
	anAttrs102: packed record
		Style: TBrushStyle;
		Color: TColor;
	end;
begin
	aStm.Read(anAttrs102, sizeof(anAttrs102));
	Style := anAttrs102.Style;
	if Style = bsSolid then begin
		BackColor := anAttrs102.Color;
		HatchColor := clBlack;
		Transparency := baOpaque;
	end
	else begin
		BackColor := clWhite;
		HatchColor := anAttrs102.Color;
		Transparency := baTransparent;
	end;
end;

procedure TBrushAttrsEx.LoadVersion105(aStm: TStream);
var
	anAttrs105: packed record
		Style: TBrushStyle;
		Color: TColor;
	end;
begin
	aStm.Read(anAttrs105, sizeof(anAttrs105));
	Style := TBrushStyle(anAttrs105.Style);
	if Style = bsSolid then begin
		BackColor := anAttrs105.Color;
		HatchColor := clBlack;
		Transparency := baOpaque;
	end
	else begin
		BackColor := clWhite;
		HatchColor := anAttrs105.Color;
		Transparency := baTransparent;
	end;
end;

procedure TBrushAttrsEx.AddPalColors(aColors: TPalColors);
begin
	if Style <> bsClear then
		aColors.Add(BackColor);

	if Style in [bsHorizontal, bsVertical, bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross] then
		aColors.Add(HatchColor);
end;

{	TFontAttrsEx }

procedure TFontAttrsEx.AssignToCanvas(aCanvas: TCanvas;
	aZoomScale, aMetersToPixels: Double);
var
	aLogFont: TLogFont;
begin
	GetLogFont(aZoomScale, aMetersToPixels, aLogFont);
	aCanvas.Font.Handle := CreateFontIndirect(aLogFont);
	SetTextColor(aCanvas.Handle, Color);
end;

procedure TFontAttrsEx.LoadFromStream(aStm: TStream);
begin
	Name := ReadString(aStm);
	aStm.ReadBuffer(Style,
		sizeof(Style) +
		sizeof(Color) +
		sizeof(Size) +
		sizeof(ForZoomScale) +
		sizeof(Pitch) +
		sizeof(CharSet));
	if DataVersion < $010F then
		if ForZoomScale <> 0 then
			ForZoomScale := 1/ForZoomScale;
end;

procedure TFontAttrsEx.SaveToStream(aStm: TStream);
begin
	WriteString(aStm, Name);
	aStm.WriteBuffer(Style,
		sizeof(Style) +
		sizeof(Color) +
		sizeof(Size) +
		sizeof(ForZoomScale) +
		sizeof(Pitch) +
		sizeof(CharSet));
end;

procedure TFontAttrsEx.LoadFromXML(aNode: IXmlNode);
var
	aStyle: TStringList;
begin
	if aNode = nil then
		SetDefault
	else begin
		Name := aNode.GetAttr('Name', 'Arial');
		Style := [];
		aStyle := TStringList.Create;
		try
			aStyle.Delimiter := ' ';
			aStyle.DelimitedText := aNode.GetAttr('Style');
			if aStyle.IndexOf('Bold') <> -1 then
				Include(Style, fsBold);
			if aStyle.IndexOf('Italic') <> -1 then
				Include(Style, fsItalic);
			if aStyle.IndexOf('Underline') <> -1 then
				Include(Style, fsUnderline);
			if aStyle.IndexOf('StrikeOut') <> -1 then
				Include(Style, fsStrikeOut);
		finally
			aStyle.Free
		end;
		Color := StrToColor(aNode.GetAttr('Color', 'black'));
		Size := aNode.GetIntAttr('Size', 10);
		ForZoomScale := aNode.GetFloatAttr('SizeScale');
		Pitch := TFontPitch(aNode.GetEnumAttr('Pitch', FontPitchNames, Ord(fpDefault)));
		CharSet := aNode.GetIntAttr('CharSet', RUSSIAN_CHARSET);
	end
end;

procedure TFontAttrsEx.SaveToXML(aNode: IXmlNode);
var
	aStyle: TStringList;
begin
	aNode.SetAttr('Name', Name);
	aStyle := TStringList.Create;
	try
		aStyle.Delimiter := ' ';
		if fsBold in Style then
			aStyle.Add('Bold');
		if fsItalic in Style then
			aStyle.Add('Italic');
		if fsUnderline in Style then
			aStyle.Add('Underline');
		if fsStrikeOut in Style then
			aStyle.Add('StrikeOut');

		aNode.SetAttr('Style', aStyle.DelimitedText);
	finally
		aStyle.Free
	end;

	aNode.SetAttr('Color', ColorToStr(Color));
	aNode.SetIntAttr('Size', Size);
	aNode.SetFloatAttr('SizeScale', ForZoomScale);
	aNode.SetAttr('Pitch', FontPitchNames[Pitch]);
	aNode.SetIntAttr('CharSet', CharSet);
end;

procedure TFontAttrsEx.LoadVersion105(aStm: TStream);
var
	anAttrs105: packed record
		Name: string[65];
		Color: TColor;
		Size: SmallInt;
		Pitch: SmallInt;
		Style: SmallInt;
	end;
begin
	aStm.ReadBuffer(anAttrs105, sizeof(anAttrs105));
	Name := anAttrs105.Name;
	Style := TFontStyles(Pointer(@anAttrs105.Style)^);
	Color := anAttrs105.Color;
	Size := anAttrs105.Size;
	ForZoomScale := 0;
	Pitch := TFontPitch(anAttrs105.Pitch);
	CharSet := 0;
end;

function TFontAttrsEx.ChooseFont: Boolean;

	function PrinterExists: Boolean;
	var
		Flags, Count, NumInfo: DWORD;
		Level: Byte;
	begin
		if Win32Platform = VER_PLATFORM_WIN32_NT then	begin
			Flags := PRINTER_ENUM_CONNECTIONS or PRINTER_ENUM_LOCAL;
			Level := 4;
		end
		else	begin
			Flags := PRINTER_ENUM_LOCAL;
			Level := 5;
		end;
		Count := 0;
		EnumPrinters(Flags, nil, Level, nil, 0, Count, NumInfo);
		Result := Count > 0;
	end;

var
	aFontDialog: TFontDialog;
begin
	aFontDialog := TFontDialog.Create(nil);
	try
		with aFontDialog do begin
			Options := [
				fdForceFontExist,
				fdNoVectorFonts,
				fdScalableOnly,
				fdTrueTypeOnly,
				fdEffects];

			if PrinterExists then
				Device := fdBoth
			else
				Device := fdScreen;
		end;

		with aFontDialog.Font do begin
			Color := Self.Color;
			Name := Self.Name;
			Size := Self.Size;
			Pitch := Self.Pitch;
			Style := Self.Style;
			CharSet := Self.CharSet;
		end;

		Result := aFontDialog.Execute;
		if Result then begin
			with aFontDialog.Font do begin
				Self.Color := Color;
				Self.Name := Name;
				Self.Size := Size;
				Self.Pitch := Pitch;
				Self.Style := Style;
				Self.CharSet := CharSet;
			end;
		end;
	finally
		aFontDialog.Free;
	end;
end;

procedure TFontAttrsEx.SetDefault;
begin
	Name := 'Arial';
	Style := [];
	Color := clBlack;
	Size := 10;
	ForZoomScale := 1;
	Pitch := fpDefault;
	CharSet := RUSSIAN_CHARSET;
end;

procedure TFontAttrsEx.GetLogFont(aZoomScale, aMetersToPixels: Double;
	var aLogFont: TLogFont);
begin
	if ForZoomScale = 0 then
		aZoomScale := 1
	else
		aZoomScale := aZoomScale/ForZoomScale;
	FillChar(aLogFont, sizeof(aLogFont), #0);
	with aLogFont do begin
		lfHeight := -Round((Self.Size*0.0254/72.0)*aZoomScale*aMetersToPixels);
		if fsBold in Self.Style then
			lfWeight := FW_BOLD
		else
			lfWeight := FW_NORMAL;
		lfItalic := Byte(fsItalic in Self.Style);
		lfUnderline := Byte(fsUnderline in Self.Style);
		lfStrikeOut := Byte(fsStrikeOut in Self.Style);
		lfCharSet := Self.CharSet;
		StrPCopy(lfFaceName, Self.Name);
		{ Everything else as default }
		lfQuality := DEFAULT_QUALITY;
		lfOutPrecision := OUT_DEFAULT_PRECIS;
		lfClipPrecision := CLIP_DEFAULT_PRECIS;
		case Self.Pitch of
			fpVariable: lfPitchAndFamily := VARIABLE_PITCH;
			fpFixed: lfPitchAndFamily := FIXED_PITCH;
		else
			lfPitchAndFamily := DEFAULT_PITCH;
		end;
	end;
end;

procedure TFontAttrsEx.AddPalColors(aColors: TPalColors);
begin
	aColors.Add(Color);
end;

procedure ResetCanvas(aCanvas: TCanvas);
begin
	with aCanvas do begin
		with Brush do begin
			Style := bsClear;
			Style := bsSolid;
			Color := clWhite;
		end;
		with Pen do begin
			Style := psClear;
			Style := psSolid;
			Color := clBlack;
			Width := 0;
			Mode := pmXor;
			Mode := pmCopy;
		end;
		CopyMode := cmSrcAnd;
		CopyMode := cmSrcCopy;
		SetBkMode(Handle, OPAQUE);
		SetBkColor(Handle, ColorToRGB(clWhite));
		SetTextColor(Handle, ColorToRGB(clBlack));
	end;
end;

function GetMetersToPixels(aCanvas: TCanvas): TDPoint;
begin
	Result.X := GetDeviceCaps(aCanvas.Handle, LOGPIXELSX)/0.0254;
	Result.Y := GetDeviceCaps(aCanvas.Handle, LOGPIXELSY)/0.0254;
end;

procedure InitTransparencyMasks;
var
	i: Integer;
begin
	for i := 2 to 10 do begin
		TransparencyMasks[i] := CreateSafeBitmapObject;
		TransparencyMasks[i].LoadFromResourceName(HInstance, 'HOLLOW_' + IntToStr(i));
	end;
end;

procedure DoneTransparencyMasks;
var
	i: Integer;
begin
	for i := 2 to 10 do
		FreeSafeBitmapObject(TransparencyMasks[i]);
end;


{ TPalColors }
constructor TPalColors.Create(aDC: HDC);
begin
	inherited Create;
	FDC := aDC;
	FList := TObjectList.Create(true);
end;

destructor TPalColors.Destroy;
begin
	if FSavePalette <> 0 then
		DeleteObject(SelectPalette(FDC, FSavePalette, false));

	FList.Free;
	inherited;
end;

procedure TPalColors.Add(aColor: TColor);
var
	aPalColor: TPalColor;
	i: integer;
begin
	for i := 0 to FList.Count-1 do
		if TPalColor(FList[i]).Color = aColor then begin
			Inc(TPalColor(FList[i]).Count);
			Exit;
		end;

	aPalColor := TPalColor.Create;
	aPalColor.Color := aColor;
	aPalColor.Count := 1;

	FList.Add(aPalColor);
end;

function ComparePalCols(aP1, aP2: Pointer): integer;
begin
	Result := TPalColor(aP2).Count - TPalColor(aP1).Count;
end;

procedure TPalColors.PrepareDC;
var
	aPalette: HPALETTE;
	aPaletteSize: Integer;
	aLOGPALETTE: PLOGPALETTE;
	aP: PPaletteEntry;
	i: integer;
begin
	if (GetDeviceCaps(FDC, RASTERCAPS) and RC_PALETTE) <> 0 then begin
		FList.Sort(ComparePalCols);

		aPaletteSize := GetDeviceCaps(FDC, SIZEPALETTE);
		if FList.Count < aPaletteSize then
			aPaletteSize := FList.Count;

		aLOGPALETTE := AllocMem(SizeOf(LOGPALETTE)+(aPaletteSize-1)*SizeOf(TPaletteEntry));
		aLOGPALETTE.palVersion := $300;
		aLOGPALETTE.palNumEntries := aPaletteSize;

		aP := @aLOGPALETTE.palPalEntry[0];
		for i := 0 to aPaletteSize-1 do begin
			with TPalColor(FList[i]) do begin
				aP.peRed := GetRValue(ColorToRGB(Color));
				aP.peGreen := GetGValue(ColorToRGB(Color));
				aP.peBlue := GetBValue(ColorToRGB(Color));
				aP.peFlags := 0;
			end;
			Inc(aP);
		end;

		aPalette := CreatePalette(aLOGPALETTE^);
		FSavePalette := SelectPalette(FDC, aPalette, false);
		RealizePalette(FDC);

		FreeMem(aLOGPALETTE);
	end;
end;

class function TPalColors.SupportPallete(aDC: HDC): Boolean;
begin
	Result := (GetDeviceCaps(aDC, RASTERCAPS) and RC_PALETTE) <> 0;
end;


{	TPointList }

const
	PointsDelta = 32;
	CountsDelta = 32;

constructor TPointList.Create;
begin
	inherited Create;
	Clear
end;

destructor TPointList.Destroy;
begin
	if Assigned(FPoints) then
		FreeMem(FPoints);
	inherited Destroy;
end;

procedure TPointList.Clear;
begin
	FClosed := False;
	FPointsCount := 0;
	FCurPointPtr := PPoint(FPoints);
end;

procedure TPointList.SetPointsLimit(aValue: Integer);
var
	aCurPointOffset: Integer;
begin
	if aValue > FPointsLimit then begin
		aCurPointOffset := PChar(FCurPointPtr) - PChar(FPoints);
		ReallocMem(FPoints, aValue * sizeof(TPoint));
		FPointsLimit := aValue;
		FCurPointPtr := PPoint(PChar(FPoints) + aCurPointOffset);
	end;
end;

procedure TPointList.AddPoint(aP: TPoint; aPixelVarianceWidth: Integer = 1);

	function Between(i, i1, i2: Integer): Boolean;
	begin
		if i2 > i1 then
			Result := (i >= (i1 - aPixelVarianceWidth + 1)) and (i <= (i2 + aPixelVarianceWidth - 1))
		else
			Result := (i >= (i2 - aPixelVarianceWidth + 1)) and (i <= (i1 + aPixelVarianceWidth - 1))
	end;

	procedure Optimize;
	var
		aLastPtr: PPoint;
	begin
		aLastPtr := FCurPointPtr;
		Dec(aLastPtr);
		if ((aP.x - OptP1.x) * (OptP2.y - OptP1.y) div aPixelVarianceWidth =
			(aP.y - OptP1.y) * (OptP2.x - OptP1.x) div aPixelVarianceWidth) and
			Between(OptP2.x, OptP1.x, aP.x) and
			Between(OptP2.y, OptP1.y, aP.y)
		then
			aLastPtr^ := aP
		else begin
			OptP1 := aLastPtr^;
			OptP2 := aP;
			PPoint(AllocatePoints(1))^ := aP;
		end;
	end;

begin
	if FPointsCount > 1 then begin
		if (FLastPt.X <> aP.X) or (FLastPt.Y <> aP.Y) then begin
			FLastPt := aP;
			Optimize
		end;
	end
	else begin
		if FPointsCount = 0 then
			OptP1 := aP
		else if (FLastPt.X <> aP.X) or (FLastPt.Y <> aP.Y) then
			OptP2 := aP
		else
			Exit;
		FLastPt := aP;
		PPoint(AllocatePoints(1))^ := aP;
	end;
end;

function TPointList.AllocatePoints(aCount: Integer): PPointArray;
begin
	if FPointsCount + aCount > FPointsLimit then
		SetPointsLimit(FPointsCount + aCount + PointsDelta);
	Result := PPointArray(FCurPointPtr);
	Inc(FCurPointPtr, aCount);
	Inc(FPointsCount, aCount)
end;

function TPointList.GetBounds(var aBounds: TRect): Boolean;
var
	aPtr: PPoint;
	i: Integer;
begin
	aPtr := Pointer(FPoints);
	Result := FPointsCount > 0;
	if Result then begin
		SetRect(aBounds, aPtr^.x, aPtr^.y, aPtr^.x, aPtr^.y);
		for i := 1 to FPointsCount - 1 do begin
			Inc(aPtr);
			ExpandRect(aBounds, aPtr^)
		end
	end;
end;

{	TPolyPointList }

constructor TPolyPointList.Create;
begin
	inherited Create;
	Clear
end;

destructor TPolyPointList.Destroy;
begin
	if Assigned(FCounts) then
		FreeMem(FCounts);
	inherited Destroy;
end;

procedure TPolyPointList.Clear;
begin
	inherited Clear;
	FCountsCount := 0;
	FCurCountPtr := PInteger(FCounts);
end;

procedure TPolyPointList.SetCountsLimit(aValue: Integer);
var
	aCurCountOffset: Integer;
begin
	if aValue > FCountsLimit then begin
		aCurCountOffset := PChar(FCurCountPtr) - PChar(FCounts);
		ReallocMem(FCounts, aValue * sizeof(Integer));
		FCountsLimit := aValue;
		FCurCountPtr := PInteger(PChar(FCounts) + aCurCountOffset);
	end;
end;

function TPolyPointList.AllocateCounts(aCount: Integer): PIntegerArray;
begin
	if FCountsCount + aCount > FCountsLimit then
		SetCountsLimit(FCountsCount + aCount + CountsDelta);
	Result := PIntegerArray(FCurCountPtr);
	Inc(FCurCountPtr, aCount);
	Inc(FCountsCount, aCount)
end;

function GetDevPoints: TDevPoints;
begin
	if CachedDevPoints = nil then
		CachedDevPoints := TDevPoints.Create;

	if CachedDevPointsInUse then
		Result := TDevPoints.Create
	else begin
		Result := CachedDevPoints;
		CachedDevPointsInUse := True;
	end;
end;

constructor TDevPoints.Create;
begin
	inherited Create;
	FPolygons := TPolyPointList.Create;
	FPolylines := TPolyPointList.Create;
	FSegment := TPointList.Create;
end;

destructor TDevPoints.Destroy;
begin
	FSegment.Free;
	FPolylines.Free;
	FPolygons.Free;
	inherited Destroy;
end;

procedure TDevPoints.Free;
begin
	if Self = CachedDevPoints then
		CachedDevPointsInUse := False
	else
		inherited Free;
end;

procedure TDevPoints.BeginUpdate;
begin
	FPolygons.Clear;
	FPolylines.Clear;
	FSegment.Clear;
end;

procedure TDevPoints.NewSegment;
var
	aDst: TPolyPointList;
	aCountPtr: PInteger;
begin
	if FSegment.PointsCount > 1 then begin
		if FSegment.Closed then begin
			aDst := FPolygons;
			FSegment.AddPoint(FSegment.Points[0])
		end else
			aDst := FPolylines;
		aCountPtr := PInteger(aDst.AllocateCounts(1));
		aCountPtr^ := FSegment.PointsCount;
		Move(FSegment.Points^, aDst.AllocatePoints(FSegment.PointsCount)^,
			FSegment.PointsCount * sizeof(TPoint));
	end;
	FSegment.Clear;
end;

procedure TDevPoints.NewRectSegment(aRect: TRect; aClosed: Boolean);
begin
	NewSegment;
	Segment.AddPoint(Point(aRect.Left, aRect.Bottom));
	Segment.AddPoint(Point(aRect.Left, aRect.Top));
	Segment.AddPoint(Point(aRect.Right, aRect.Top));
	Segment.AddPoint(Point(aRect.Right, aRect.Bottom));
	Segment.Closed := aClosed;
	if not aClosed then
		Segment.AddPoint(Point(aRect.Left, aRect.Bottom));
end;

procedure TDevPoints.EndUpdate;
begin
	NewSegment;
end;

procedure TDevPoints.PaintPolygons(aCanvas: TCanvas);
begin
	if FPolygons.CountsCount > 0 then
		Polypolygon(aCanvas.Handle, FPolygons.Points^, FPolygons.Counts^, FPolygons.CountsCount);
end;

procedure TDevPoints.PaintPolylines(aCanvas: TCanvas);
begin
	if FPolylines.CountsCount > 0 then
		Polypolyline(aCanvas.Handle, FPolylines.Points^, FPolylines.Counts^, FPolylines.CountsCount);
end;

procedure TDevPoints.Paint(aCanvas: TCanvas; const aPen: TPenAttrsEx;
	const aBrush: TBrushAttrsEx;
	const aZoomScale: Double;
	const aMetersToPixels: Double;
	anUseAlphaBled: Boolean);

	procedure PaintOutlines;
	begin
		if aPen.Style <> psClear then begin
			aPen.AssignToCanvas(aCanvas, aZoomScale, aMetersToPixels);
			aCanvas.Brush.Style := bsClear;
			PaintPolygons(aCanvas);
			PaintPolylines(aCanvas);
		end
	end;

	procedure FillTransparentWithAlphaBlend;
	var
		aBitmap: Graphics.TBitmap;
		aSaveDC: Integer;
		aClipRect: TRect;

		aBlendFunction: _BLENDFUNCTION;
	begin
		if not GetBounds(aClipRect) then
			Exit;

		aBitmap := Graphics.TBitmap.Create;
		try
			aSaveDC := SaveDC(aCanvas.Handle);
			try
				Win32Check(BeginPath(aCanvas.Handle));
				PaintPolygons(aCanvas);
				Win32Check(EndPath(aCanvas.Handle));
				Win32Check(SelectClipPath(aCanvas.Handle, RGN_AND));

				aBitmap.Width := 1;
				aBitmap.Height := 1;
				aBitmap.Canvas.Brush.Style := bsSolid;
				aBitmap.Canvas.Brush.Color := aBrush.BackColor;
				aBitmap.Canvas.FillRect(Rect(0, 0, aBitmap.Width, aBitmap.Height));

				aBlendFunction.BlendOp := AC_SRC_OVER;
				aBlendFunction.BlendFlags := 0;
				aBlendFunction.SourceConstantAlpha := (255*(aBrush.Transparency - 1) div 10);
				aBlendFunction.AlphaFormat := 0;

				Win32Check(AlphaBlend(aCanvas.Handle,
					aClipRect.Left, aClipRect.Top,
					aClipRect.Right - aClipRect.Left, aClipRect.Bottom - aClipRect.Top,
					aBitmap.Canvas.Handle, 0, 0, aBitmap.Width, aBitmap.Height,
					aBlendFunction));
			finally
				RestoreDC(aCanvas.Handle, aSaveDC);
			end;
		finally
			aBitmap.Free;
		end;
	end;

	procedure FillTransparentWithoutAlphaBlend;
	var
		aSaveROP: Integer;
		aSaveTextColor: Integer;
	begin
		aSaveROP := GetROP2(aCanvas.Handle);
		aSaveTextColor := GetTextColor(aCanvas.Handle);

		aCanvas.Pen.Style := psClear;
		aCanvas.Brush.Bitmap := TransparencyMasks[aBrush.Transparency];

		SetTextColor(aCanvas.Handle, clBlack);
		SetROP2(aCanvas.Handle, R2_MASKPENNOT);
		PaintPolygons(aCanvas);

		SetTextColor(aCanvas.Handle, ColorToRGB(aBrush.BackColor));
		SetROP2(aCanvas.Handle, R2_XORPEN);
		PaintPolygons(aCanvas);

		SetROP2(aCanvas.Handle, aSaveROP);
		SetTextColor(aCanvas.Handle, aSaveTextColor);
	end;

	procedure FillTransparent;
	begin
		if anUseAlphaBled and CanUseAlphaBlend(aCanvas) then
			FillTransparentWithAlphaBlend
		else
			FillTransparentWithoutAlphaBlend
	end;

	procedure FillHatch;
	begin
	end;

	function IsHatchBrush: Boolean;
	begin
		Result := aBrush.Style in [bsHorizontal, bsVertical, bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross];
	end;

	procedure FillHatchWithTransparentBackground;
	var
		aSaveBkColor: Integer;
		aSaveBkMode: Integer;
	begin
		aSaveBkColor := GetBkColor(aCanvas.Handle);
		aSaveBkMode := GetBkMode(aCanvas.Handle);

		aCanvas.Pen.Mode := pmCopy;
		aCanvas.Brush := GetBrush(aBrush.Style, aBrush.HatchColor);
		SetBkColor(aCanvas.Handle, $FFFFFF);
		SetBkMode(aCanvas.Handle, TRANSPARENT);

		PaintPolygons(aCanvas);

		SetBkColor(aCanvas.Handle, aSaveBkColor);
		SetBkMode(aCanvas.Handle, aSaveBkMode);
	end;

	procedure FillHatchWithBackgroundColor;
	var
		aSaveBkColor: Integer;
		aSaveBkMode: Integer;
	begin
		aSaveBkColor := GetBkColor(aCanvas.Handle);
		aSaveBkMode := GetBkMode(aCanvas.Handle);

		aCanvas.Pen.Mode := pmCopy;
		aCanvas.Brush := GetBrush(aBrush.Style, aBrush.HatchColor);
		if aBrush.Transparency > baOpaque then begin
			SetBkColor(aCanvas.Handle, $FFFFFF);
			SetBkMode(aCanvas.Handle, TRANSPARENT);
		end
		else begin
			SetBkColor(aCanvas.Handle, ColorToRGB(aBrush.BackColor));
			SetBkMode(aCanvas.Handle, OPAQUE);
		end;
		PaintPolygons(aCanvas);

		SetBkColor(aCanvas.Handle, aSaveBkColor);
		SetBkMode(aCanvas.Handle, aSaveBkMode);
	end;

	procedure PaintFill;
	begin
		if Polygons.CountsCount = 0 then
			Exit;

		if aBrush.Transparency > baTransparent then begin
			FillTransparent;
			if IsHatchBrush then
				FillHatchWithTransparentBackground
		end
		else if IsHatchBrush then
			FillHatchWithBackgroundColor;
	end;

	procedure PaintFillAndOutLines;
	begin
		aPen.AssignToCanvas(aCanvas, aZoomScale, aMetersToPixels);
		aBrush.AssignToCanvas(aCanvas);
		PaintPolygons(aCanvas);
		aPen.AssignToCanvas(aCanvas, aZoomScale, aMetersToPixels);		
		PaintPolylines(aCanvas);
	end;


begin
	if (aPen.Style = psClear) and (aBrush.Style = bsClear) then
		Exit;

	if (aBrush.Style = bsClear) or ((aBrush.Style = bsSolid) and (aBrush.Transparency = baOpaque)) then
		PaintFillAndOutLines
	else begin
		PaintFill;
		PaintOutlines;
	end;
end;

procedure TDevPoints.Paint(aCanvas: TCanvas);
begin
	PaintPolygons(aCanvas);
	PaintPolylines(aCanvas);
end;


function TDevPoints.GetBounds(var aBounds: TRect): Boolean;
var
	aPolygons,
	aPolylines: Boolean;
	aPolygonsBounds,
	aPolylinesBounds: TRect;
begin
	aPolygons := Polygons.GetBounds(aPolygonsBounds);
	aPolylines := Polylines.GetBounds(aPolylinesBounds);
	if aPolylines and aPolygons then
		UnionRect(aBounds, aPolygonsBounds, aPolylinesBounds)
	else if aPolygons then
		aBounds := aPolygonsBounds
	else if aPolylines then
		aBounds := aPolylinesBounds;
	Result := aPolygons or aPolylines;
end;

var
	TEMP:  TDevPoints = nil;

function TDevPoints.CanUseAlphaBlend(aCanvas: TCanvas): Boolean;
var
	aVersion: OSVERSIONINFO;
begin
	aVersion.dwOSVersionInfoSize := SizeOf(aVersion);
	Result := GetVersionEx(aVersion) and
						 ((aVersion.dwMajorVersion > 4) or
						 ((aVersion.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS) and
							(aVersion.dwMajorVersion = 4) and
							(aVersion.dwMinorVersion > 0)));

	Result := Result and ((GetDeviceCaps(aCanvas.Handle, TECHNOLOGY) = DT_RASDISPLAY) or
		(GetDeviceCaps(aCanvas.Handle, TECHNOLOGY) = DT_DISPFILE) or
		((GetDeviceCaps(aCanvas.Handle, SHADEBLENDCAPS) and SB_CONST_ALPHA) <> 0));
end;


initialization
	{$IFDEF DEBUG} GetGDIContextData(nil) {$ENDIF} // чтоб линкер функцию не удалил

	OnePen := TPen.Create;
	OneBrush := TBrush.Create;
	InitTransparencyMasks;
finalization
	DoneTransparencyMasks;
	OnePen.Free;
	OneBrush.Free;

	TEMP := CachedDevPoints;
	CachedDevPoints := nil;
	CachedDevPointsInUse := false;
	TEMP.Free
end.


