AL_Paper

Top  Previous  Next

 

// Modified: 2015-02-19     By Agócs László Hun. StellaSOFT

 

unit AL_Paper;

 

interface

Uses

   Windows, SysUtils, Classes, Graphics, Controls, StdCtrls, ClipBrd, Math,

   Extctrls, Messages, Dialogs, NewGeom, DGrafik, B_Spline, Szoveg, Szamok,

   StObjects, Forms, AlType;

 

Type

TFloat = Double;

Str32 = string[32];

TMarkType = (mtBox,mtCircle,mtCross);

TMarkSize = 2..8;

 

TActionMode = (amNone, amDrawing, amPaning, amZooming, amPainting,

                amSelect,

                amInsertPoint, amDeletePoint, amMovePoint,amSelectPoint,

                amChangePoint, amDeleteSelected, amMoveSelected, amRotateSelected,

                amNewBeginPoint, amMagnifySelected,  amSelectArea, amSelectAreaEx,

                amAutoPlan, amTestWorking);

 

TDrawMode = (dmNone, dmPoint, dmLine, dmRectangle, dmPolyline, dmPolygon,

              dmCircle, dmEllipse, dmArc, dmChord, dmSpline, dmBspline, dmText,

              dmFreeHand);

 

TInCode = (icIn,        // Cursor in Curve

            icOnLine,    // Cursor on Curve's line

            icOnPoint,   // Cursor is on any Point;

            icOut        // Cursor out of Curve

            );

 

PPointRec = ^TPointRec;

TPointRec = record

//             funccode: byte;

            X: TFloat;

            Y: TFloat;

            Selected: boolean;

          end;

 

PPointArray = ^TPointArray;

TPointArray = array[0..0] of TPoint;

 

TNewGraphData = record //Graphstructur for SaveGraphToFile/LoadGraphFromFile

   Copyright   : Str32;

   Version     : integer;

   GraphTitle  : Str32;

   Curves      : integer;

   Dummy       : Array[1..128] of byte;

end;

 

TNewCurveData = record //Datenstruktur für SaveCurveToStream/LoadCurveFromStream

   ID       : Integer;

   Name     : Str32;

   Shape    : TDrawMode;

   Layer    : byte;

   Font     : TFont;

   Selected : Boolean;

   Enabled  : Boolean;

   Visible  : Boolean;

   Closed   : boolean;

   Angle    : TFloat;

   Points   : Integer;

end;

 

TCurveData = record //Datenstruktur für SaveCurveToStream/LoadCurveFromStream

   Name: Str32;

   Enabled: Boolean;

   Color: TColor;

   LineWidth: Byte;

   PenStyle: TPenStyle;

   Points: Integer;

   Closed: boolean;

   Texts: Integer;

   Marks: Integer;

   XOfs: TFloat;

   YOfs: TFloat;

   FontName: Str32;

   FontSize: Integer;

   FontStyle: TFontStyles;

   MarkSize: TMarkSize;

end;

 

TGraphData = record //Datenstruktur für SaveGraphToFile/LoadGraphFromFile

   GraphTitle: Str32;

   Zoom: TFloat;

   MaxZoom: TFloat;

   Curves: Integer;

end;

 

{Gyártási pozíció}

TWorkPosition = record

   CuvNumber   : integer;      {Aktuális obj. sorszáma}

   PointNumber : integer;      {Aktuális pont sorszáma}

   WorkPoint   : TPoint2d;    {Aktuális pont koordinátái}

end;

 

{ Polzgon metszések vizsgálatához}

TmpRec = record

      Cuvidx   : integer;   // Polygon sorszáma

      Pointidx : integer;   // legközelebbi pontjának sorszáma

      d        : double;    // Távolsága

end;

 

{Síkbeli pont objektum}

TPoint2dObj = Class(TPersistent)

private

   fx,fy : extended;

   FOnChange: TNotifyEvent;

   procedure Setx(Value:extended);

   procedure Sety(Value:extended);

   procedure Changed; dynamic;

public

   constructor Create;

published

   property x:extended read fx write Setx;

   property y:extended read fy write Sety;

   property OnChange: TNotifyEvent read FOnChange write FOnChange;

end;

 

TMetric = (meMM,meInch);

TGridStyle  = (gsNone,gsLine,gsDot,gsCross);

 

TGrid = Class(TPersistent)

private

   fVisible: boolean;

   fGridStyle: TGridStyle;

   fSubGridColor: TColor;

   fMainGridColor: TColor;

   FOnChange: TNotifyEvent;

   fMetric: TMetric;

   fMargin: integer;

   fOnlyOnPaper: boolean;

   procedure SetMainGridColor(Value: TColor);

   procedure SetGridStyle(const Value: TGridStyle);

   procedure SetSubGridColor(Value: TColor);

   procedure SetVisible(const Value: boolean);

   procedure Changed;

   procedure SetMetric(const Value: TMetric);

   procedure SetMargin(const Value: integer);

   procedure SetOnlyOnPaper(const Value: boolean);

protected

public

   constructor Create;

   procedure Change(Sender: TObject);

published

   property MainGridColor: TColor read fMainGridColor write SetMainGridColor;

   property Margin: integer read fMargin write SetMargin;

   property SubGridColor: TColor read fSubGridColor write SetSubGridColor;

   property Style: TGridStyle read fGridStyle write SetGridStyle default gsNone;

   property Metric: TMetric read fMetric write SetMetric default meMM;

   property Visible: boolean read fVisible write SetVisible default True;

   property OnlyOnPaper: boolean read fOnlyOnPaper write SetOnlyOnPaper default True;

   property OnChange: TNotifyEvent read FOnChange write FOnChange;

end;

 

TLayerName = String[30];

 

TLayer = class(TPersistent)

private

   fVisible: Boolean;

   fHomogen: Boolean;

   fModified: Boolean;

   fActive: Boolean;

   fTag: LongInt;

   FNote: string;

   fBrush: TBrush;

   fName: TLayerName;

   fPen: TPen;

   fLayerId: Byte;

   procedure SetBrush(const Value: TBrush);

   procedure SetName(const Value: TLayerName);

   procedure SetPen(const Value: TPen);

published

   constructor Create(Idx: Byte);

   destructor Destroy; override;

   procedure SaveToStream(const Stream: TStream); virtual;

   procedure LoadFromStream(const Stream: TStream); virtual;

   property Name: TLayerName read fName write SetName;

   property LayerID: Byte read fLayerId;

   property Pen: TPen read fPen write SetPen;

   property Brush: TBrush read fBrush write SetBrush;

   property Active: Boolean read fActive write FActive;

   property Modified: Boolean read fModified;

   property Homogen: Boolean read fHomogen write fHomogen;

   property Visible: Boolean read fVisible write fVisible;

   property Note: string read FNote write fNote;

   property Tag: LongInt read fTag write fTag;

end;

 

TDXFOut = class(TPersistent)

private

   FromXMin: TFloat;

   FromXMax: TFloat;

   FromYMin: TFloat;

   FromYMax: TFloat;

   ToXMin: TFloat;

   ToXMax: TFloat;

   ToYMin: TFloat;

   ToYMax: TFloat;

   TextHeight: TFloat;

   Decimals: Byte;

   LayerName: Str32;

public

   StringList: TStringList;

   constructor Create(AFromXMin,AFromYMin,AFromXMax,AFromYMax,AToXMin,AToYMin,

                      AToXMax,AToYMax,ATextHeight: TFloat; ADecimals: Byte);

   destructor Destroy; override;

//    procedure SaveToFile(fn: string);

   function FToA(F: TFloat): Str32;

   function ToX(X: TFloat): TFloat;

   function ToY(Y: TFloat): TFloat;

   procedure Header;

   procedure Trailer;

   procedure SetLayer(const Name: Str32);

   procedure Line(X1,Y1,Z1,X2,Y2,Z2: TFloat);

   procedure Point(X,Y,Z: TFloat);

   procedure StartPolyLine(Closed: Boolean);

   procedure Vertex(X,Y,Z: TFloat);

   procedure EndPolyLine;

   procedure DText(X,Y,Z,Height,Angle: TFloat; const Txt: Str32);

   procedure Layer;

   procedure StartPoint(X,Y,Z: TFloat);

   procedure EndPoint(X,Y,Z: TFloat);

   procedure AddText(const Txt: Str32);

end;

 

 

TCurve = class(TPersistent)

private

   FID  : integer;

   FName: Str32;

   FEnabled: Boolean;

   PPoint: PPointRec;

   fClosed: boolean;

   fSelected: boolean;

   FVisible: Boolean;

   fShape: TDrawMode;

   FLayer: byte;

   FFont: TFont;

   FOnChange: TNotifyEvent;

   fAngle: TFloat;

   FParentID: integer;

   FSorted: boolean;

   fSigned: boolean;

   procedure Changed(Sender: TObject); dynamic;

   procedure SetSelected(const Value: boolean);

   procedure SetShape(const Value: TDrawMode);

   procedure SetLayer(const Value: byte);

   procedure SetFont(const Value: TFont);

   procedure SetClosed(const Value: boolean);

   procedure SetEnabled(const Value: Boolean);

   procedure SetVisible(const Value: Boolean);

   procedure SetName(const Value: Str32);

   procedure SetAngle(const Value: TFloat);

   function GetPointArray(AIndex: integer): TPoint2d;

   procedure SetPoints(AIndex: integer; const Value: TPoint2d);

   function GetCount: integer;

   procedure SetSigned(const Value: boolean);

   procedure SetPointRec(AIndex: integer; const Value: TPointRec);

public

   FPoints       : TList;

   CPIndex       : Integer;        // Matching point index

   PointsArray   : array of TPoint2d;

   constructor Create;

   destructor Destroy; override;

 

   procedure ClearPoints;

   procedure AddPoint(Ax,Ay: TFloat); overload;

   procedure AddPoint(P: TPoint2d); overload;

   procedure GetPoint(AIndex: Integer; var Ax,Ay: TFloat);

   function GetPoint2d(AIndex: Integer): TPoint2d;

   function GetPointRec(AIndex: Integer): TPointRec;

   procedure ChangePoint(AIndex: Integer; Ax,Ay: TFloat); overload;

   procedure ChangePoint(AIndex: Integer; Ax, Ay: TFloat; Sel: boolean); overload;

   procedure SelectPoint(AIndex: Integer; Sel: boolean); overload;

   procedure InsertPoint(AIndex: Integer; Ax,Ay: TFloat);

   procedure DeletePoint(AIndex: Integer);

   procedure InversPointOrder;

   procedure AbsolutClosed;

 

   procedure MoveCurve(Ax,Ay: TFloat);

   procedure MoveSelectedPoints(Ax,Ay: TFloat);

   procedure MagnifyCurve(Cent: TPoint2d; Magnify: TFloat);

   procedure RotateCurve(Cent : TPoint2d; Angle: TFloat);

 

   function IsInBoundsRect(Ax, Ay: TFloat): boolean;

   function IsOnPoint(Ax, Ay, delta: TFloat): Integer;

   function IsInCurve(Ax, Ay: TFloat): TInCode; overload;

   function IsInCurve(P: TPoint2d): TInCode; overload;

   function IsCutLine(P1,P2: TPoint2d): boolean; overload;

   function IsCutLine(P1, P2: TPoint2d; var d : double): boolean; overload;

   function GetKerulet: double;

   function GetKeruletSzakasz(Aindex1,Aindex2: integer): double;

   function GetNearestPoint(p: TPoint2d; var pIdx: integer): TFloat;

   function GetBoundsRect: TRect2d;

   function IsDirect: boolean;

   procedure FillPointArray(var aList: array of TPoint2d);

 

   function GetOldCurveData: TCurveData;

   procedure SetOldCurveData(Data: TCurveData);

   function GetCurveData: TNewCurveData;

   procedure SetCurveData(Data: TNewCurveData);

 

   procedure CurveToRect(Ax, Ay: TFloat);

   function CurveToText: WideString;

 

   property Count: integer read GetCount;   // Pontok száma

   property BoundsRect: TRect2d read GetBoundsRect;

   property ParentID: integer read FParentID write FParentID;

   property Sorted: boolean read FSorted write FSorted;

   property Points[AIndex: integer] : TPoint2d read GetPointArray write SetPoints;

   property PointRec[AIndex: integer] : TPointRec read GetPointRec write SetPointRec;

published

   property ID: Integer read FID write FID;

   property Name: Str32 read FName write SetName;

   property Layer: byte read FLayer write SetLayer default 0;

   property Font: TFont read FFont write SetFont;

   property Angle: TFloat read fAngle write SetAngle;

   property Enabled: Boolean read FEnabled write SetEnabled;

   property Visible: Boolean read FVisible write SetVisible;

   property Closed: boolean read fClosed write SetClosed;

   property Selected: boolean read fSelected write SetSelected;

   property Shape: TDrawMode read fShape write SetShape;

   property Signed: boolean read fSigned write SetSigned;

   property OnChange: TNotifyEvent read FOnChange write FOnChange;

end;

 

// Event fron changing drawmode

TChangeMode = procedure(Sender: TObject; ActionMode: TActionMode; DrawMode: TDrawMode) of object;

// Event fron changing window dimension

TChangeWindow = procedure(Sender: TObject; x0,y0,Zoom: real; MouseX,MouseY: real) of object;

TMouseEnter = procedure(Sender: TObject) of object;

TNewBeginPoint = procedure(Sender: TObject; Curve: integer) of object;

TChangeCurve = procedure(Sender: TObject; Curve: TCurve; Point: integer) of object;

TUndoRedoChangeEvent = procedure(Sender: TObject; Undo,Redo:boolean) of object;

TCutPlan = procedure(Sender: TObject; Curve: TCurve; Point: integer) of object;

TProcess = procedure(Sender: TObject; Percent: integer) of object;

TAutoSortEvent = procedure(Sender: TObject; Status: byte; ObjectNo: word) of object;

 

TALSablon = class(TCustomControl)

private

   DrawBmp: TBitMap;

   fCoordLabel: TLabel;

   fCentrum: TPoint2dObj;

   fOrigo: TPoint2d;

   fWorkOrigo: TPoint2d;

   fPaper: TPoint2dObj;

   fZoom: extended;

   FPaperVisible: boolean;

   fPaperColor: TColor;

   fBackColor: TColor;

   fCentralCross: boolean;

   fGrid: TGrid;

   fHinted: boolean;

   Hint1   : THintWindow;

   HintActive : boolean;

   oldHintStr: string;

   fCursorCross: boolean;

   FDrawMode: TDrawMode;

   FSensitiveRadius: integer;

   fShowPoints: boolean;

   fWorking: boolean;

   fDefaultLayer: Byte;

   fChangeMode: TChangeMode;

   fActionMode: TActionMode;

   fActLayer: integer;

   fpFazis: integer;

   fNewBeginPoint: TNewBeginPoint;

   fChangeWindow: TChangeWindow;

   fChangeCurve: TChangeCurve;

   fSelected: TCurve;

   FGraphTitle: Str32;

   fLocked: boolean;

   FWorkArea: TRect;

   FTitleFont: TFont;

   fAutoUndo: boolean;

   FUndoRedoChangeEvent: TUndoRedoChangeEvent;

   FLoading: boolean;

   FMouseEnter: TMouseEnter;

   FMouseLeave: TMouseEnter;

   fChanged: boolean;

   FDemo: boolean;

   FSTOP: boolean;

   FSablonSzinkron: boolean;

   FMMPerLepes: extended;

   fChangeSelected: TChangeCurve;

   FConturRadius: double;

   FAutoSortEvent: TAutoSortEvent;

   FPlan: TProcess;

   FTestSpeed: double;

   fChangeAll: TNotifyEvent;

   FCentralisZoom: boolean;

   procedure SetZoom(const Value: extended);

   procedure SetPaperVisible(const Value: boolean);

   procedure SetBackColor(const Value: TColor);

   procedure SetPaperColor(const Value: TColor);

   procedure WMSize(var Msg: TWMSize); message WM_SIZE;

   procedure WMEraseBkGnd(var Message:TWMEraseBkGnd); message WM_ERASEBKGND;

   procedure CMMouseEnter(var msg:TMessage); message CM_MOUSEENTER;

   procedure CMMouseLeave(var msg: TMessage); message CM_MOUSELEAVE;

   Procedure CMChildkey( Var msg: TCMChildKey ); message CM_CHILDKEY;

   procedure SetCentralCross(const Value: boolean);

   procedure GridDraw;

   procedure DrawMouseCross(o:TPoint;PenMode:TPenMode);

   procedure SetCursorCross(const Value: boolean);

   function GetWindow: TRect2d;

   procedure SetWindow(const Value: TRect2d);

   procedure SetDrawMode(const Value: TDrawMode);

   procedure SetSensitiveRadius(const Value: integer);

   procedure SetShowPoints(const Value: boolean);

   procedure SetWorking(const Value: boolean);

   procedure SetDefaultLayer(const Value: Byte);

   procedure SetActionMode(const Value: TActionMode);

   procedure SetpFazis(const Value: integer);

   procedure SetSelected(const Value: TCurve);

   procedure SetGraphTitle(const Value: Str32);

   procedure SetLocked(const Value: boolean);

   procedure SetWorkArea(const Value: TRect);

   procedure SetTitleFont(const Value: TFont);

   procedure SetLoading(const Value: boolean);

   procedure SetWorkOrigo(const Value: TPoint2d);

   procedure ReOrderNames;

   function GetDisabledCount: integer;

protected

   FCurve              : TCurve;     // Cuve for general purpose

   oldCentrum          : TPoint2d;   //

   Origin,MovePt       : TPoint;

   oldOrigin,oldMovePt : TPoint;

   MouseInOut          : integer;    // Egér belép:1, bent van:0, kilép:-1

   h                   : integer;    // New Curve handle

   rrect               : TRect2d;    // Rectangle for rect or window

   polygonContinue     : boolean;    // Polygon continue;

   MaxPointsCount      : integer;    // Max. point in Curve

   // Rotation variables

   RotCentrum          : TPoint2d;   // Centrum of rotation

   RotStartAngle       : TFloat;     // Rotate curves start angle

   RotAngle            : TFloat;     // Rotation angle

   oldCursorCross      : boolean;

 

   Paning              : boolean;

   Zooming             : boolean;

   painting            : boolean;

   HClip               : HRgn;

   oldCursor           : TCursor;

 

   DXFOut              : TDXFOut;

 

   UR                  : TUndoRedo;  // Undo-Redo object

 

   procedure Change(Sender: TObject);

   procedure ChangeCentrum(Sender: TObject);

   procedure ChangePaperExtension(Sender: TObject);

   procedure MouseDown(Button: TMouseButton; Shift: TShiftState;

     X, Y: Integer); override;

   procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;

   procedure MouseUp(Button: TMouseButton; Shift: TShiftState;

     X, Y: Integer); override;

   function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;

     MousePos: TPoint): Boolean; override;

   function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;

   function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;

   procedure UndoStart;

   procedure UndoStop;

public

   FCurveList    : TList;      // List of vectorial curves

   TempCurve     : TCurve;     // Temporary curve for not poligonized objects: Ex. Spline

   CPMatch       : Boolean;    // Matching point

   CurveMatch    : Boolean;    // Matching curve

   CurveIn       : boolean;    // point in curve

   CPCurve       : Integer;

   LastCPCurve   : Integer;

   CPIndex       : Integer;

   LastCPIndex   : Integer;

   CPx           : TFloat;

   CPy           : TFloat;

   MousePos      : TPoint;     // Mouse x,y position

   ActText       : Str32;

   InnerStream   : TMemoryStream;     // memorystream for inner use

   oldFile       : boolean;

   WorkPosition  : TWorkPosition;

   WRect         : TRect;             {A munkapont alatti terület mentéséhez}

   WBmp          : TBitmap;

   Moving        : boolean;

   pClosed,pOpened,pSelected : TPen;

   constructor Create(AOwner: TComponent); override;

   destructor Destroy; override;

   procedure Paint; override;

   { Világ koordináták (W) képernyő koordináttákká (S) ill. vissza }

   function XToW(x:integer):TFloat;

   function YToW(y:integer):TFloat;

   function XToS(x:TFloat):integer;

   function YToS(y:TFloat):integer;

   function WToS(x,y:TFloat):TPoint;

   function SToW(x,y: integer):TPoint2d;

   function OrigoToCent:TPoint2D;

   function CentToOrigo(c:TPoint2D):TPoint2D;

   {Teljes papír az ablakban}

   procedure ZoomPaper;

   procedure ZoomDrawing;

   procedure MoveWindow(dx,dy: integer);

   procedure MoveCentrum(fx,fy: double);

   procedure CurveToCent(AIndex: Integer);

   procedure NewOrigo(x,y:extended);

   property Origo: TPoint2d read fOrigo write FOrigo;

   property WorkOrigo: TPoint2d read fWorkOrigo write SetWorkOrigo;

   property Window: TRect2d read GetWindow write SetWindow;

 

   function GetDrawExtension: TRect2d;

   function IsRectInWindow(R: TRect2d): boolean;

   function IsPaperInWindow: boolean;

   function IsPointInWindow(p: TPoint2d): boolean;

   { Curves and process}

   function MakeCurve(const AName: Str32; ID: integer; Shape: TDrawMode;

            AEnabled, AVisible, AClosed: Boolean): Integer;

   procedure Clear;

   function AddCurve(ACurve: TCurve):integer;

   procedure DeleteCurve(AItem: Integer);

   procedure DeleteSelectedCurves;

   procedure InsertCurve(AIndex: Integer; Curve: TCurve);

   function GetCurveName(H: Integer): Str32;

   function GetCurveHandle(AName: Str32; var H: Integer): Boolean;

 

   procedure AddPoint(AIndex: Integer; X, Y: TFloat); overload;

   procedure AddPoint(AIndex: Integer; P: TPoint2d); overload;

   procedure InsertPoint(AIndex,APosition: Integer; X,Y: TFloat); overload;

   procedure InsertPoint(AIndex,APosition: Integer; P: TPoint2d); overload;

   procedure DeletePoint(AIndex,APosition: Integer);

   procedure DeleteSamePoints(diff: TFloat);

   procedure ChangePoint(AIndex,APosition: Integer; X,Y: TFloat);

   procedure DoMove(Dx,Dy: Integer);  // Move a point in curve

   procedure GetPoint(AIndex,APosition: Integer; var X,Y: TFloat);

   function GetMaxPoints: Integer;

   function GetNearestPoint(p: TPoint2d; var cuvIdx, pIdx: integer): TFloat;

   procedure SetBeginPoint(ACurve,AIndex: Integer);

 

   procedure MoveCurve(AIndex :integer; Ax, Ay: TFloat);

   procedure MoveSelectedCurves(Ax,Ay: TFloat);

   procedure RotateSelectedCurves(Cent : TPoint2d; Angle: TFloat);

   procedure InversSelectedCurves;

   procedure InversCurve(AIndex: Integer);

   procedure SelectCurveByName(aName: string);

   procedure SelectCurve(AIndex: Integer);

   procedure PoligonizeAll(PointCount: integer);

   procedure Poligonize(Cuv: TCurve; Count: integer);

   procedure VektorisationAll(MaxDiff: TFloat);

   procedure Vektorisation(MaxDiff: TFloat; Cuv: TCurve);

   procedure PontSurites(Cuv: TCurve; Dist: double);

   procedure PontSuritesAll(Dist: double);

 

   procedure CheckCurvePoints(X, Y: Integer);

 

   procedure SelectAll(all: boolean);

   procedure SelectAllInArea(R: TRect2D);

   procedure SelectAllInAreaEx(R: TRect2d); // Select only points

   procedure ClosedAll(all: boolean);

   procedure SelectAllPolylines;

   procedure SelectAllPolygons;

   procedure SelectParentObjects;

   procedure SelectChildObjects;

   procedure EnabledAll(all: boolean);

   procedure SignedAll(all: boolean);

   function GetSignedCount: integer;

   procedure SignedNotCutting;

 

   { Transformations }

   procedure Normalisation(Down: boolean);

   procedure Eltolas(dx,dy: double);

   procedure Nyujtas(tenyezo:double);

   procedure CentralisNyujtas(Cent: TPoint2d; tenyezo: double);

   procedure MagnifySelected(Cent: TPoint2d; Magnify: TFloat);

 

   function SaveCurveToStream(FileStream: TStream;

     Item: Integer): Boolean;

   function LoadCurveFromStream(FileStream: TStream): Boolean;

   function LoadCurveFromFile(const FileName: string): Boolean;

   procedure SaveGraphToMemoryStream(var stm: TMemoryStream);

   procedure LoadGraphFromMemoryStream(stm: TMemoryStream);

   function SaveGraphToFile(const FileName: string): Boolean;

   function LoadGraphFromFile(const FileName: string): Boolean;

   function LoadOldGraphFromFile(const FileName: string): Boolean;

   function LoadFromDXF(const FileName: string): Boolean;

   function SaveToDXF(const FileName: string):boolean;

   function LoadFromPLT(const FileName: string): Boolean;

   procedure LoadFromDAT(Filename: STRING);

   function SaveToDAT(Filename: STRING):boolean;

   procedure DXFCurves;

 

   { Virtual Clipboard procedures }

   procedure CopySelectedToVirtClipboard;

   procedure CutSelectedToVirtClipboard;

   procedure PasteSelectedFromVirtClipboard;

 

   {Undo,Redo}

   procedure UndoInit;

   procedure Undo;

   procedure Redo;

   procedure UndoSave;

   procedure UndoRedo(Sender:TObject; Undo,Redo:boolean);

 

   {Automatkus objektum sorrend képzés}

   procedure AutoSortObject(BasePoint: TPoint2d); overload;

   procedure AutoSortObject(BasePoint: TPoint2d; Connecting: boolean); overload;

   procedure AutoCutSequence(BasePoint: TPoint2d; Sorting: boolean);

   procedure InitParentObjects;

   function IsParent(AIndex: Integer): boolean; overload;

   function IsParent(x, y: TFloat): boolean; overload;

   function GetInnerObjectsCount(AIndex: Integer): integer;

   function GetParentObject(AIndex: Integer): integer; overload;

   function GetParentObject(x,y: TFloat): integer; overload;

   function OutLineObject(AIndex: Integer; delta: real): TCurve;

   function ObjectContour(Cuv: TCurve;OutCode:double): TCurve;

   procedure StripObj12(AParent,Achild: integer);

   procedure StripChildToParent(AIndex: integer);

   procedure StripAll;

   procedure ContourOptimalizalas(var Cuv: TCurve);

   function IsCutObject(p1,p2: TPoint2d; var Aindex: integer): boolean;

   procedure ElkerulesAB(Var eCurve: TCurve);

   procedure Elkerules;

   procedure DrawCurve(Cuv: TCurve; co: TColor);

 

   procedure ShowHintPanel(Show: Boolean);

 

   { Working }

   procedure DrawWorkPoint(x,y:double);

   procedure ClearWorkPoint;

   procedure WorkpositionToCentrum;

   procedure TestVekOut(dx,dy:extended);

   procedure TestWorking(AObject,AItem:integer);

 

   property pFazis: integer read fpFazis write SetpFazis;    // Drawing phase

   property WorkArea: TRect read FWorkArea write SetWorkArea;

   property Loading: boolean read FLoading write SetLoading;

   property Canvas;

   property DisabledCount: integer read GetDisabledCount;

   property CentralisZoom: boolean  read FCentralisZoom write FCentralisZoom;

published

   property ActionMode: TActionMode read fActionMode write SetActionMode;

   property ActLayer: integer read fActLayer write fActLayer default 0;

   property AutoUndo : boolean read fAutoUndo write fAutoUndo;

   property Changed : boolean read fChanged write fChanged;

   property Centrum: TPoint2dObj read fCentrum write fCentrum;

   property CentralCross: boolean read fCentralCross write SetCentralCross;

   property CoordLabel: TLabel read fCoordLabel write fCoordLabel;

   property CursorCross: boolean read fCursorCross write SetCursorCross;

            // Kontúr vonal távolsága az objektumtól

   property ConturRadius: double read FConturRadius write FConturRadius;

   property DefaultLayer: Byte read fDefaultLayer write SetDefaultLayer default 0;

   property Demo: boolean read FDemo write FDemo default False;

   property DrawMode: TDrawMode read FDrawMode write SetDrawMode;

   property BackColor: TColor read fBackColor write SetBackColor;

   property GraphTitle: Str32 read FGraphTitle write SetGraphTitle;

   property Grid: TGrid read fGrid Write fGrid;

   property Hinted: boolean read fHinted write fHinted;

   property Locked: boolean read fLocked write SetLocked;  // Editable?

   property MMPerLepes: extended read FMMPerLepes write FMMPerLepes;

   property Paper: TPoint2dObj read fPaper write fPaper;

   property PaperColor: TColor read fPaperColor write SetPaperColor;

   property PaperVisible: boolean read FPaperVisible write SetPaperVisible;

   property SablonSzinkron: boolean read FSablonSzinkron write FSablonSzinkron;

   property Selected: TCurve read fSelected write SetSelected;

   // Cursor sensitive radius of circle around of curves' points

   property SensitiveRadius: integer read FSensitiveRadius write SetSensitiveRadius;

   property ShowPoints: boolean read fShowPoints write SetShowPoints;

   property STOP: boolean read FSTOP write fSTOP;

   property TestSpeed: double read FTestSpeed write FTestSpeed;

   property TitleFont: TFont read FTitleFont write SetTitleFont;

   property Working: boolean read fWorking write SetWorking;

   property Zoom: extended read fZoom write SetZoom;

   property OnChangeAll: TNotifyEvent read fChangeAll write fChangeAll;

   property OnChangeCurve: TChangeCurve read fChangeCurve write fChangeCurve;

   property OnChangeMode: TChangeMode read fChangeMode write fChangeMode;

   property OnChangeSelected: TChangeCurve read fChangeSelected write fChangeSelected;

   property OnChangeWindow: TChangeWindow read fChangeWindow write fChangeWindow;

   property OnMouseEnter: TMouseEnter read FMouseEnter write FMouseEnter;

   property OnMouseLeave: TMouseEnter read FMouseLeave write FMouseLeave;

   property OnNewBeginPoint: TNewBeginPoint read fNewBeginPoint write fNewBeginPoint;

   property OnUndoRedoChange : TUndoRedoChangeEvent read FUndoRedoChangeEvent

            write FUndoRedoChangeEvent;

   property OnAutoSort: TAutoSortEvent read FAutoSortEvent write FAutoSortEvent;

   property OnPlan: TProcess read FPlan write FPlan; // Event for autocut percent 

   property Align;

   property Anchors;

   property BevelInner;

   property BevelOuter;

   property BevelWidth;

   property Caption;

   property Enabled;

   property Font;

   property Hint;

   property PopupMenu;

   property ShowHint;

   property TabOrder;

   property TabStop;

   property Visible;

   property OnCanResize;

   property OnClick;

   property OnContextPopup;

   property OnConstrainedResize;

   property OnDblClick;

   property OnDragDrop;

   property OnDragOver;

   property OnEndDrag;

   property OnEnter;

   property OnExit;

   property OnKeyDown;

   property OnKeyPress;

   property OnKeyUp;

   property OnMouseMove;

   property OnMouseDown;

   property OnMouseUp;

   property OnMouseWheel;

   property OnMouseWheelDown;

   property OnMouseWheelUp;

   property OnStartDrag;

   property OnResize;

end;

 

   procedure Register;

   // Draw a shape to Canvas

   procedure DrawShape(Canvas: TCanvas; T,B: TPoint; DrawMode: TDrawMode;

                           AMode: TPenMode);

   function InRange(Test,Min,Max: Integer): Boolean;

 

Var delta: TFloat;       // Sensitive radius around of points

   VirtualClipboard : TMemoryStream;   // Store List of vectorial curves for public

   ClipboardStr     : WideString;      // Save draw to clipboard as text

 

Const

DrawModeText : Array[0..13] of String =

             ('None', 'Point', 'Line', 'Rectangle', 'Polyline', 'Polygon',

              'Circle', 'Ellipse', 'Arc', 'Chord', 'Spline', 'BSline', 'Text',

              'FreeHand');

 

ActionModeText : Array[0..19] of String =

              ('None', 'Drawing', 'Paning', 'Zooming', 'Painting',

                'Select',

                'InsertPoint', 'DeletePoint', 'MovePoint','SelectPoint',

                'ChangePoint', 'DeleteSelected', 'MoveSelected', 'RotateSelected',

                'NewBeginPoint', 'MagnifySelected', 'SelectArea', 'SelectAreaEx',

                'AutoPlan','TestWorking');

 

ShapeClosed : Array[0..12] of Boolean =

             (False, False, False, True, False, True,

              True, True, False, True, False, True, False);

 

implementation

 

procedure Register;

begin

RegisterComponents('AL',[TALSablon]);

end;

 

function InRange(Test,Min,Max: Integer): Boolean;

begin

Result:=(Test >= Min) and (Test <= Max);

end;

 

// Draw a shape to Canvas

procedure DrawShape(Canvas: TCanvas; T,B: TPoint; DrawMode: TDrawMode;

                           AMode: TPenMode);

var DC:HDC;

   DX,DY : integer;

begin

DC := GetDC(Canvas.Handle);

With Canvas do

begin

   Pen.Mode    := AMode;

   Brush.Color := clWhite;

   Brush.style := bsClear;

   If (T.X<>B.x) OR (T.Y<>B.Y) then

   begin

       case DrawMode of

       dmPoint:

           Rectangle(T.X-2,T.Y-2,T.X+2,T.Y+2);

       dmLine,dmPolyline,dmPolygon:

       begin

           MoveTo(T.X, T.Y); LineTo(B.X, B.Y);

       end;

       dmRectangle : Rectangle(T.X, T.Y, B.X, B.Y);

       dmCircle,dmEllipse :

       begin

           dx := Abs(T.X-B.X);

           dy := Abs(T.Y-B.Y);

           if DrawMode=dmCircle then begin

              dx:=Trunc(sqrt(dx*dx+dy*dy));

              dy:=dx;

           end;

           Ellipse(T.X-dx, T.Y-dy, T.X+dx, T.Y+dy);

       end;

       end;

   end;

end;

RestoreDC(Canvas.Handle,DC);

end;

 

 

{ -----------  TPoint2dObj --------- }

 

constructor TPoint2dObj.Create;

begin

inherited;

fx := 0;

fy := 0;

end;

 

procedure TPoint2dObj.Changed;

 

begin if Assigned(FOnChange) then FOnChange(Self); end;

 

procedure TPoint2dObj.Setx(Value:extended);

begin

    Fx:=Value;

    Changed;

end;

 

procedure TPoint2dObj.Sety(Value:extended);

begin

    Fy:=Value;

    Changed;

end;

 

{------------------------------------------------------------------------------}

 

{ TLayer }

 

constructor TLayer.Create(Idx: Byte);

begin

fPen := TPen.Create;

fBrush := TBrush.Create;

fLayerID := Idx;

Tag := 0;

end;

 

destructor TLayer.Destroy;

begin

fPen.Free;

fBrush.Free;

inherited;

end;

 

procedure TLayer.LoadFromStream(const Stream: TStream);

begin

 

end;

 

procedure TLayer.SaveToStream(const Stream: TStream);

begin

 

end;

 

procedure TLayer.SetBrush(const Value: TBrush);

begin

fBrush := Value;

end;

 

procedure TLayer.SetName(const Value: TLayerName);

begin

fName := Value;

end;

 

procedure TLayer.SetPen(const Value: TPen);

begin

fPen := Value;

end;

 

{ TGrid }

 

constructor TGrid.Create;

begin

inherited;

fMainGridColor := clGray;

fSubGridColor  := clSilver;

fOnlyOnPaper   := True;

fMetric        := meMM;

fVisible       := True;

end;

 

procedure TGrid.Change(Sender: TObject);

begin

   Changed;

end;

 

procedure TGrid.Changed;

begin if Assigned(FOnChange) then FOnChange(Self); end;

 

procedure TGrid.SetOnlyOnPaper(const Value: boolean);

begin

fOnlyOnPaper := Value;

Changed;

end;

 

procedure TGrid.SetMargin(const Value: integer);

begin

fMargin := Value;

Changed;

end;

 

procedure TGrid.SetMainGridColor(Value: TColor);

begin

fMainGridColor:=Value;

Changed;

end;

 

procedure TGrid.SetGridStyle(const Value: TGridStyle);

begin

fGridStyle := Value;

Changed;

end;

 

procedure TGrid.SetSubGridColor(Value: TColor);

begin

fSubGridColor := Value;

Changed;

end;

 

procedure TGrid.SetMetric(const Value: TMetric);

begin

fMetric := Value;

Changed;

end;

 

procedure TGrid.SetVisible(const Value: boolean);

begin

fVisible := Value;

Changed;

end;

 

{------------------------------------------------------------------------------}

 

constructor TDXFOut.Create(AFromXMin,AFromYMin,AFromXMax,AFromYMax,

                          AToXMin,AToYMin,AToXMax,AToYMax,ATextHeight: TFloat; ADecimals: Byte);

begin

inherited Create;

FromXMin:=AFromXMin;

FromYMin:=AFromYMin;

FromXMax:=AFromXMax;

FromYMax:=AFromYMax;

ToXMin:=AToXMin;

ToYMin:=AToYMin;

ToXMax:=AToXMax;

ToYMax:=AToYMax;

TextHeight:=ATextHeight;

Decimals:=ADecimals;

StringList:=TStringList.Create;

end;

{------------------------------------------------------------------------------}

 

destructor TDXFOut.Destroy;

begin

StringList.Free;

inherited Destroy;

end;

{------------------------------------------------------------------------------}

 

procedure TDXFOut.Header;

begin

LayerName:='0';

StringList.Add('0');

StringList.Add('SECTION');

StringList.Add('2');

StringList.Add('HEADER');

StringList.Add('9');

StringList.Add('$LIMMIN');

StringList.Add('10');

StringList.Add(FToA(ToXMin));

StringList.Add('20');

StringList.Add(FToA(ToYMin));

StringList.Add('9');

StringList.Add('$LIMMAX');

StringList.Add('10');

StringList.Add(FToA(ToXMax));

StringList.Add('20');

StringList.Add(FToA(ToYMax));

StringList.Add('0');

StringList.Add('ENDSEC');

StringList.Add('0');

StringList.Add('SECTION');

StringList.Add('2');

StringList.Add('TABLES');

StringList.Add('0');

StringList.Add('TABLE');

StringList.Add('2');

StringList.Add('LAYER');

StringList.Add('70');

StringList.Add('1');

StringList.Add('0');

StringList.Add('LAYER');

StringList.Add('2');

StringList.Add('0');

StringList.Add('70');

StringList.Add('64');

StringList.Add('62');

StringList.Add('7');

StringList.Add('6');

StringList.Add('CONTINUOUS');

StringList.Add('0');

StringList.Add('ENDTAB');

StringList.Add('0');

StringList.Add('ENDSEC');

StringList.Add('0');

StringList.Add('SECTION');

StringList.Add('2');

StringList.Add('ENTITIES');

end;

{------------------------------------------------------------------------------}

 

function TDXFOut.FToA(F: TFloat): Str32;

var

I: Integer;

begin

Result:=FloatToStrF(F,ffFixed,16,Decimals);

I:=Pos(',',Result);

if I > 0 then Result[I]:='.';

end;

{------------------------------------------------------------------------------}

 

function TDXFOut.ToX(X: TFloat): TFloat;

var

Factor,FromDif: TFloat;

begin

FromDif:=FromXMax - FromXMin;

if FromDif <> 0.0 then Factor:=(ToXMax - ToXMin) / FromDif else Factor:=1.0;

Result:=X * Factor;

end;

{------------------------------------------------------------------------------}

 

function TDXFOut.ToY(Y: TFloat): TFloat;

var

Factor,FromDif: TFloat;

begin

FromDif:=FromYMax - FromYMin;

if FromDif <> 0.0 then Factor:=(ToYMax - ToYMin) / FromDif else Factor:=1.0;

Result:=Y * Factor;

end;

{------------------------------------------------------------------------------}

 

procedure TDXFOut.SetLayer(const Name: Str32);

begin

LayerName:=Name;

end;

{------------------------------------------------------------------------------}

 

procedure TDXFOut.Layer;

begin

StringList.Add('8');

StringList.Add(LayerName);

end;

{------------------------------------------------------------------------------}

 

procedure TDXFOut.StartPoint(X,Y,Z: TFloat);

begin

StringList.Add(' 10');

StringList.Add(FToA(X));

StringList.Add(' 20');

StringList.Add(FToA(Y));

StringList.Add(' 30');

StringList.Add(FToA(Z));

end;

{------------------------------------------------------------------------------}

 

procedure TDXFOut.EndPoint(X,Y,Z: TFloat);

begin

StringList.Add(' 11');

StringList.Add(FToA(X));

StringList.Add(' 21');

StringList.Add(FToA(Y));

StringList.Add(' 31');

StringList.Add(FToA(Z));

end;

{------------------------------------------------------------------------------}

 

procedure TDXFOut.AddText(const Txt: Str32);

begin

StringList.Add('1');

StringList.Add(Txt);

end;

{------------------------------------------------------------------------------}

 

procedure TDXFOut.StartPolyLine(Closed: Boolean);

var

Flag : Byte;

begin

StringList.Add('0');

StringList.Add('POLYLINE');

Layer;

StringList.Add('66');

StringList.Add('1');

StartPoint(0,0,0);

Flag:=8;

if Closed then Flag:=Flag or 1;

StringList.Add('70');

StringList.Add(IntToStr(Flag));

end;

{------------------------------------------------------------------------------}

 

procedure TDXFOut.Vertex(X,Y,Z: TFloat);

var

Flag : Byte;

begin

StringList.Add('0');

StringList.Add('VERTEX');

Layer;

StartPoint(X,Y,Z);

StringList.Add('70');

Flag:=32;

StringList.Add(IntToStr(Flag));

end;

{------------------------------------------------------------------------------}

 

procedure TDXFOut.EndPolyLine;

begin

StringList.Add('0');

StringList.Add('SEQEND');

Layer;

end;

{------------------------------------------------------------------------------}

 

procedure TDXFOut.Line(X1,Y1,Z1,X2,Y2,Z2: TFloat);

begin

StringList.Add('0');

StringList.Add('LINE');

Layer;

StartPoint(X1,Y1,Z1);

EndPoint(X2,Y2,Z2);

end;

{------------------------------------------------------------------------------}

 

procedure TDXFOut.Point(X,Y,Z: TFloat);

begin

StringList.Add('0');

StringList.Add('POINT');

Layer;

StartPoint(X,Y,Z);

end;

{------------------------------------------------------------------------------}

 

procedure TDXFOut.DText(X,Y,Z,Height,Angle: TFloat; const Txt: Str32);

begin

StringList.Add('0');

StringList.Add('TEXT');

Layer;

StartPoint(X,Y,Z);

StringList.Add('40');

StringList.Add(FToA(Height));

AddText(Txt);

StringList.Add('50');

StringList.Add(FToA(Angle));

end;

{------------------------------------------------------------------------------}

 

procedure TDXFOut.Trailer;

begin

StringList.Add('0');

StringList.Add('ENDSEC');

StringList.Add('0');

StringList.Add('EOF');

end;

 

{------------------------------------------------------------------------------}

 

{ TCurve }

 

// TCurve = Closed or Opened Curve Obeject's Datas}

 

constructor TCurve.Create;

begin

inherited Create;

FPoints        :=TList.Create;

FFont          :=TFont.Create;

FFont.OnChange :=Changed;

FAngle         :=0;

FEnabled       :=True;

FVisible       :=True;

FClosed        :=True;

FSelected      :=False;

FSigned        :=False;

FShape         :=dmNone;

FParentID      :=-1;      // Nincs szülő objektuma

end;

 

destructor TCurve.Destroy;

var

I: Integer;

begin

for I:=0 to Pred(FPoints.Count) do FreeMem(FPoints.Items[I],SizeOf(TPointRec));

FPoints.Free;

inherited Destroy;

end;

 

function TCurve.GetCount: integer;

begin

Result := Fpoints.Count;

end;

 

procedure TCurve.SetName(const Value: Str32);

begin

FName := Value;

Changed(Self);

end;

 

procedure TCurve.SetLayer(const Value: byte);

begin

if Enabled then begin

FLayer := Value;

Changed(Self);

end;

end;

 

procedure TCurve.SetFont(const Value: TFont);

begin

if Enabled then begin

FFont := Value;

Changed(Self);

end;

end;

 

procedure TCurve.SetClosed(const Value: boolean);

begin

Try

IF Self<>nil then

if Enabled then begin

fClosed := Value;

Changed(Self);

end;

except

end;

end;

 

procedure TCurve.SetEnabled(const Value: Boolean);

begin

FEnabled := Value;

Changed(Self);

end;

 

procedure TCurve.SetSigned(const Value: boolean);

begin

fSigned := Value;

Changed(Self);

end;

 

procedure TCurve.SetVisible(const Value: Boolean);

begin

FVisible := Value;

Changed(Self);

end;

 

procedure TCurve.SetAngle(const Value: TFloat);

begin

fAngle := Value;

Changed(Self);

end;

 

procedure TCurve.AddPoint(Ax, Ay: TFloat);

begin

if Enabled then begin

GetMem(PPoint,SizeOf(TPointRec));

PPoint^.X:=Ax;

PPoint^.Y:=Ay;

PPoint^.Selected:=False;

FPoints.Add(PPoint);

end;

end;

 

procedure TCurve.AddPoint(P: TPoint2d);

begin

AddPoint(P.x, P.y);

end;

 

procedure TCurve.ChangePoint(AIndex: Integer; Ax, Ay: TFloat);

begin

if Enabled then begin

if InRange(AIndex,0,Pred(FPoints.Count)) then

begin

   PPoint:=FPoints.Items[AIndex];

   PPoint^.X:=Ax;

   PPoint^.Y:=Ay;

end;

end;

end;

 

procedure TCurve.ChangePoint(AIndex: Integer; Ax, Ay: TFloat; Sel: boolean);

begin

if Enabled then

if InRange(AIndex,0,Pred(FPoints.Count)) then

begin

   PPoint:=FPoints.Items[AIndex];

   PPoint^.X:=Ax;

   PPoint^.Y:=Ay;

   PPoint^.Selected:=Sel;

end;

end;

 

procedure TCurve.SelectPoint(AIndex: Integer; Sel: boolean);

begin

if Enabled then

if InRange(AIndex,0,Pred(FPoints.Count)) then

begin

   PPoint:=FPoints.Items[AIndex];

   PPoint^.Selected:=Sel;

end;

end;

 

procedure TCurve.MoveCurve(Ax,Ay: TFloat);

var i: integer;

begin

if Enabled then begin

For i:=0 to Pred(FPoints.Count) do

begin

   PPoint:=FPoints.Items[i];

   PPoint^.X:=PPoint^.X+Ax;

   PPoint^.Y:=PPoint^.Y+Ay;

end;

end;

end;

 

procedure TCurve.MoveSelectedPoints(Ax,Ay: TFloat);

var i: integer;

   pr: TPointRec;

begin

if Enabled then begin

For i:=0 to Pred(FPoints.Count) do

begin

   PPoint:=FPoints.Items[i];

   if PPoint^.Selected then begin

      PPoint^.X:=PPoint^.X+Ax;

      PPoint^.Y:=PPoint^.Y+Ay;

   end;

end;

end;

end;

 

procedure TCurve.MagnifyCurve(Cent: TPoint2d; Magnify: TFloat);

var i: integer;

begin

if Enabled then begin

For i:=0 to Pred(FPoints.Count) do

begin

   PPoint:=FPoints.Items[i];

   PPoint^.X := Cent.x + Magnify * (PPoint^.X - Cent.x);

   PPoint^.Y := Cent.y + Magnify * (PPoint^.Y - Cent.y);

end;

end;

end;

 

procedure TCurve.RotateCurve(Cent : TPoint2d; Angle: TFloat);

var i,j: integer;

   pp: Tpoint2d;

begin

if Enabled then begin

Case Shape of

dmText : j:=0;

else

   j := Pred(FPoints.Count);

end;

For i:=0 to j do

begin

   PPoint:=FPoints.Items[i];

   pp := Point2D(PPoint^.X,PPoint^.Y);

   RelRotate2D(pp,Cent,Angle);

   PPoint^.X:=pp.X;

   PPoint^.Y:=pp.Y;

end;

end;

end;

 

procedure TCurve.ClearPoints;

begin

if Enabled then begin

FPoints.Clear;

end;

end;

 

procedure TCurve.DeletePoint(AIndex: Integer);

begin

if Enabled then begin

if InRange(AIndex,0,Pred(FPoints.Count)) then

begin

   FreeMem(FPoints.Items[AIndex],SizeOf(TPointRec));

   FPoints.Delete(AIndex);

end;

end;

end;

 

procedure TCurve.GetPoint(AIndex: Integer; var Ax, Ay: TFloat);

begin

if InRange(AIndex,0,Pred(FPoints.Count)) then

begin

   PPoint:=FPoints.Items[AIndex];

   Ax:=PPoint^.X;

   Ay:=PPoint^.Y;

end;

end;

 

function TCurve.GetPoint2d(AIndex: Integer): TPoint2d;

begin

if InRange(AIndex,0,Pred(FPoints.Count)) then

begin

   PPoint := FPoints.Items[AIndex];

   Result := Point2d(PPoint^.X,PPoint^.Y);

end;

end;

 

function TCurve.GetPointRec(AIndex: Integer): TPointRec;

begin

if InRange(AIndex,0,Pred(FPoints.Count)) then

begin

   Result := TPointRec(FPoints.Items[AIndex]^);

end;

end;

 

function TCurve.GetPointArray(AIndex: integer): TPoint2d;

begin

Result := GetPoint2d(AIndex);

end;

 

procedure TCurve.FillPointArray(var aList: array of TPoint2d);

var i: integer;

begin

SetLength(PointsArray,Count);

for i:=0 to Count-1 do

     PointsArray[i] := GetPoint2d(i);

end;

 

procedure TCurve.SetPointRec(AIndex: integer; const Value: TPointRec);

begin

ChangePoint(AIndex,Value.x,Value.y,Value.Selected);

end;

 

procedure TCurve.SetPoints(AIndex: integer; const Value: TPoint2d);

begin

ChangePoint(AIndex,Value.x,Value.y);

end;

 

procedure TCurve.InsertPoint(AIndex: Integer; Ax, Ay: TFloat);

begin

if Enabled then begin

if AIndex > -1 then

begin

   GetMem(PPoint,SizeOf(TPointRec));

   PPoint^.X:=Ax;

   PPoint^.Y:=Ay;

   FPoints.Insert(AIndex,PPoint);

end;

end;

end;

(*

// Az objektum pontjait egy dinamikus tömbbe tölti

function TCurve.GetPointArray: Array of TPoint2d;

var i: integer;

begin

SetLength(Result,FPoints.Count);

For i:=0 to Pred(FPoints.Count) do

   Result[i]:=GetPoint2d(i);

end;

*)

 

function TCurve.IsDirect: boolean;

var ymax: double;

   i,idx: integer;

   Pprior,Pnext: integer;

begin

// Y max pont megkeresése

ymax:= -10e+10;

for i:=0 to Pred(Fpoints.Count) do

     if Points[i].y>ymax then begin

        ymax := Points[i].y;

        idx := i;

     end;

Pprior := idx-1;

Pnext  := idx+1;

if idx=0 then

    Pprior := Pred(Fpoints.Count);

if idx=Pred(Fpoints.Count) then

    Pnext := 0;

Result := IsDirectPoligon(Points[Pprior],Points[idx],Points[Pnext]);

end;

 

procedure TCurve.SetSelected(const Value: boolean);

begin

if Enabled then begin

FSelected := Value;

Changed(Self);

end;

end;

 

procedure TCurve.SetShape(const Value: TDrawMode);

begin

if Enabled then begin

fShape := Value;

Changed(Self);

end;

end;

 

function TCurve.IsInCurve(P: TPoint2d): TInCode;

begin

Result := IsInCurve(p.x,p.y);

end;

 

function TCurve.IsInCurve(Ax, Ay: TFloat): TInCode;

{Examine that point is in curve or in a point or out of curve}

Var e: TEgyenes;

   i,N: integer;

   arr  : array of TPoint2d;

   PP1,PP2: PPointRec;

   d: double;

 

function InSide (const x,y : integer; Polygon: array of TPoint): boolean;

var

    PolyHandle: HRGN;

begin

  PolyHandle := CreatePolygonRgn(Polygon[0],length(Polygon)-1,Winding);

  result     := PtInRegion(PolyHandle,X,Y);

  DeleteObject(PolyHandle);

end;

 

function PointInPolygonTest(x, y: real; N: Integer; aList: Array of TPoint2d): Boolean;

Type

  PPoint = ^TPoint;

var

  I, J : Integer;

 

  Function xp(aVal:Integer):Integer;

  Begin

    Result:= PPoint(@aList[aVal]).X;

  end;

 

  Function yp(aVal:Integer):Integer;

  Begin

    Result:= PPoint(@aList[aVal]).Y;

  end;

 

begin

  Result := False;

  {L := Length(aList);}

  if (N = 0) then exit;

  J := N-1;

  for I := 0 to N-1 do

  begin

    if ((((yp(I) <= y) and (y < yp(J))) or

         ((yp(J) <= y) and (y < yp(I)))) and

        (x < (xp(J)-xp(I))*(y-yp(I))/(yp(J)-yp(I))+xp(I)))

    then Result := not Result;

    J:=I;

  end;

end;

 

Function IsPointOnLine(p, p_1, p_2: TPoint2d; diff: double):boolean;

var d: double;

begin

{A pontnak az egyenestől való távolsága = d}

d := p.x*(p_1.y-p_2.y)-p.y*(p_1.x-p_2.x)+(p_1.x*p_2.y)-(p_1.y*p_2.x);

if Abs(d)<=diff then Result:=True else Result:=False;

end;

 

FUNCTION point_dist_to_line(xp,yp,x1,y1,x2,y2: double): double;

// Compute the distance from a point (xp,yp) to a line defined by its

// start (x1,y1) and end (x2,y2) points.

Var dx1p,dx21,dy1p,dy21 : double;

   frac, lambda,xsep,ysep : double;

BEGIN

    dx1p := x1 - xp; dx21 := x2 - x1; dy1p := y1 - yp; dy21 := y2 - y1;

    frac := dx21*dx21 + dy21*dy21;

    if frac=0 then Frac:=1;

    // -- Compute the distance along the line that the normal intersects.

    lambda := -(dx1p*dx21 + dy1p*dy21) / frac;

    // -- Accept if along the line segment, else choose the correct end point.

    lambda := MIN(MAX(lambda,0.0),1.0);

    //-- Compute the x and y separations between the point on the line that is

    //-- closest to (xp,yp) and (xp,yp).

    xsep := dx1p + lambda*dx21;

    ysep := dy1p + lambda*dy21;

    Result := SQRT(xsep*xsep + ysep*ysep);

END;

 

begin

Result := icOut;

if IsInBoundsRect(Ax,Ay) then begin

 

    // Finds a point

    if IsOnPoint(Ax,Ay,delta)>-1 then begin

       Result := icOnPoint;

    end;

 

    if FPoints.Count>1 then begin

 

       // Finds a line

       For i:=0 to FPoints.Count-1 do begin

          PP1:=FPoints.Items[i];

          IF (i=FPoints.Count-1) then begin

             if Closed then PP2:=FPoints.Items[0]

          end else

             PP2:=FPoints.Items[i+1];

          d := point_dist_to_line(Ax,Ay,PP1^.x,PP1^.y,PP2^.x,PP2^.y);

          if d<delta

          then begin

             CPIndex := i+1;

             Result := icOnLine;

             Exit;

          end;

       end;

 

       //Point in poligon

       If Closed then begin

       // Fills the arr array with the curve points

       N := FPoints.Count;

       If Closed then N:=N+1;

       SetLength(arr,N);

       For i:=0 to FPoints.Count-1 do begin

          PPoint:=FPoints.Items[i];

          arr[i]:=Point2d(PPoint^.x,PPoint^.y);

       end;

       If Closed then begin

          PPoint:=FPoints.Items[0];

          arr[High(arr)]:=Point2d(PPoint^.x,PPoint^.y);

       end;

//        if InSide(Trunc(Ax),Trunc(Ay),arr) then

//        if PointInPolygonTest(Ax,Ay,FPoints.Count,arr) then

         if IsPointInPoligon(arr,Point2d(Ax,Ay)) then

             Result := icIn;

       end;

 

    end;

 

end;

end;

 

// Megadja, hogy az alakzat melyik pontja van a legközelebb egy külső ponthoz

function TCurve.GetNearestPoint(p: TPoint2d; var pIdx: integer): TFloat;

var

J   : Integer;

d   : Double;

x,y : double;

begin

Result := 10e+10;

   For J:=0 to Pred(FPoints.Count) do

   begin

       GetPoint(j,x,y);

       d:=KetPontTavolsaga(p.x,p.y,x,y);

       if d<Result then begin

          pIdx   := J;

          Result := d;

       end;

   end;

end;

 

// ---------------------------------------------------------------------------

 

function TCurve.IsInBoundsRect(Ax, Ay: TFloat): boolean;

begin

With BoundsRect do

   Result := ((x1-delta)<=Ax) and ((x2+delta)>=Ax) and

          ((y1-delta)<=Ay) and ((y2+delta)>=Ay)

end;

 

function TCurve.GetBoundsRect: TRect2d;

var

I: Integer;

x1,y1,x2,y2: TFloat;

begin

Try

x1:=1E+10;

y1:=1E+10;

x2:=-1E+10;

y2:=-1E+10;

If FPoints.Count>0 then

for I:=0 to Pred(FPoints.Count) do begin

     PPoint:=FPoints.Items[i];

     if PPoint^.x<x1 then x1:=PPoint^.x;

     if PPoint^.x>x2 then x2:=PPoint^.x;

     if PPoint^.y<y1 then y1:=PPoint^.y;

     if PPoint^.y>y2 then y2:=PPoint^.y;

end;

     Result.x1 := x1;

     Result.y1 := y1;

     Result.x2 := x2;

     Result.y2 := y2;

except

end;

end;

 

function TCurve.IsOnPoint(Ax, Ay, delta: TFloat): Integer;

(* Result = Point index : if P(Ax,Ay) point in delta radius circle;

  Result = -1          : other else *)

var

I: Integer;

begin

Result := -1;

for I:=0 to Pred(FPoints.Count) do begin

     PPoint:=FPoints.Items[i];

     if (Abs(Ax-PPoint^.x)<=delta) and (Abs(Ay-PPoint^.y)<=delta)

     then begin

          CPIndex := i;

          Result := i;

          exit;

     end;

end;

end;

 

// Megvizsgálja, hogy P1-P2 szakasz áttvágja-e a polygont

function TCurve.IsCutLine(P1, P2: TPoint2d): boolean;

var

I: Integer;

mp,pp1,pp2: TPoint2d;

begin

Result := False;

i:=0;

While i<=FPoints.Count-1 do begin

     pp1:=GetPoint2d(i);

     if i<FPoints.Count-1 then

        pp2:=GetPoint2d(i+1)

     else

        pp2:=GetPoint2d(0);

     if SzakaszSzakaszMetszes(pp1,pp2,p1,p2,mp) then begin

          Result := True;

          exit;

     end;

     Inc(i);

end;

end;

 

// Megvizsgálja, hogy P1-P2 szakasz áttvágja-e a polygont és

// d metszéspont távolságát adja a P1 első ponttól

function TCurve.IsCutLine(P1, P2: TPoint2d; var d : double): boolean;

var

I: Integer;

pp1,pp2,mp: TPoint2d;

dd: double;

begin

Result := False;

i:=0;

d:=10e+10;

While i<=FPoints.Count-1 do begin

     pp1:=GetPoint2d(i);

     if i<FPoints.Count-1 then

        pp2:=GetPoint2d(i+1)

     else

        pp2:=GetPoint2d(0);

     if SzakaszSzakaszMetszes(pp1,pp2,p1,p2,mp) then begin

        dd:=RelDist2d(P1,mp);

        if dd<d then d:=dd;

        Result := True;

     end;

     Inc(i);

end;

end;

 

// Meghatározza az objektum kerületét

function TCurve.GetKerulet: double;

var

I: Integer;

pp1,pp2: TPoint2d;

begin

Result := 0;

for I:=0 to FPoints.Count-2 do begin

     pp1:=GetPoint2d(i);

     pp2:=GetPoint2d(i+1);

     Result := Result + KetPontTavolsaga(pp1.X,pp1.y,pp2.x,pp2.y);

end;

if Closed then begin

    pp1:=pp2;

    pp2:=GetPoint2d(0);

    Result := Result + KetPontTavolsaga(pp1.X,pp1.y,pp2.x,pp2.y);

end;

end;

 

// Meghatározza az objektum kerületi hosszát Aindex1,Aindex2 pontok között;

function TCurve.GetKeruletSzakasz(Aindex1,Aindex2: integer): double;

var

I: Integer;

Idx1,Idx2: integer;

pp1,pp2: TPoint2d;

Ker: double;

begin

Result := 0;

if Aindex2 = Aindex1 then Exit;

if Aindex2 > Aindex1 then begin

    Idx1 := Aindex1;

    Idx2 := Aindex2;

end else begin

    Idx1 := Aindex2;

    Idx2 := Aindex1;

    ker := GetKerulet;

end;

for I:=Idx1 to Idx2-1 do begin

     pp1:=GetPoint2d(i);

     pp2:=GetPoint2d(i+1);

     Result := Result + KetPontTavolsaga(pp1.X,pp1.y,pp2.x,pp2.y);

end;

if Aindex2 < Aindex1 then Result := Ker-Result;

end;

 

// Megfordítja a pontsorrendet egy objektumon belül

procedure TCurve.InversPointOrder;

var i: integer;

   x,y: TFloat;

begin

if Enabled then

   if Closed then begin

      GetPoint(0,x,y);

      AddPoint(x,y);

      DeletePoint(0);

      For i:=0 to (FPoints.Count div 2)-1 do

          Fpoints.Exchange(i,Fpoints.Count-1-i);

   end else

   For i:=0 to (FPoints.Count div 2)-1 do

       Fpoints.Exchange(i,Fpoints.Count-1-i);

end;

 

// End point := First point

procedure TCurve.AbsolutClosed;

var x,y,x1,y1: double;

begin

If Closed then begin

    GetPoint(0,x,y);

    GetPoint(FPoints.Count-1,x1,y1);

    if (x<>x1) or (y<>y1) then

       AddPoint(x,y);

end;

end;

 

function TCurve.GetOldCurveData: TCurveData;

begin

   Result.Name     := Name;

   Result.Closed   := Closed;

   Result.Points   := fPoints.Count;

end;

 

procedure TCurve.SetOldCurveData(Data: TCurveData);

begin

if Enabled then begin

   Name        := Data.Name;

   Closed      := Data.Closed;

   if Closed then

   Shape       := dmPolygon

   else

   Shape       := dmPolyline;

end;

end;

 

function TCurve.GetCurveData: TNewCurveData;

begin

   Result.ID       := ID;

   Result.Name     := Name;

   Result.Shape    := Shape;

   Result.Layer    := Layer;

   Result.Font     := Font;

   Result.Selected := Selected;

   Result.Enabled  := Enabled;

   Result.Visible  := Enabled;

   Result.Closed   := Closed;

   Result.Points   := fPoints.Count;

end;

 

procedure TCurve.SetCurveData(Data: TNewCurveData);

begin

if Enabled then begin

   ID          := Data.ID;

   Name        := Data.Name;

   Shape       := Data.Shape;

   Layer       := Data.Layer;

   Font        := Data.Font;

   Selected    := Data.Selected;

   Enabled     := Data.Enabled;

   Visible     := Data.Visible;

   Closed      := Data.Closed;

end;

end;

 

procedure TCurve.CurveToRect(Ax, Ay: TFloat);

begin

if Enabled then begin

end;

end;

 

function TCurve.CurveToText : WideString;

 

Var i: integer;

 

Function BoolText(b:boolean):string;

begin

   if b then Result := 'True' else Result := 'False';

end;

 

begin

Result := '';

Result := Result + '[Curve]'+Eoln;

Result := Result + 'Name     = '+Name+Eoln;

Result := Result + 'ID       = '+IntToStr(ID)+Eoln;

Result := Result + 'Shape    = '+DrawModeText[Ord(Shape)]+Eoln;

Result := Result + 'Layer    = '+IntToStr(Layer)+Eoln;

Result := Result + 'Font     = '+Font.Name+','+Inttostr(Font.Size)+Eoln;

Result := Result + 'Selected = '+BoolText(Selected)+Eoln;

Result := Result + 'Enabled  = '+BoolText(Enabled)+Eoln;

Result := Result + 'Visible  = '+BoolText(Visible)+Eoln;

Result := Result + 'Closed   = '+BoolText(Closed)+Eoln;

Result := Result + 'Points   = '+IntToStr(FPoints.Count)+Eoln;

Result := Result + '[Points]'+Eoln;

for I:=0 to Pred(FPoints.Count) do begin

     PPoint:=FPoints.Items[i];

     Result := Result + '  '+IntToStr(I)+' = '+

            Format('%6.2f',[PPoint^.x])+','+Format('%6.2f',[PPoint^.y])+Eoln;

end;

Result := Result + Eoln;

end;

 

procedure TCurve.Changed(Sender: TObject);

begin if Assigned(FOnChange) then FOnChange(Self); end;

 

{ TALSablon }

 

procedure TALSablon.Change(Sender: TObject);

begin

//  oldCentrum := OrigoToCent;

if Sender is TCurve then

    if Assigned(fChangeCurve) then fChangeCurve(Self,TCurve(Sender),-1);

Invalidate;

end;

 

procedure TALSablon.ChangeCentrum(Sender: TObject);

var p: TPoint2d;

begin

Origo := CentToOrigo(Point2d(Centrum.x,Centrum.y));

Repaint;

end;

 

procedure TALSablon.ChangePaperExtension(Sender: TObject);

begin

ZoomPaper;

end;

 

constructor TALSablon.Create(AOwner: TComponent);

begin

inherited;

 

Screen.Cursors[crKez1]     :=  LoadCursor(HInstance, 'SKEZ_1');

Screen.Cursors[crKez2]     :=  LoadCursor(HInstance, 'SKEZ_2');

Screen.Cursors[crRealZoom] :=  LoadCursor(HInstance, 'SREAL_ZOOM');

Screen.Cursors[crNyilUp]   :=  LoadCursor(HInstance, 'SNYIL_UP');

Screen.Cursors[crNyilDown] :=  LoadCursor(HInstance, 'SNYIL_DOWN');

Screen.Cursors[crNyilLeft] :=  LoadCursor(HInstance, 'SNYIL_LEFT');

Screen.Cursors[crNyilRight]:=  LoadCursor(HInstance, 'SNYIL_RIGHT');

Screen.Cursors[crZoomIn]   :=  LoadCursor(HInstance, 'SZOOM_IN');

Screen.Cursors[crZoomOut]  :=  LoadCursor(HInstance, 'SZOOM_OUT');

Screen.Cursors[crKereszt]  :=  LoadCursor(HInstance, 'SKERESZT');

Screen.Cursors[crHelp]     :=  LoadCursor(HInstance, 'SHELP_CUR');

Screen.Cursors[crPolyline]     :=  LoadCursor(HInstance, 'SPOLYLINE');

Screen.Cursors[crPolygon]      :=  LoadCursor(HInstance, 'SPOLYGON');

Screen.Cursors[crInsertPoint]  :=  LoadCursor(HInstance, 'SINSERTPOINT');

Screen.Cursors[crDeletePoint]  :=  LoadCursor(HInstance, 'SDELETEPOINT');

Screen.Cursors[crNewbeginPoint]:=  LoadCursor(HInstance, 'SNEWBEGINPOINT');

Screen.Cursors[crRotateSelected]:=  LoadCursor(HInstance,'SROTATESELECTED');

Screen.Cursors[crFreeHand]:=  LoadCursor(HInstance,'SFREEHAND');

 

STOP   := False;

Width  := 200;

height := 200;

WBmp       := TBitMap.Create;   // Memory Bitmap for Working Pointer

WBmp.Width := 8;

WBmp.Height:= 8;

// Creates pens

pClosed := TPen.Create;

pClosed.Width := 2;

pClosed.Color := clBlack;

pClosed.Style := psSolid;

 

pOpened := TPen.Create;

pOpened.Width := 1;

pOpened.Color := clGray;

pOpened.Style := psDot;

 

pSelected := TPen.Create;

pSelected.Width := 2;

pSelected.Color := clBlue;

pSelected.Style := psSolid;

 

fZoom             := 1;

DrawBmp           := TBitMap.Create;

FCurveList        := TList.Create;

fPaper            := TPoint2DObj.Create;

fPaper.x          := 210;

fPaper.y          := 297;

fBackColor        := clSilver;

fPaperColor       := clWhite;

fPaperVisible     := True;

fGrid             := TGrid.Create;

fCentrum          := TPoint2DObj.Create;

fGrid.OnChange    := Change;

fCentrum.OnChange := ChangeCentrum;

fPaper.OnChange   := ChangePaperExtension;

fCentralCross     := True;

fCursorCross      := True;

oldCursorCross    := True;

fShowPoints       := True;

MouseInOut        := 1;

Origin            := Point(0,0);

MovePt            := Origin;

oldMovePt         := MovePt;

Hinted            := True;

Hint1             := THintWindow.Create(Self);

painting          := False;

fDefaultLayer     := 0;

SensitiveRadius   := 2;

Centrum.x         := fPaper.x / 2;

Centrum.y         := fPaper.y / 2;

DrawMode          := dmNone;

FTitleFont        := TFont.Create;

With FTitleFont do begin

      Name := 'Times New Roman';

      Color:= clNavy;

      Size := 8;

end;

innerStream := TMemoryStream.Create;

fAutoUndo := True;

UR:= TUndoRedo.Create;

Ur.UndoLimit := 100;

Ur.UndoSaveProcedure := SaveGraphToMemoryStream;

Ur.UndoRedoProcedure := LoadGraphFromMemoryStream;

Ur.OnUndoRedo        := UndoRedo;

UndoInit;

Changed := False;

//  DoubleBuffered := True;

FWorkOrigo := Point2d(0,0);

FMMPerLepes  := 4;

TempCurve    := TCurve.Create;

FConturRadius := 2;

FDemo   := False;

FCentralisZoom:=True;

ZoomPaper;

end;

 

destructor TALSablon.Destroy;

var

I: Integer;

begin

if Self <> nil then begin

for I:=Pred(FCurveList.Count) downto 0 do

begin

   FCurve:=FCurveList.Items[I];

   FCurve.Free;

end;

FCurveList.Free;

pClosed.Free;

pOpened.Free;

pSelected.Free;

Hint1.Free;

fPaper.Free;

fGrid.Free;

fCentrum.Free;

FTitleFont.Free;

DrawBmp.Free;

WBmp.Free;

UR.Free;

innerStream.Destroy;

end;

inherited;

end;

 

procedure TALSablon.WMSize(var Msg: TWMSize);

begin

   inherited;

   ChangeCentrum(nil);

end;

 

procedure TALSablon.UndoInit;

begin

Clear;           // Clears all curves

UR.UndoInit;     // Initialize UndoRedo system

UndoSave;        // Saves this situation

end;

 

procedure TALSablon.Undo;

begin

if (not Locked) and UR.Enable then begin

Loading := True;

FCurveList.Clear;

UR.Undo;

Changed := True;

Loading := False;

invalidate;

end;

end;

 

procedure TALSablon.Redo;

begin

if (not Locked) and UR.Enable then begin

Loading := True;

Clear;

UR.Redo;

Changed := True;

Loading := False;

end;

end;

 

procedure TALSablon.UndoSave;

begin

if (not Locked) and UR.Enable then

UR.UndoSave;  // Felhasználói mentés undo-hoz

end;

 

procedure TALSablon.UndoRedo(Sender:TObject; Undo,Redo:boolean);

begin

If Assigned(FUndoRedoChangeEvent) then

    FUndoRedoChangeEvent(Self,Undo,Redo);

end;

 

procedure TALSablon.Paint;

var

R       : TRect;

H,I,J,K : Integer;

Radius  : integer;

X,Y     : TFloat;

Angle   : TFloat;

Size    : integer;

p       : TPoint;

pp      : Array[0..2] of TPoint2D;

PA,pPA  : PPointArray;

RE      : TRect2d;

dc      : HDC;

begin

Try

painting := True;

 

DrawBmp.Width:=Width;

DrawBmp.Height:=Height;

DrawBmp.Canvas.Pen.Width:=1;

 

DrawBmp.Canvas.Brush.Color:=BackColor;

DrawBmp.Canvas.FillRect(ClientRect);

DrawBmp.Canvas.Brush.Color:=clSilver;

 

If IsPaperInWindow and PaperVisible then begin

   DrawBmp.Canvas.Pen.Style := psSolid;

   R:=Rect(XToS(0),YToS(0),XToS(Paper.x),YToS(Paper.y));

   OffsetRect(R,4,4);

   DrawBmp.Canvas.Brush.Color:=clBlack;

   DrawBmp.Canvas.FillRect(R);

   OffsetRect(R,-4,-4);

   DrawBmp.Canvas.Brush.Color:=PaperColor;

   DrawBmp.Canvas.FillRect(R);

   DrawBmp.Canvas.Pen.Color := clBlack;

   DrawBmp.Canvas.Rectangle(R);

end;

 

GridDraw;

 

if Length(FGraphTitle) > 0 then

begin

     DrawBmp.Canvas.Font:=TitleFont;

     DrawBmp.Canvas.Brush.Style := bsClear;

     DrawBmp.Canvas.Brush.Color := clSilver;

     DrawBmp.Canvas.TextOut(4,4,FGraphTitle);

//      DrawBmp.Canvas.TextOut(Width div 2 - DrawBmp.Canvas.TextWidth(FGraphTitle) div 2,

//                        10,FGraphTitle)

end;

 

K := GetMaxPoints;

Size:=GetMaxPoints * SizeOf(TPointArray);

GetMem(PA,Size);

 

for H:=0 to Pred(FCurveList.Count) do

begin

   FCurve:=FCurveList.Items[H];

   if FCurve<>nil then begin

   if FCurve.Visible and (FCurve.FPoints.Count > 0) then

   begin

     DrawBmp.Canvas.Pen.Style := psSolid;

     DrawBmp.Canvas.Pen.Width:=1;

     DrawBmp.Canvas.Brush.Style:=bsSolid;

     J:=Pred(FCurve.FPoints.Count);

 

     for I:=0 to J do

     begin

       FCurve.GetPoint(I,X,Y);

       p := WtoS(x,y);

       PA^[I].x:= p.x;

       PA^[I].y:= p.y;

     end;

 

     // Tollak beállítása

     If FCurve.Closed then begin

            DrawBmp.Canvas.Pen.Assign(pClosed);

            DrawBmp.Canvas.Brush.Style:=bsClear;

     end else

            DrawBmp.Canvas.Pen.Assign(pOpened);

     If (FCurve.Selected) then

       DrawBmp.Canvas.Pen.Assign(pSelected);

     if FCurve.Signed then

        DrawBmp.Canvas.Pen.Color := clSilver;

     if FCurve = Selected then begin

        DrawBmp.Canvas.Pen.Width := 2;

        if FCurve.Selected then

           DrawBmp.Canvas.Pen.Color := clFuchsia

        else

           DrawBmp.Canvas.Pen.Color := clRed;

        RE := FCurve.BoundsRect;

        R  := Rect(XToS(RE.X1),YToS(Re.y1),XToS(RE.X2),YToS(Re.y2));

        DrawBmp.Canvas.TextOut((R.Right+R.Left) div 2,(R.Bottom+R.Top) div 2,IntToStr(H))

     end;

 

     // Objektumok rajzolása

     Case FCurve.Shape of

     dmPolygon,dmPolyLine,dmPoint,dmLine,dmRectangle:

       If FCurve.Closed then

       begin

           DrawBmp.Canvas.Polygon(Slice(PA^,Succ(J)))

       end

       else

       begin

           DrawBmp.Canvas.PolyLine(Slice(PA^,Succ(J)));

       end;

     dmCircle:

       begin

          Radius:= Trunc( SQRT( SQR(p.x-PA^[0].x) + SQR(p.y-PA^[0].y) ) );

          DrawBmp.Canvas.Ellipse(PA^[0].x-Radius,PA^[0].y-Radius,PA^[0].x+Radius,PA^[0].y+Radius);

       end;

     dmEllipse:

       begin

          DrawBmp.Canvas.Ellipse(PA^[0].x-Abs(PA^[0].x-p.x),PA^[0].y-Abs(PA^[0].y-p.y),

                                 PA^[0].x+Abs(PA^[0].x-p.x),PA^[0].y+Abs(PA^[0].y-p.y));

       end;

     dmArc:

       If FCurve.FPoints.Count>2 then

       begin

         For i:=0 to 2 do begin

             FCurve.GetPoint(I,X,Y);

             pp[i] := Point2D(XtoS(x),YToS(y));

         end;

         KorivRajzol(DrawBmp.Canvas,pp[0],pp[1],pp[2]);

       end else

          DrawBmp.Canvas.PolyLine(Slice(PA^,Succ(J)));

     dmSpline:

       begin

         if FCurve.Closed then K:=3 else K:=4;

         SplineXP(DrawBmp.Canvas,Slice(PA^,Succ(J)),100,TBSplineAlgoritm(K));

       end;

     dmBSpline:

       begin

         SplineXP(DrawBmp.Canvas,Slice(PA^,Succ(J)),100,TBSplineAlgoritm(3));

       end;

     dmText:

       begin

         DrawBmp.Canvas.Font := FCurve.Font;

         DrawBmp.Canvas.Font.Size := Trunc(FCurve.Font.Size * Zoom);

         if DrawBmp.Canvas.Font.Size>2 then begin

            Angle := FCurve.Angle;

            FCurve.GetPoint(0,X,Y);

            p := WtoS(x,y);

            if Angle=0 then

               DrawBmp.Canvas.TextOut(p.x,p.y,FCurve.Name)

            else

               RotText(DrawBmp.Canvas,p.x,p.y,FCurve.Name,Round(10*Angle));

         end;

       end;

     end;

 

     // Sarokpontok rajzolása = Draw points

     DrawBmp.Canvas.Pen.Width := 1;

     DrawBmp.Canvas.Brush.Color:=clLime;

     If ShowPoints then

     for I:=1 to J do

     begin

          if FCurve.GetPointRec(I).Selected then begin

             DrawBmp.Canvas.Pen.Color := clBlue;

//              DrawBmp.Canvas.Brush.Color:=clBlue;

             DrawBmp.Canvas.Rectangle(PA^[I].x-4,PA^[I].y-4,

               PA^[I].x+4,PA^[I].y+4);

          end else begin

             DrawBmp.Canvas.Pen.Color := clBlack;

//              DrawBmp.Canvas.Brush.Color:=clLime;

             DrawBmp.Canvas.Rectangle(PA^[I].x-SensitiveRadius,PA^[I].y-SensitiveRadius,

               PA^[I].x+SensitiveRadius,PA^[I].y+SensitiveRadius);

          end;

     end;

          // Draw begin point

     If (FCurve=Selected) then begin

          DrawBmp.Canvas.Brush.Color:=clRed;

          DrawBmp.Canvas.Ellipse(PA^[0].x-SensitiveRadius-4,PA^[0].y-SensitiveRadius-4,

               PA^[0].x+SensitiveRadius+4,PA^[0].y+SensitiveRadius+4)

     end else begin

          DrawBmp.Canvas.Brush.Color:=clBlue;

          DrawBmp.Canvas.Ellipse(PA^[0].x-SensitiveRadius-2,PA^[0].y-SensitiveRadius-2,

               PA^[0].x+SensitiveRadius+2,PA^[0].y+SensitiveRadius+2)

     end;

          DrawBmp.Canvas.Brush.Color:=clWhite;

 

   end;

   end;

end;

 

{Középkereszt}

If CentralCross then

With DrawBmp.Canvas do begin

   R := Clientrect;

   Pen.Color := clBlack;

   Pen.Style := psSolid;

   MoveTo((R.Left+R.Right) div 2,R.Top);

   LineTo((R.Left+R.Right) div 2,R.Bottom);

   MoveTo(R.Left,(R.Top+R.Bottom) div 2);

   LineTo(R.Right,(R.Top+R.Bottom) div 2);

end;

if ActionMode=amRotateSelected then

    if pFazis>0 then begin

       DrawBmp.Canvas.Pen.Color := clRed;

       DrawBmp.Canvas.Brush.Color := clRed;

       p := WToS(RotCentrum.x,RotCentrum.y);

       DrawBmp.Canvas.Ellipse(p.x-4,p.y-4,p.x+4,p.y+4);

    end;

 

finally

FreeMem(PA,Size);

R:=ClientRect;

Canvas.CopyRect(R,DrawBmp.Canvas,R);

DrawWorkPoint(WorkPosition.WorkPoint.x,WorkPosition.WorkPoint.y);

If oldCursorCross (*and (MouseInOut=1)*) then begin

    DrawMouseCross(oldMovePt,pmXor);

end;

painting := False;

if Assigned(fChangeWindow) then

    fChangeWindow(Self,fOrigo.x,fOrigo.Y,fZoom,XToW(MovePt.x),YToW(MovePt.y))

end;

end;

 

procedure TALSablon.GridDraw;

var

   kp,kp0: TPoint2d;

   tav,kpy,mar,marx,mary: extended;

   i: integer;

   GridTav : integer;     // Distance between lines

   R : TRect;

begin

If Grid.Visible then begin

GridTav := 1;

With DrawBmp.Canvas do

 

if Grid.OnlyOnPaper then begin

For i:=0 to 2 do begin

     tav  := Gridtav;

     if (Zoom*tav)>5 then begin

 

     Pen.Color := Grid.SubgridColor;

     Case GridTav of

     1:  Pen.Width := 1;

     10: Pen.Width := 2;

     100: Pen.Color := Grid.MaingridColor;

     end;

 

     kp.x := 0;

     kp.y := 0; kp0:=kp;

 

     if Grid.Style=gsLine then begin

     While kp.x<=Paper.x do begin

           MoveTo(XToS(kp.x),YToS(0));

           LineTo(XToS(kp.x),YToS(Paper.y-0.1));

           kp.x:=kp.x+tav;

     end;

     While kp.y<=Paper.y do begin

           MoveTo(XToS(0),YToS(kp.y));

           LineTo(XToS(Paper.x-0.1),YToS(kp.y));

           kp.y:=kp.y+tav;

     end;

     end;

 

   end;

   GridTav := GridTav * 10;

 

end;

 

end else

begin

For i:=0 to 2 do begin

     tav  := Zoom * Gridtav;

     if tav>5 then begin

 

     Pen.Color := Grid.SubgridColor;

     Case GridTav of

     1:  Pen.Width := 1;

     10: Pen.Width := 2;

     100: Pen.Color := Grid.MaingridColor;

     end;

 

     marx := -Maradek(origo.x,GridTav);

     mary := -Maradek(origo.y,GridTav);

     kp.x := tav*marx;

     kp.y := tav*mary; kp0:=kp;

 

     if Grid.Style in [gsDot,gsCross] then

     While kp.x<=Width do begin

     While kp.y<=Height do begin

      Case Grid.Style of

      gsDot: begin

          Pixels[Trunc(kp.x),Height-Trunc(kp.y)]:= clGreen;

         end;

      gsCross: begin

          MoveTo(Trunc(kp.x)-4,Height-Trunc(kp.y));

          LineTo(Trunc(kp.x)+5,Height-Trunc(kp.y));

          MoveTo(Trunc(kp.x),Height-Trunc(kp.y)-4);

          LineTo(Trunc(kp.x),Height-Trunc(kp.y)+4);

         end;

      end;

      kp.y := kp.y+tav;

     end;

      kp.x:=kp.x+tav;

      kp.y := kp0.y;

     end;

 

     if Grid.Style=gsLine then begin

     While kp.x<=Width do begin

           MoveTo(Trunc(kp.x),0);

           LineTo(Trunc(kp.x),Height);

           kp.x:=kp.x+tav;

     end;

     While kp.y<=Height do begin

           MoveTo(0,Height-Trunc(kp.y));

           LineTo(Width,Height-Trunc(kp.y));

           kp.y:=kp.y+tav;

     end;

     end;

 

     end; //if tav>3

 

   GridTav := GridTav * 10;

 

end;

end;

 

end;

// Margin draws

if (Grid.Margin>0) and PaperVisible then begin

      DrawBmp.Canvas.Brush.Style:=bsClear;

      DrawBmp.Canvas.Pen.Style := psDot;

      DrawBmp.Canvas.Pen.Color := clSilver;

      R:=Rect(XToS(Grid.Margin),YToS(Grid.Margin),XToS(Trunc(Paper.x-Grid.Margin)),

              YToS(Trunc(Paper.y-Grid.Margin)));

      DrawBmp.Canvas.Rectangle(R);

end;

end;

 

{Új origo meghatározása: átírja a centrum koordinátáit is}

procedure TALSablon.NewOrigo(x,y:extended);

var c : TPoint2d;

begin

   FOrigo.x:=x;

   FOrigo.y:=y;

   c := OrigoToCent;

   fCentrum.x := c.x;

   Centrum.y := c.y;

end;

 

procedure TALSablon.SetBackColor(const Value: TColor);

begin

fBackColor := Value;

Repaint;

end;

 

procedure TALSablon.SetPaperColor(const Value: TColor);

begin

fPaperColor := Value;

Repaint;

end;

 

procedure TALSablon.SetPaperVisible(const Value: boolean);

begin

FPaperVisible := Value;

Repaint;

end;

 

procedure TALSablon.SetZoom(const Value: extended);

var felx,fely: extended;

begin

If fzoom<>Value then begin

if CentralisZoom then begin

   felx := Width/(2*Zoom);

   fely := Height/(2*Zoom);

end else begin

   felx := MovePt.x/(Zoom);

   fely := (Height-MovePt.y)/(Zoom);

end;

forigo.x := forigo.x+felx*(1-(fZoom/Value));

forigo.y := forigo.y+fely*(1-(fZoom/Value));

fZoom := Value;

invalidate;

end;

end;

 

function TALSablon.XToS(x: TFloat): integer;

begin

  Result:=Round(Zoom*(x-forigo.x));

end;

 

function TALSablon.YToS(y: TFloat): integer;

begin

  Result:=Height-Round(Zoom*(y-forigo.y));

end;

 

function TALSablon.XToW(x: integer): TFloat;

begin

  Result := origo.x + x / Zoom;

end;

 

function TALSablon.YToW(y: integer): TFloat;

begin

  Result := origo.y + (Height - y) / Zoom;

end;

 

function TALSablon.SToW(x, y: integer): TPoint2d;

begin

  Result.x := XToW(x);

  Result.y := YToW(y);

end;

 

function TALSablon.WToS(x, y: TFloat): TPoint;

begin

Try

  Result.x:= XToS(x);

  Result.y:= YToS(y);

except

  Result:= Point(0,0);

end;

end;

 

{Az origo koord.-áiból kiszámitja a képközéppont koord.it}

function TALSablon.OrigoToCent:TPoint2D;

begin

Result.x := origo.x+Width/(2*Zoom);

Result.y := origo.y+Height/(2*Zoom);

end;

 

{Az képközéppont koord.-áiból kiszámitja a origo koord.it}

function TALSablon.CentToOrigo(c:TPoint2D):TPoint2D;

begin

Result.x := c.x-Width/(2*Zoom);

Result.y := c.y-Height/(2*Zoom);

end;

 

procedure TALSablon.SetBeginPoint(ACurve,AIndex: Integer);

var NewPoints: TList;

   i,j1,j2: integer;

   PPoint: PPointRec;

begin

if AIndex>0 then begin

FCurve:=FCurveList.Items[ACurve];

if InRange(ACurve,0,Pred(FCurveList.Count)) then

if InRange(AIndex,0,Pred(fCurve.FPoints.Count)) then

begin

Try

   NewPoints:=TList.Create;

   For i:=AIndex to Pred(FCurve.fPoints.Count) do begin

       PPoint:=FCurve.fPoints.Items[i];

       NewPoints.Add(PPoint);

   end;

   if FCurve.Closed then begin

      j1 := 0; j2 := AIndex-1;

      For i:=j1 to j2 do begin

       PPoint:=FCurve.fPoints.Items[i];

       NewPoints.Add(PPoint);

   end;

   end else begin

      j2 := 0; j1 := AIndex-1;

      For i:=j1 downto j2 do begin

       PPoint:=FCurve.fPoints.Items[i];

       NewPoints.Add(PPoint);

   end;

   end;

   finally

       FCurve.fPoints.Clear;

       For i:=0 to Pred(NewPoints.Count) do begin

           PPoint:=NewPoints.Items[i];

           FCurve.fPoints.Add(PPoint);

       end;

       NewPoints.Free;

       Selected := FCurve;

       Changed := True;

       if Assigned(fNewBeginPoint) then fNewBeginPoint(Self,ACurve);

   end;

end;

end;

end;

 

procedure TALSablon.DrawMouseCross(o:TPoint;PenMode:TPenMode);

var DC:HDC;

   oldPen: TPen;

begin

Try

   oldPen:=Canvas.Pen;

   oldPen.Color := Canvas.Pen.Color;

   oldPen.Mode  := Canvas.pen.Mode;

   Canvas.pen.Color := clBlue;

   Canvas.pen.Mode := PenMode;

   DrawShape(Canvas,Point(0,o.y),Point(Width,o.y),dmLine,pmNotXor);

   DrawShape(Canvas,Point(o.x,0),Point(o.x,Height),dmLine,pmNotXor);

Finally

   Canvas.Pen.Color:=oldPen.Color;

   Canvas.pen.Mode := oldPen.Mode;

end;

end;

 

procedure TALSablon.MouseDown(Button: TMouseButton; Shift: TShiftState; X,Y: Integer);

Var xx,yy : TFloat;    // Mouse world coordinates

   pr    : TPointRec;

   s     : Str32;

   sel   : boolean;

   RR    : extended;    // Radius for magnify

   InputString : string;

   pp    : TPoint2d;

begin

 

xx := origo.x + x / Zoom;

yy := origo.y + (Height-y) / Zoom;

 

Origin := Point(x,y);

MovePt := Point(x,y);

MousePos := Origin;

If pFazis=0 then oldOrigin := Origin;

 

if (DrawMode<>dmNone) then begin

 

if Shift = [ssLeft] then begin

 

    Case DrawMode of

 

    dmNone :

      if (ActionMode = amSelectArea) then

      Case pFazis of

      0: begin

         Canvas.Pen.Style:=psDash;

         Canvas.Rectangle(Origin.x,Origin.y,Origin.x,Origin.y);

         end;

      1: pFazis := -1;

      end;

 

    dmFreeHand :

    Case pFazis of

    0: h:=MakeCurve('Drawing',-1,dmPolyline,True,True,False);

    else begin

        FCurve := FCurveList.Items[h];

        Selected := FCurve;

        pFazis := -1;

    end;

    end;

 

    dmPoint :

    Case pFazis of

    0: h:=MakeCurve('Point',-1,DrawMode,True,True,False);

    1: pFazis := -1;

    end;

 

    dmLine :

    Case pFazis of

    0: h:=MakeCurve('Line',-1,DrawMode,True,True,False);

    2: pFazis := -1;

    end;

 

    dmRectangle :

    Case pFazis of

    0: h:=MakeCurve('Rectangle',-1,DrawMode,True,True,True);

    1: begin

         FCurve := FCurveList.Items[h];

         FCurve.GetPoint(0,pr.x,pr.y);

         FCurve.ClearPoints;

         // Circle From left botton corner

         FCurve.AddPoint(pr.x,pr.y);

         FCurve.AddPoint(xx,pr.y);

         FCurve.AddPoint(xx,yy);

         AddPoint(H,pr.x,yy);

         pFazis := -1;

       end;

    end;

 

    dmPolyLine  :

    Case pFazis of

    0: h:=MakeCurve('PolyLine',-1,DrawMode,True,True,False);

    end;

 

    dmPolygon  :

    Case pFazis of

    0:

    begin

      h:=MakeCurve('Polygon',-1,DrawMode,True,True,True);

      polygonContinue := True;

    end;

    end;

 

    dmCircle   :

    Case pFazis of

    0: h:=MakeCurve('Circle',-1,DrawMode,True,True,True);

    1: begin

       AddPoint(h,xx,yy);

       pFazis := -1;

       end;

    end;

 

    dmEllipse   :

    Case pFazis of

    0: h:=MakeCurve('Ellipse',-1,DrawMode,True,True,True);

    1: begin

       AddPoint(h,xx,yy);

       pFazis := -1;

       end;

    end;

 

    dmArc:

          case pfazis of

          0: h:=MakeCurve('Arc',-1,DrawMode,True,True,False);

          1: begin

             FCurve.GetPoint(0,pr.x,pr.y);

             pp:=FelezoPont(Point2d(XToS(pr.x),YToS(pr.y)),Point2d(x,y));

             MovePt:=ClientToScreen(Point(Trunc(pp.x),Trunc(pp.y)));

             SetCursorPos(MovePt.x,MovePt.y);

             end;

          2: begin

             ChangePoint(h,1,xx,yy);

             pfazis:=-1;

             end;

          end;

 

    dmSpline:

    Case pFazis of

    0:

    begin

      h:=MakeCurve('Spline',-1,DrawMode,True,True,False);

      polygonContinue := True;

    end;

    end;

 

    dmBSpline:

    Case pFazis of

    0:

    begin

      h:=MakeCurve('BSpline',-1,DrawMode,True,True,True);

      polygonContinue := True;

    end;

    end;

 

    dmText:

    Case pFazis of

    1:

    begin

       AddPoint(h,xx,yy);

       pFazis := -1;

    end;

    end;

 

    end;

    if pFazis>-1 then

       AddPoint(h,xx,yy);

end;

 

end // End of if (DrawMode<>dmNone)

else

    begin

      // Choice selected curve

      if (ActionMode = amNone) and (CurveMatch or CPMatch) then begin

            FCurve := FCurveList.Items[CPCurve];

         if (ssCtrl in Shift) and (ssAlt in Shift) then begin

            if CPMatch then begin

               ActionMode := amNone;

               pr := FCurve.PointRec[CPIndex];

               FCurve.ChangePoint(CPIndex,pr.x,pr.y,not pr.Selected);

            end;

         end else

         if (Shift = [ssShift,ssLeft]) or (Shift = [ssCtrl,ssLeft]) then begin

            sel := FCurve.Selected;

            if Shift=[ssCtrl,ssLeft] then SelectAll(False);

            FCurve.Selected := not sel;

            if CurveMatch then ActionMode := amMoveSelected;

            if CPMatch then ActionMode := amMovePoint;

            if Assigned(fChangeSelected) then fChangeSelected(Self,FCurve,CPIndex);

         end else

            Selected := FCurveList.Items[CPCurve];

      end

      else

         Selected := nil;