mirror of
http://gitlab.expertsoft.com.ua/git/expertcad
synced 2026-01-11 22:45:39 +02:00
8836 lines
238 KiB
ObjectPascal
8836 lines
238 KiB
ObjectPascal
Unit PCTypesUtils;
|
||
|
||
interface
|
||
|
||
|
||
|
||
uses SysUtils, WinTypes, WinProcs, Messages,
|
||
Classes, Graphics, Controls, Forms, Dialogs,
|
||
ExtCtrls,comctrls,buttons,stdctrls,windows,math,
|
||
rrEllipses,menus,oleCtnrs,InPutform,shlObj,Registry,
|
||
U_Common_Classes, MemoForm,comObj,grids,variants,Printers,StrUtils;
|
||
|
||
function GradientFill(DC: HDC; const Vertex {PTriVertex}; NumVertex:ULONG; const Mesh {PGradientTriangle}; NumMesh,Mode: ULONG): BOOL; stdcall; external 'msimg32.dll';
|
||
|
||
|
||
var OutMemo:TMemo=nil;
|
||
ErrorMemo:TMemo=nil;
|
||
ErrorPrinted:Boolean=false;
|
||
|
||
var OutLabel:TLabel=nil;
|
||
|
||
var DragStartX,DragStartY,DragOldX,DragOldY,DragDeltaX,DragDeltaY : Double;
|
||
DragStartXInt,DragStartYInt,DragOldXInt,DragOldYInt,DragDeltaXInt,DragDeltaYInt : Double;
|
||
|
||
DragState: integer;
|
||
DragReady,DragReadyInt: Boolean;
|
||
(*
|
||
var gCanvas: TCGDeviceContext;
|
||
var gcL: TCGLight;
|
||
*)
|
||
|
||
|
||
|
||
const dsNone = 0;
|
||
dsMove = 1;
|
||
dsMod = 2;
|
||
dsHScroll = 3;
|
||
dsVScroll = 4;
|
||
dsPan = 7;
|
||
dsHRuler = 5;
|
||
dsVRuler = 6;
|
||
dsLocate = 8;
|
||
dsDetPan = 9;
|
||
|
||
IdLine = 0;
|
||
IdCircle = 1;
|
||
IdEllipse = 2;
|
||
IdRectangle = 3;
|
||
IdArc = 4;
|
||
IdBezier = 5;
|
||
IdPolyLine = 6;
|
||
|
||
|
||
ciFile = 0;
|
||
ciDraw = 1;
|
||
ciEdit = 2;
|
||
ciArrange = 3;
|
||
ciModify = 4;
|
||
ciTransform = 5;
|
||
ciView = 6;
|
||
ciInsert = 7;
|
||
ciOptions = 8;
|
||
ciTools = 9;
|
||
ciMacros = 10;
|
||
ciBlocks = 11;
|
||
ciPlugins = 12;
|
||
ciMenus = 13;
|
||
|
||
|
||
bFile = 1;
|
||
bEdit = 2;
|
||
bAlign = 3;
|
||
bText = 4;
|
||
bPen = 5;
|
||
bBrush = 7;
|
||
bTools = 8;
|
||
bArrange = 9;
|
||
bTransform = 10;
|
||
bMainMenu = 11;
|
||
|
||
cNew = 1;
|
||
cOpen = 2;
|
||
cSave = 3;
|
||
cSaveAs = 4;
|
||
cExit = 5;
|
||
cFile = 99;
|
||
cPrint = 6;
|
||
cPrintPreview = 7;
|
||
cPrinterSetup = 8;
|
||
cExportDrawing = 9;
|
||
cImportDrawing = 10;
|
||
cPageSetup = 11;
|
||
cSelectTool = 12;
|
||
cLine = 13;
|
||
cRectangle = 14;
|
||
cCircle = 15;
|
||
cEllipse = 16;
|
||
cArc = 17;
|
||
cPolyline = 18;
|
||
cPoint = 19;
|
||
cText = 20;
|
||
cUndo = 21;
|
||
cRedo = 22;
|
||
cCut = 23;
|
||
cCopy = 24;
|
||
cPaste = 25;
|
||
cDelete = 26;
|
||
cClear = 27;
|
||
cEdit = 100;
|
||
cTextColor = 91;
|
||
cPenColor = 92;
|
||
cBrushColor = 93;
|
||
cPenStyle = 94;
|
||
cBrushStyle = 95;
|
||
cRowStyle = 96;
|
||
cPenWidth = 97;
|
||
cFontName = 98;
|
||
cBold = 28;
|
||
cItalic = 29;
|
||
cUnderline = 30;
|
||
cStrike = 31;
|
||
cMove = 32;
|
||
cDuplicate = 33;
|
||
cRotate = 34;
|
||
cMirror = 35;
|
||
cArrayPolar = 36;
|
||
cArrayRectangular = 37;
|
||
cGroup = 38;
|
||
cUnGroup = 39;
|
||
cBringToFront = 40;
|
||
cSendToBack = 41;
|
||
cBringForward = 42;
|
||
cSendBackward = 43;
|
||
cInvertArc = 44;
|
||
cArcStyleOpen = 45;
|
||
cArcStylePie = 46;
|
||
cArcStyleChord = 47;
|
||
cFlipImageHorizontal = 48;
|
||
cFlipImageVertical = 49;
|
||
cTransparentImage = 50;
|
||
cClipImage = 51;
|
||
cBoundLine = 52;
|
||
cWeldIntoPolyLine = 53;
|
||
cConvertBeziertoPolyLine = 54;
|
||
cConvertPolyLinetoBezier = 55;
|
||
cPolyLineClosed = 56;
|
||
cInsertPicture = 57;
|
||
cInsertBlock = 58;
|
||
|
||
|
||
cMakeBlock = 59;
|
||
cAlignTops = 60;
|
||
cAlignBottoms = 61;
|
||
cAlignYCenters = 62;
|
||
cAlignLefts = 63;
|
||
cAlignRights = 64;
|
||
cAlignXCenters = 65;
|
||
cDistrubuteHorizontal = 66;
|
||
cDistrubuteVertical = 67;
|
||
|
||
cShowProperties = 68;
|
||
cLayersDialog = 69;
|
||
cEnvironmentOptions = 70;
|
||
cBlocksManager = 71;
|
||
cMacroManager = 72;
|
||
cActualSize = 73;
|
||
cFitToPage = 74;
|
||
cZoom50 = 75;
|
||
cZoom75 = 76;
|
||
cZoom25 = 77;
|
||
cZoom150= 78;
|
||
cZoom200 = 79;
|
||
cZoom125 = 80;
|
||
cZoom175 = 81;
|
||
cZoomIn = 82;
|
||
cZoomOut = 83;
|
||
cCustomize = 84;
|
||
cRichText = 85;
|
||
cOleObject = 86;
|
||
cMathGraph = 87;
|
||
cArrange = 101;
|
||
cOrder = 102;
|
||
cAlign = 103;
|
||
cArcStyle = 104;
|
||
cInsert = 105;
|
||
cView = 106;
|
||
cTools = 107;
|
||
cZoom = 108;
|
||
cModifyDialog = 109;
|
||
cNonTransparentImage = 110;
|
||
cUnBoundLine = 111;
|
||
cSelectAll = 112;
|
||
cDeSelectAll = 113;
|
||
cInvertSelection = 114;
|
||
cPolylineOpen = 115;
|
||
cUnClipImage = 116;
|
||
cZoomArea = 117;
|
||
cInsertCurrentBlock = 118;
|
||
cRunMacro = 119;
|
||
cFontDialog = 120;
|
||
cDimLines = 121;
|
||
cHorzDim = 122;
|
||
cVertDim = 123;
|
||
cAlignedDim = 124;
|
||
cTextCharset = 125;
|
||
cTextSize = 126;
|
||
cTextRatio = 127;
|
||
cDrawTool = 128;
|
||
cFormat = 129;
|
||
cFontStyle = 130;
|
||
cAlignDlg = 131;
|
||
cTransformDlg = 132;
|
||
cOptions = 133;
|
||
cGrids = 134;
|
||
cRulers = 135;
|
||
cGuides = 136;
|
||
cSnapGrid = 137;
|
||
cSnapGuides = 138;
|
||
cSnapObject = 139;
|
||
cGridColor = 140;
|
||
cGuideColor = 141;
|
||
cAngularGuides = 142;
|
||
cRulerSystem = 143;
|
||
cInch = 144;
|
||
cMetric = 145;
|
||
cRecordUndo = 146;
|
||
cPageLo = 147;
|
||
cPageOr = 148;
|
||
cBackColor = 149;
|
||
cMacroDir = 150;
|
||
cBlockDir = 151;
|
||
cA0 = 152;
|
||
cA1 = 153;
|
||
cA2 = 154;
|
||
cA3 = 155;
|
||
cA4 = 156;
|
||
cA5 = 157;
|
||
cA6 = 158;
|
||
cB4 = 159;
|
||
cB5 = 160;
|
||
cTabloid = 161;
|
||
cLetter = 162;
|
||
cCustom = 163;
|
||
cLandscape = 164;
|
||
cPortrait = 165;
|
||
cInfoXY = 166;
|
||
cInfoDim = 167;
|
||
cInfoMes = 168;
|
||
cCommEdit = 169;
|
||
cPageColor = 170;
|
||
cRunPlugin = 171;
|
||
cGridStep = 172;
|
||
cMapScale = 173;
|
||
cArcSel = 174; // used by system itself
|
||
cBmpSel = 175; // used by system itself
|
||
cLineSel = 176; // used by system itself
|
||
cPLineSel = 177; // used by system itself
|
||
cGroupSel = 178; // used by system itself
|
||
cAnySel = 179; // used by system itself
|
||
cPluginVerbs = 180;
|
||
cCenterGuides = 181;
|
||
cPluginManager = 182;
|
||
cPageWidth = 183;
|
||
cPageHeight = 184;
|
||
cRulerMode = 185;
|
||
cGridType = 186;
|
||
cRadiusDim = 187;
|
||
cAngleDim = 188;
|
||
cOffset = 189;
|
||
cConvertToBezier = 190;
|
||
cDuplicateAsBezier = 191;
|
||
cElpArc = 192;
|
||
cInterbreak = 193;
|
||
cKnife = 194;
|
||
cFreeHand = 195;
|
||
|
||
|
||
|
||
|
||
|
||
//OLE Cursors
|
||
crOleDefault = 0;
|
||
crOleArrow = 1;
|
||
crOleCross = 2;
|
||
crOleIBeam = 3;
|
||
crOleSize = 5;
|
||
|
||
crOleSizeNESW = 6;
|
||
crOleSizeNS = 7;
|
||
crOleSizeNWSE = 8;
|
||
crOleSizeWE = 9;
|
||
crOleUpArrow = 10;
|
||
crOleHourGlass = 11;
|
||
crOleNoDrop = 12;
|
||
crOleAppStart = 13;
|
||
crOleHelp = 14;
|
||
crOleSizeAll = 15;
|
||
|
||
crOleDrag = 16;
|
||
crOleHandPoint = 17;
|
||
crOleHSplit = 18;
|
||
crOleVSplit = 19;
|
||
|
||
|
||
|
||
//ole dragsource id s
|
||
oleDS_Surface = 3;
|
||
oleDS_BlockBox = 4;
|
||
|
||
|
||
// ole shift states
|
||
oleShift = 1;
|
||
oleCtrl = 2;
|
||
oleAlt = 4;
|
||
oleLeft = 8;
|
||
oleRight= 16;
|
||
oleMiddle = 32;
|
||
oleDouble = 64;
|
||
|
||
// ole mouse buttons
|
||
oleMbLeft = 0;
|
||
oleMbRight = 1;
|
||
oleMbMiddle = 2;
|
||
|
||
//ole drag state
|
||
oledsDragEnter = 0;
|
||
oledsDragLeave = 1;
|
||
oledsDragMove=2;
|
||
|
||
var spin : integer = 0;
|
||
var tip : integer = 0;
|
||
|
||
const rd = PI/180;
|
||
|
||
|
||
|
||
|
||
Const BasicColors : array [1..48] of TColor = (8421631,8454143,8454016,8453888,
|
||
16777088,16744448,12615935,16744703,255,65535,65408,4259584,16776960,12615680,
|
||
12615808,16711935,4210816,4227327,65280,8421376,8404992,16744576,4194432,
|
||
8388863,128,33023,32768,4227072,16711680,10485760,8388736,16711808,64,16512,
|
||
16384,4210688,8388608,4194304,4194368,8388672,0,32896,4227200,8421504,8421440,
|
||
12632256,4194368,16777215);
|
||
|
||
//03.08.2012 - <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
|
||
const GrayedColors: array[0..59] of TColor = (
|
||
$FCFCFC,$FAFAFA,$F7F7F7,$F5F5F5,$F2F2F2,$F0F0F0,$EDEDED,$EBEBEB,$E8E8E8,$E5E5E5,
|
||
//clSilver,
|
||
$E3E3E3,$E0E0E0,$DEDEDE,$DBDBDB,$D9D9D9,$D6D6D6,$D4D4D4,$D1D1D1,$CFCFCF,$CCCCCC,
|
||
$C9C9C9,$C7C7C7,$C4C4C4,$C2C2C2,$BFBFBF,$BDBDBD,$BABABA,$B8B8B8,$B5B5B5,$B3B3B3,
|
||
clSilver,
|
||
$B0B0B0,$ADADAD,$ABABAB,$A8A8A8,$A6A6A6,$A3A3A3,$A1A1A1,$9E9E9E,$9C9C9C,$999999,
|
||
$969696,$949494,$919191,$8F8F8F,$8C8C8C,$8A8A8A,$878787,$858585,$828282,$7F7F7F,
|
||
$7D7D7D,$7A7A7A,$787878,$757575,$737373,$707070,$6E6E6E,$6B6B6B,$696969);
|
||
|
||
//03.08.2012 GrayedColor = clSilver;
|
||
DefGrayedColor = clSilver;
|
||
|
||
pointdim = 3;
|
||
ElpRes = 500; // Line resolution when drawing an ellipse
|
||
|
||
HeadLength=3.5;
|
||
HeadHeight=1.2;
|
||
|
||
|
||
const BoolStr: array[0..1] of String = ('False','True');
|
||
const BoolString: array[Boolean] of String = ('False','True');
|
||
const SignBytes: array[1..8] of Byte = (123,125,212,234,076,065,169,214);
|
||
const RegChars: array[1..30] of Byte =(85,110,114,101,103,105,115,116,101,114,101,100,32,67,111,112,121,32,111,102,32,80,111,119,101,114,67,65,68,46);
|
||
const CsArray : Array [0..17] of Byte = (ANSI_CHARSET,DEFAULT_CHARSET,
|
||
SYMBOL_CHARSET,SHIFTJIS_CHARSET,GB2312_CHARSET,HANGEUL_CHARSET,CHINESEBIG5_CHARSET,
|
||
OEM_CHARSET,JOHAB_CHARSET,HEBREW_CHARSET,ARABIC_CHARSET,GREEK_CHARSET,TURKISH_CHARSET,
|
||
THAI_CHARSET,EASTEUROPE_CHARSET,RUSSIAN_CHARSET,MAC_CHARSET,BALTIC_CHARSET);
|
||
|
||
|
||
Type
|
||
|
||
TLanguage = 0..$FFFF;
|
||
TLangOption = (loLocalized, loEnglish, loNative, loAbbrev);
|
||
ConvertXYProc = Procedure (var X,Y,Z: Double) of Object;
|
||
ConvertDimProc = Procedure (var Dim: Double) of Object;
|
||
TGetValueFunc = Function (Obj:Pointer):Double;
|
||
TGetValueFuncEx = Function (Obj,Data:Pointer):Double;
|
||
|
||
TStringArray = Array of String;
|
||
T2DStringArr = Array of Array [0..1] of String;
|
||
TWebCol = String;
|
||
TwebRow = Array of TwebCol;
|
||
TwebTable = Array of TWebRow;
|
||
TwebTableArr = Array of TWebTable;
|
||
TDetailStyle = (dsZoom,dsIsometry);
|
||
|
||
TMapDirection = (mdNorth,mdEast,mdSouth,mdWest,mdNorthEast,mdSouthEast,mdSouthWest,mdNorthWest);
|
||
T3DAxis = (aZ,aY,aX);
|
||
TInsertState = (isInsert,isDontInsert,isDelete);
|
||
|
||
TPCTool = (
|
||
toSelect,
|
||
toZoom,
|
||
toInsertBlock,
|
||
toInsertCurrentBlock,
|
||
toFigure,
|
||
toOperation,
|
||
toInsertUserPicture,
|
||
toDetailZoom,
|
||
toLocate,
|
||
toDelete,
|
||
toMWand
|
||
);
|
||
|
||
TFillType = (fsNone,fsSolid,fsHatch,fsGradient,fsTexture,fsExtended);
|
||
THatchStyle = (hsNone,hsHorizontal,hsVertical,hsCross,hsRDiagonal,
|
||
hsLDiagonal,hsDCross,hsCheckered,hsDCheckered,
|
||
hsHBricks,hsVBricks,hsDBricks);
|
||
TGradStyle = (gsNoGrad,gsRadCenter, gsRadTop, gsRadBottom, gsRadLeft,
|
||
gsRadRight, gsRadTopLeft, gsRadTopRight, gsRadBottomLeft, gsRadBottomRight, gsLineHorz,
|
||
gsLineVert, gsRefHorz, gsRefVert, gsDiagLineF, gsDiagLineB,
|
||
gsDiagRefF, gsDiagRefB, gsArrowLeft, gsArrowRight, gsArrowUp, gsArrowDown,
|
||
gsQuadrant, gsMirrored);
|
||
TTextureStyle = (txtNone,txtNewsPrint,txtRcPaper,txtParchment,txtStationery,txtGreenMarble,
|
||
txtWhiteMarble,txtBrownMarble,txtGranite,txtBluePaper,txtPinkPaper,
|
||
txtPurpleMesh,txtBouquet,txtPapyrus,txtCanvas,txtDenim,txtWovenMat,
|
||
txtWaterDroplets,txtPaperBag,txtFishFossil,txtSand,txtCork,txtWalnut,
|
||
txtOak,txtMediumWood,txtCustom);
|
||
|
||
|
||
TDrawStyle = (dsTrace,mydsNormal,dsCanvas);
|
||
TModPointType = ( ptUnDefined,ptCirclePoint, ptLineEnd, ptPolyPoint, ptRectPoint,
|
||
ptTextPoint,ptGroupPoint,ptBezierPoint,ptArcEnd,ptElpArcEnd,
|
||
ptElpPoint,ptPictPoint,ptControlPoint,ptCustomPoint,ptArcControl,ptRotPoint,ptRotCenter);
|
||
|
||
TBezierPoint = (psCorner,psCurve,psCurveCorner);
|
||
TSegmentType = (sLine,sCurve,sArc);
|
||
|
||
TRowStyle = ( rsNone,rsRightSolid,rsLeftSolid, rsBothSolid,
|
||
rsRightLight,rsLeftLight,rsBothLight );
|
||
TPageLayout = ( plA0,plA1,plA2,plA3,plA4,plA5,plA6,plB4,plB5,plTabloid,
|
||
plLetter,plCustom );
|
||
TPageOrient = ( poLandscape , poPortrait);
|
||
|
||
THorzAligns = ( haNoChange, haTop, haBottom, haCenter, haDistHorz );
|
||
|
||
TVertAligns = ( vaNoChange, vaLeft, vaRight, vaCenter, vaDistVert );
|
||
TTextAlign = (taTopLeft,taTopCenter,taTopRight,taMiddleLeft,taMiddleCenter,
|
||
taMiddleRight,taBottomLeft,taBottomCenter,taBottomRight);
|
||
TTextVAlign = (vtCenter,vtTop,vtBottom);
|
||
TTextHAlign = (htCenter,htLeft,htRight);
|
||
|
||
TRulerSystem = (rsMetric, rsWhitworth);
|
||
TVertZero = (vzBottom,vzTop);
|
||
THorzZero = (vzLeft,vzRight);
|
||
|
||
TShow = (seen,lost,grayed);
|
||
TGuideType = (gtVert,gtHorz);
|
||
TTBCommand = Integer;
|
||
|
||
TModifyMode = ( mmPenColor,mmPenWidth,mmBrushColor,mmPenStyle,mmBrushStyle,
|
||
mmRowStyle, mmText, mmFontName, mmFontSize, mmFontCs, mmFontColor, mmFontStyle,
|
||
mmFontBold,mmFontItalic,mmFontUnderline,mmFontStrike);
|
||
|
||
TOrderStyle = (osBack,osFront,osBward,osFWard);
|
||
TFigurePopStyle = (fpsNone,fpsStandart,fpsAppendCustom,fpsOnlyCustom);
|
||
THDimLabelStyle = (hlsInner,hlsLeft,hlsRight,hlsLeftTop,hlsLeftBottom,
|
||
hlsRightTop,hlsRightBottom);
|
||
TVDimLabelStyle = (vlsInner,vlsTop,vlsBottom,vlsTopLeft,vlsTopRight,
|
||
vlsBottomLeft,vlsBottomRight);
|
||
TADimLabelStyle = (alsInner,alsLeft,alsRight);
|
||
TCDimLabelStyle = (clsInner,clsLeft,clsRight);
|
||
TArcDimLabelStyle = (rlsInner,rlsOuter);
|
||
|
||
|
||
TEndType = (etClear,etRow,etDot,etNick);
|
||
TDimTextPos = (tpOnLine,tpAbove,tpBelow);
|
||
|
||
TFlipMode = (fmVert,fmHorz);
|
||
TFlipModes = set of TFlipMode;
|
||
TIconVertPos = (vposTop,vposBottom,vposMiddle);
|
||
TIconHorzPos = (hposLeft,hposRight,hposMiddle);
|
||
|
||
TArcStyle = (asOpen,asPie,asChord);
|
||
|
||
TStatementType =
|
||
( stDocBegin, stDocEnd, stLayerBegin, stLayerEnd,stTablesBegin,stTablesEnd,
|
||
stBlockBegin,stBlockEnd,StFigureBegin,stFigureEnd,StInFigureBegin,stInFigureEnd,
|
||
tValue,stPoints,stDocValue,stLayerValue,stBlockValue,StFigureValue,
|
||
stUndefined);
|
||
|
||
TGridType = (grtLine,grtPoint,grtCross);
|
||
|
||
TDoublePoint = record
|
||
x: Double;
|
||
y: Double;
|
||
z: Double;
|
||
end;
|
||
|
||
T3DPoint = TDoublePoint;
|
||
P3DPoint = ^T3DPoint;
|
||
|
||
TDoubleRect = record
|
||
Left: Double;
|
||
Top: Double;
|
||
Right:Double;
|
||
Bottom: Double;
|
||
end;
|
||
|
||
TSortItem = record
|
||
Value: Double;
|
||
Tag:LongInt;
|
||
end;
|
||
|
||
TSortItemArr = array of TSortItem;
|
||
|
||
TRGB = record
|
||
R, G, B: Double;
|
||
end;
|
||
|
||
|
||
PDoublePoint = ^TDoublePoint;
|
||
|
||
TDoublePointArr = array of TDoublePoint;
|
||
PDoublePointArr = ^TDoublePointArr;
|
||
|
||
TPointArr = array of Windows.TPoint;
|
||
TDoublePointSet = array of TDoublePointArr;
|
||
TDoublePointGroup = array of TDoublePointArr;
|
||
T3DPointArray = array of T3DPoint;
|
||
TBoolArray = array of Boolean;
|
||
TDoubleArray = array of Double;
|
||
PDoubleArray = ^TDoubleArray;
|
||
|
||
T3DFace = T3DPointArray;
|
||
TSolid= Array of T3DFace;
|
||
TTokenArray = Array [0..99] of string;
|
||
TByteArr = array of Byte;
|
||
|
||
TLayerInfo = record
|
||
Name : string;
|
||
visible : boolean;
|
||
Grayed : boolean;
|
||
end;
|
||
|
||
TShadowType = (stNone,stLine,stRectangle,stCircle,stPolyline);
|
||
TVectorSegmentType = (vstLine,vstBezier);
|
||
TVectorObjectType = (votLine,votBezier,votEllipse,votCircle,votPolyline,votPolygon,votPoint);
|
||
TFitMode = (fmNone,fmAutoGap,fmDistEnlarge,fmDistShrink,fmEnlargeLast,fmShrinkLast);
|
||
TCadMacro = Record
|
||
Name: string;
|
||
lines: TStringlist;
|
||
end;
|
||
|
||
//Tolik 03/06/2021 --
|
||
//TUndoActionType = (uaModify,uaInsert,uaRemove,uaOrder,uaGroup,uaUnGroup,uaClip,uaUnClip,uaReplace,uaDimLine);
|
||
TUndoActionType = (uaModify,uaInsert,uaRemove,uaOrder,uaGroup,uaUnGroup,uaClip,uaUnClip,uaReplace,uaDimLine, uaList, uaDesignList, uaProjectPlan);
|
||
//
|
||
TUndoAction = class(TMyObject)
|
||
ActionType : TUndoActionType;
|
||
FIndex: Integer;
|
||
List: TList;
|
||
Params: TList;
|
||
RedoList: TList;
|
||
Tag: Integer;
|
||
Constructor Create(aType:TUndoActionType);
|
||
Destructor Destroy;override;
|
||
end;
|
||
|
||
TEventCallBack = Procedure (Client:TObject; EventId: Integer; Numval:Integer;
|
||
StrVal: String; DblVal:Double;Enabled:Boolean);stdcall;
|
||
|
||
TEventItem = class
|
||
Client: Tobject;
|
||
CallBack: TEventCallBack;
|
||
Constructor Create(aClient:TObject;aCallback: TEventCallBack);
|
||
end;
|
||
|
||
TEventEngine = class (TObject)
|
||
EventId:Integer;
|
||
Clients: TList;
|
||
NumVal : Integer;
|
||
Strval : String;
|
||
DblVal : Double;
|
||
Enabled: Boolean;
|
||
Function RegisterClient(Client:TObject;CallBack: TEventCallBack):Pointer;
|
||
Procedure UnRegisterClient(EvHandle:Pointer);
|
||
Procedure RaiseEvent(aNumVal: Integer; aStrval:String;
|
||
aDblVal:Double);overload;
|
||
Procedure RaiseEvent(bVal:Boolean);overload;
|
||
Procedure RaiseEvent(aNumVal:Integer);overload;
|
||
Procedure RaiseEvent(aDblVal:Double);overload;
|
||
Procedure RaiseEvent(aStrVal:String);overload;
|
||
Procedure RaiseEvent;overload;
|
||
Procedure EnableEvent(xEnabled: Boolean);
|
||
Constructor Create (Id: Integer;aNumVal: Integer; aStrval:String;
|
||
aDblVal:Double);
|
||
Destructor Destroy;override;
|
||
end;
|
||
|
||
TColorMenuItem = class(TMenuItem)
|
||
Private
|
||
FColor:TColor;
|
||
SelectedItem: TMenuItem;
|
||
Bitmap: Graphics.TBitmap;
|
||
Procedure SetColor(Value: TColor);
|
||
public
|
||
Constructor Create(aOwner:TComponent);
|
||
procedure ChildMeasureItem(Sender: TObject; ACanvas: TCanvas;
|
||
var Width, Height: Integer);
|
||
procedure ChildAdvancedDrawItem(Sender: TObject; ACanvas: TCanvas;
|
||
ARect: TRect; State: TOwnerDrawState);
|
||
procedure SelfMeasureItem(Sender: TObject; ACanvas: TCanvas;
|
||
var Width, Height: Integer);
|
||
procedure SelfAdvancedDrawItem(Sender: TObject; ACanvas: TCanvas;
|
||
ARect: TRect; State: TOwnerDrawState);
|
||
Procedure ColorSelected(Sender:TObject);
|
||
Procedure SetBitmap(aBitmap: Graphics.TBitmap);
|
||
Property Color:TColor read FColor write setColor;
|
||
end;
|
||
|
||
TColorChangeEvent = Procedure (Sender:Tobject; xColor:TColor) of Object;
|
||
|
||
TColorPopUp = class(TPopUpMenu)
|
||
Private
|
||
FColor:TColor;
|
||
SelectedItem: TMenuItem;
|
||
FColorChange: TColorChangeEvent;
|
||
Procedure SetColor(Value: TColor);
|
||
public
|
||
Constructor Create(aOwner:TComponent);
|
||
procedure ChildMeasureItem(Sender: TObject; ACanvas: TCanvas;
|
||
var Width, Height: Integer);
|
||
procedure ChildAdvancedDrawItem(Sender: TObject; ACanvas: TCanvas;
|
||
ARect: TRect; State: TOwnerDrawState);
|
||
Procedure ColorSelected(Sender:TObject);
|
||
Property Color:TColor read FColor write setColor;
|
||
Property OnColorChange:TColorChangeEvent read FColorChange write FColorChange;
|
||
end;
|
||
|
||
// <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> TFaceRecord
|
||
TFaceType = (ftPolygon,ftLine,ftCube,ftBar,ftPipe,ftCircle,ftSphere,ftCenterCube, ftPicture,
|
||
ftNetPath, ftNetDoor, ftNetWindow, ftNetBalconDoor, ftNetBalconWindow, ftNetFrame,
|
||
ftNetFloor, ftNetCeiling, ftNet3DSObject, {Tolik 18/09/2018 -- }ftCylinder, ftBooblick);
|
||
// <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>
|
||
TFaceWallType = (fwtNone, fwtInner, fwtOuter, fwtDoorSlope, fwtWindowSlope, fwtBalconSlope, fwtNiche, fwtArc);
|
||
// <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>
|
||
TWallSideType = (wstNone, wstUpper, wstUnder, wstLeft, wstRight, wstLeftSide, wstRightSide);
|
||
// <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>
|
||
TWallViewTypes = (wvtNoUpper, wvtNoUnder, wvtNoLeft, wvtNoRight, wvtNoLeftSide, wvtNoRightSide);
|
||
TWallViewType = set of TWallViewTypes;
|
||
|
||
|
||
TFaceRecord = class(TMyObject)
|
||
Points : T3DPointArray;
|
||
PointsForNormal : T3DPointArray;
|
||
Normal: T3dPoint;
|
||
Color : TColor;
|
||
RecType: TFaceType; //
|
||
Size: Double;
|
||
Trans: Boolean;
|
||
OpTrans: Boolean;
|
||
Info: String;
|
||
FFigure: TObject;
|
||
// 22.07.2011
|
||
F3DObject: TObject;
|
||
FFaceWallType: TFaceWallType;
|
||
FWallSideType: TWallSideType;
|
||
FTreeNode: TTreeNode;
|
||
FComponID: Integer;
|
||
FCadID: Integer;
|
||
constructor Create(fPoints: T3DPointArray; xColor: Tcolor; xType: TFaceType; xsize:Double = 0.1;
|
||
oTrans: Boolean = False; aFigure: TObject = nil; aComponID: Integer = 0);
|
||
// Tolik
|
||
Destructor destroy; override;
|
||
end;
|
||
|
||
|
||
TBevelShapeEx = (bsBox, bsFrame, bsTopLine, bsBottomLine, bsLeftLine,
|
||
bsRightLine, bsSpacer,bsVertLine,bsHorzLine);
|
||
|
||
TBevelEx = class(TBevel)
|
||
private
|
||
FShape: TBevelShapeEx;
|
||
procedure SetShape(Value: TBevelShapeEx);
|
||
protected
|
||
procedure Paint; override;
|
||
published
|
||
property Shape: TBevelShapeEx read FShape write SetShape default bsBox;
|
||
end;
|
||
|
||
TMFSOle = class(TOleContainer)
|
||
private
|
||
FOnChange:TNotifyEvent;
|
||
protected
|
||
procedure Changed; override;
|
||
public
|
||
Property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
||
end;
|
||
|
||
|
||
TMGScaleStyle = (gsNone,gsTick,gsNumbers,gsBoth);
|
||
|
||
TGuideTraces = (gtNone,gtNinty,gtThirty,gtFortyFive,gtSixty,gtCustom);
|
||
|
||
TMouseTraceEvent = procedure (Sender: TObject; Shift: TShiftState; X,Y: Double) of object;
|
||
TMousePushEvent = procedure (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Double) of object;
|
||
TMousePullEvent = procedure (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Double) of object;
|
||
TDropDragEvent = procedure (Sender, Source: TObject; X, Y: Double) of object;
|
||
TDragTraceEvent = procedure (Sender, Source: TObject; X, Y: Double;State: TDragState; var Accept: Boolean) of object;
|
||
TDragEndEvent = procedure (Sender, Target: TObject; X, Y: Double) of object;
|
||
TDragStartEvent = procedure (Sender: TObject; var DragObject: TDragObject) of object;
|
||
TSnapProc = procedure (var x,y: Double) of object;
|
||
|
||
TPointType = (ptRect,ptCircle,ptCross,ptStar,ptRow,ptRCenter,ptECircle,ptCCross,ptTarget);
|
||
TPointArray = array of TPoint;
|
||
glnarray = ARRAY [1..1000] OF real;
|
||
TFigHandle = LongInt;
|
||
|
||
TColorSpeedButton = class(TSpeedButton)
|
||
protected
|
||
procedure Paint; override;
|
||
end;
|
||
|
||
const
|
||
MaxPixelCount = 32768;
|
||
|
||
const penstyles : array[0..6] of TPenStyle = (psSolid, psDash, psDot, psDashDot, psDashDotDot, psClear, psInsideFrame);
|
||
const brushstyles : array[0..7] of TBrushStyle = (bsSolid, bsClear, bsHorizontal, bsVertical, bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross);
|
||
|
||
(*
|
||
const mval : array [1..4,1..4] of real = (
|
||
( -1, 3, -3, 1 ),
|
||
( 3, -6, 3, 0 ),
|
||
( -3, 3, 0, 0 ),
|
||
( 1, 0, 0, 0 )
|
||
);
|
||
|
||
|
||
{ -0.5, 1.5, -1.5, 0.5 },
|
||
{ 1.0, -2.5, 2.0, -0.5 },
|
||
{ -0.5, 0.0, 0.5, 0.0 },
|
||
{ 0.0, 1.0, 0.0, 0.0 }};
|
||
|
||
|
||
|
||
const mval : array [1..4,1..4] of real = (
|
||
( -0.5, 1.5, -1.5, 0.5 ),
|
||
( 1.0, -2.5, 2.0, -0.5 ),
|
||
( -0.5, 0.0, 0.5, 0.0 ),
|
||
( 0.0, 1.0, 0.0, 0.0 )
|
||
);
|
||
Matrix bsplinematrix = {
|
||
{ -1.0/6.0, 3.0/6.0, -3.0/6.0, 1.0/6.0 },
|
||
{ 3.0/6.0, -6.0/6.0, 3.0/6.0, 0.0 },
|
||
{ -3.0/6.0, 0.0, 3.0/6.0, 0.0 },
|
||
{ 1.0/6.0, 4.0/6.0, 1.0/6.0, 0.0 }};
|
||
|
||
const mval : array [1..4,1..4] of real = (
|
||
( -1.0/6.0, 3.0/6.0, -3.0/6.0, 1.0/6.0),
|
||
( 3.0/6.0, -6.0/6.0, 3.0/6.0, 0.0 ),
|
||
( -3.0/6.0, 0.0, 3.0/6.0, 0.0 ),
|
||
( 1.0/6.0, 4.0/6.0, 1.0/6.0, 0.0 )
|
||
);
|
||
*)
|
||
|
||
const mval : array [1..4,1..4] of real = (
|
||
( -1, 3, -3, 1 ),
|
||
( 3, -6, 3, 0 ),
|
||
( -3, 3, 0, 0 ),
|
||
( 1, 0, 0, 0 )
|
||
);
|
||
|
||
|
||
TYPE
|
||
|
||
pRGBArray = ^TRGBArray; // Use SysUtils.pByteArray for 8-bit color
|
||
TRGBArray = ARRAY[0..MaxPixelCount-1] OF TRGBTriple;
|
||
|
||
|
||
Function ValidateString(str: String):String;
|
||
|
||
Function readInt(ptr: pointer; index: integer): Pint;
|
||
Procedure PutSign(canvas: TCanvas;point:Tpoint);
|
||
Function IspointInBezier(p1,p2,p3,p4,point:TDoublepoint):boolean;
|
||
Function IspointInPolyBezier(Points:TDoublePointArr;Point:TDoublepoint):boolean;
|
||
Function IspointInArc(hp,cp:TDoublePoint;rad: Double;arcstyle:Integer;a1,a2:Double):Boolean;overload;
|
||
Function IspointInArc(hp,cp:TDoublePoint;rad: Double;arcstyle:Integer;ap1,ap2:TDoublePoint;inverted:Boolean):Boolean;overload;
|
||
Function IspointInCircle(x,y,cx,cy,radius:Double):Boolean;
|
||
Function IspointInEllipse(x,y,cx,cy,alen,blen,angle:Double):Boolean;
|
||
Function GetArcCenter(p1,p2:TDoublepoint;Angle:Double):TDoublePoint;
|
||
Function GetBezierSample(p1,p2,p3,p4:TDoublepoint;Index,Resolution:Integer):TDoublePoint;overload;
|
||
Function GetBezierSample(p1,p2,p3,p4:TDoublepoint;tx:Double):TDoublePoint;overload;
|
||
Procedure BeziersToPolyline(bpoints:TDoublePointArr;var pPoints:TDoublePointArr; PatchLen:Double);
|
||
Procedure BezierToPolyline(p1,p2,p3,p4:TDoublePoint;var pPoints:TDoublePointArr; PatchLen:Double;incFirst:Boolean);
|
||
Function AddFileExt(Fname,FExt:String):String;
|
||
//Tolik 15/12/2021 --
|
||
function IsPointInLine3D(const m1,m2 : TDoublePoint;
|
||
const p : TDoublePoint;
|
||
PenWidth : double;
|
||
MarginDelta:Double = 2) : Boolean;
|
||
//
|
||
function IsPointInLine(const m1,m2 : TdoublePoint;
|
||
const p : TDoublePoint;
|
||
const PenWidth : Integer;MarginDelta:Double = 2) : Boolean;
|
||
function PointInRect(const P: TDoublePoint; const R: TDoubleRect): Boolean;
|
||
function PointInPolyRect(P: TDoublePoint; r1,r2,r3,r4: TDoublePoint): Boolean;
|
||
Function PtInPolygon(POINTS:TDoublePointArr; ptTest:TDoublePoint):Boolean;
|
||
Function RectCenter(Rect:TDoubleRect):TDoublePoint;
|
||
Procedure GetPolylineBounds(Points:TDoublePointArr;var figMaxX,figMaxY,figMinX,figMinY: double);
|
||
Procedure GetBezierBounds(p1,p2,p3,p4:TDoublePoint;var figMaxX,figMaxY,figMinX,figMinY: double);
|
||
Procedure GetPolyBezierBounds(Points:TDoublePointArr; var figMaxX,figMaxY,figMinX,figMinY: double);
|
||
Procedure GetArcBounds(p1:TDoublePoint; rad1,rad2: Double; arcstyle: Integer; a1,a2,a: Double;
|
||
var figMaxX,figMaxY,figMinX,figMinY: double);
|
||
Procedure GetDoubleArcPoints(cx,cy,rad1,rad2,a1,a2,a3,a4:Double; var p:TdoublePointArr);
|
||
Procedure DoubleArcToPolyGon(cx,cy,rad1,rad2,a1,a2,a3,a4:Double; var p:TdoublePointArr);
|
||
|
||
Function GetRelativePointbyAngle(angle: integer;cPoint,oPoint: TPoint) : TPoint;
|
||
Function GetRelativePointbyAngleFloat(angle: Double;cPoint,oPoint: TDoublePoint) : TDoublePoint; //#From Oleg# //12.09.2011
|
||
Procedure ScalePoints(var points:array of TPoint;percentx,percenty: integer; rPoint: TPoint);
|
||
Function GetRelativePointbyscale(percentx,percenty: integer;rPoint,oPoint: TPoint) : TPoint;
|
||
Function GetSymetricPoint(sPoint,lPoint1,lPoint2: TDoublePoint): TDoublePoint;
|
||
Function GetPointOnEllipse(cx,cy,a,b,elpAngle,pAngle:integer):TPoint;
|
||
Procedure GenerateBezierCPoints(p1,p2,p3: TDoublepoint; var cp1,cp2:TDoublepoint; Corner: Boolean);
|
||
|
||
function Get2DPoint(X, Y, Z,dx,dy: Extended): TPoint;
|
||
|
||
Function ReadStringFromStream(Stream:TStream):String;
|
||
Procedure WriteString(Stream:TStream; str:string);
|
||
Procedure WriteStringToStream(Stream:TStream; str:string);
|
||
Procedure WriteField(Code:Byte; Stream:TStream; Const Value; Size: integer);
|
||
Procedure WriteStrField(Code:Byte;Stream:TStream; Const Value:String);
|
||
Procedure WriteBinField(Code:Byte; Stream:TStream; Const Value:pByte; Size: integer);
|
||
Procedure WriteStreamField(Code:Byte; Stream:TStream; Const Value:TStream);
|
||
Procedure StreamToStream(str:TStream; ToStr: TStream; Size:Integer);
|
||
Function StreamEqual(str1,str2:TStream):Boolean;
|
||
|
||
|
||
Procedure StreamToClipBoard(str:TMemoryStream;format:word);
|
||
Procedure ClipBoardToStream(str:TMemoryStream;format:word);
|
||
function RemoveTags(str: String; rtf: Boolean): String;
|
||
Function RemoveBlocks(str:String; s1,s2: String):String;
|
||
Function SplitWebTable(WebText:String; var TableArr: TWebTableArr):Integer;
|
||
|
||
|
||
function LanguageName(Language: TLanguage): String;
|
||
function CharSetFromLocale(Language: TLanguage): TFontCharSet;
|
||
function CodePageFromLocale(Language: TLanguage): Integer;
|
||
function OEMCodePageFromLocale(Language: TLanguage): Integer;
|
||
//function CharToWide(const S: String; CodePage: Word): WideString;
|
||
function CharToWide(const S: AnsiString; CodePage: Word): WideString;
|
||
//function WideToChar(const WS: WideString; CodePage: Word): String;
|
||
function WideToChar(const WS: WideString; CodePage: Word): AnsiString;
|
||
function CharToChar(const S: AnsiString; CP1, CP2: Word): AnsiString;
|
||
//function LengthEx(S: String; CP: Word): Integer;
|
||
function LengthEx(S: AnsiString; CP: Word): Integer;
|
||
procedure getellipseBounds(x,y,a,b,xangle: double;lines: integer; var BoundRect: TDoubleRect);
|
||
Function GetTextureBitmap(Idx:Integer):Graphics.TBitmap;
|
||
|
||
|
||
// Parser Functions
|
||
|
||
Function ParseCommand(Command: String; var StrArray: TStringArray):integer;
|
||
|
||
Procedure GetTokensInLine(statement: string; var tokencount: integer;
|
||
var tokens : TTokenarray);
|
||
Function CheckHeader(statement: string):TStatementType;
|
||
Function CheckStatement(statement: string; var sName: string; var sValue: string ): Boolean;
|
||
Function GetPointFromSource(index: integer; Source: string): TPoint;
|
||
Function GetValFromStrArray(index: integer; Source: string): String;
|
||
Function SplitStr(Line:string; var s:TStringArray; delim:String=','): integer;
|
||
Procedure SplitWebResult(Res:String; var sArr:T2DStringArr;delim:String='=');
|
||
Function ReadTag(tName,tDef:String;var xTags:T2DStringArr):String;
|
||
Procedure WriteTag(tName,tVal:String;var xTags:T2DStringArr);
|
||
Procedure WriteHexStringAsStream(str:String; Stream:TStream);
|
||
Function StreamAsHexString(Stream:TStream):String;
|
||
Procedure ReadTagFromStream(Stream:TStream; var TagArr: T2dStringArr);
|
||
Procedure WriteTagToStream(Stream:TStream; TagArr: T2dStringArr);
|
||
|
||
|
||
// Info Functions
|
||
Function GetAngleofLine(cp,p: TPoint; var reg:integer):integer;
|
||
//Function GetAngleOf2Lines(p11,p12, p21, p22: TDoblePoint):Double;
|
||
Function GetRadOfLine(cp,p: TPoint):Real;overload;
|
||
Function GetRadOfLine(cp,p: TDoublePoint):Real;overload;
|
||
Function GetRadOf2Lines(p1,p2,p3:TDoublePoint):Real;
|
||
Function CoRegOfLine(Rad:Double):Integer;
|
||
Function DirectionOfAngle(rad1,rad2:Double):TMapDirection;
|
||
|
||
|
||
function GetLineLenght(p1,p2: TDoublePoint; Planer:Boolean = True):Real;
|
||
function GetLineLength(p1,p2: TDoublePoint; Planer:Boolean = True):Real;
|
||
|
||
Function GetLineSegmentPoint(p1,p2:TDoublepoint; ratio: double):TDoublePoint;
|
||
Function GetLineFormula(p1,p2: TDoublepoint;var a,b: double):Boolean;
|
||
Function Get90LineFormula(p1,p2: TDoublepoint;var a,b: double):Boolean;
|
||
Procedure PointTo90Line(p1,p2:TDoublePoint; var x,y: Double);
|
||
Procedure PointToLine(p1,p2:TDoublePoint; var x,y: Double);
|
||
Procedure PointToLineByLen(p1,p2:TDoublePoint; var p: TDoublePoint);
|
||
Procedure PointToLineByAngle(p1,p2:TDoublePoint; var p: TDoublePoint);
|
||
Procedure PointToParallelLine(p1,p2:TDoublePoint; var x,y: Double);
|
||
Function PointByDistToLine(p1,p2:TDoublePoint; Dist:Double):TDoublePoint;
|
||
Function PointByDistToLineA(p1,p2:TDoublePoint; Dist,Angle:Double):TDoublePoint;
|
||
Function PointOutToLine(p1,p2,xp:TDoublePoint; Dist:Double):TDoublePoint;
|
||
Function GetDistToLine(p1,p2,p:TDoublePoint):Double;
|
||
Function GetAreaofPGon(p:array of Tpoint; nPoint: integer):real;overload;
|
||
Function GetAreaofPGon(p:TdoublePointArr):real;overload;
|
||
Function GetPerimeterOfCircle(r:double): real;
|
||
Function GetAreaOfCircle(r:double): real;
|
||
Function CreateLinearRgn(p1,p2: TDoublepoint): HRGN;
|
||
Function CreateRotatedRgn(p1: TDoublepoint; w,h:double;rad: double): HRGN;
|
||
Function AngleDist(a1,a2:Double):Double;
|
||
Function SurfaceColor(a,b,c,light:T3DPoint):TColor;overload;
|
||
Function SurfaceColor(Face:T3DPointArray;light:T3DPoint):TColor;overload;
|
||
Function SurfaceColor(a1,a2:TDoublePoint):TColor;overload;
|
||
Function Gray(level:Byte):TColor;
|
||
Function Bluer(level:Byte):TColor;
|
||
Function GetLineNormal(p1,p2:TDoublePoint;dist:Double):TdoublePoint;
|
||
|
||
|
||
Procedure RotateCanvas(Handle:HDC; Ang: Real);
|
||
Procedure FlipCanvas(Handle:HDC; fMode: TFlipMode;delta:double=0);
|
||
Procedure ResetCanvas(Handle:HDC);
|
||
Function RotatePoint(cpoint, opoint: Tpoint; ang: real):TPoint;overload;
|
||
Function RotatePoint(cpoint, opoint: TDoublepoint; ang: real):TDoublePoint;overload;
|
||
Function ScalePoint(cpoint, opoint: TDoublepoint; px,py: real):TDoublePoint;
|
||
//Tolik -- 12/02/2016 --
|
||
// Function RotateDPoint(cpoint, opoint: TDoublepoint; ang: real):TDoublePoint;
|
||
Function RotateDPoint(cpoint, opoint: TDoublepoint; ang: double):TDoublePoint;
|
||
//
|
||
Function DoublePoint(x,y:Double):TDoublePoint;overload;
|
||
Function DoublePoint(pt:Tpoint):TDoublePoint;overload;
|
||
Function DoublePoint(x,y,z:Double):TDoublePoint;overload;
|
||
Function DoublePoint(p:TdoublePoint;z:Double):TDoublePoint;overload;
|
||
Function DP(pt:TPoint):TDoublePoint;
|
||
Procedure SwapPoints(var p1,p2:TDOublePoint);
|
||
Procedure ShrinkLine(var p1,p2:TDoublePoint;d:Double);
|
||
Procedure ExtendLine(var p1,p2:TDoublePoint;d:Double);
|
||
Procedure ShrinkRect(var Rect:TDoubleRect;d:Double);
|
||
Function MPoint(p1,p2:TDoublePoint):TDoublePoint;overload;
|
||
Function MPoint(r:TDoubleRect):TDoublePoint;overload;
|
||
Function MPoint(p1,p2:TDoublePoint;Step:Integer):TDoublePoint;overload;
|
||
Function MPoint(p1,p2:TDoublePoint;Delta:Double;Planer:Boolean = True):TDoublePoint;overload;
|
||
Function PushPoint(p1,p2:TDoublePoint;Delta:Double;var Ended:Boolean):TDoublePoint;
|
||
Function FindGroundPoint(xp1,xp2:TDoublePoint;gLevel: Double):TDoublePoint;
|
||
Function QrPoint(p1,p2:TDoublePoint):TDoublePoint;
|
||
Function MVPoint(p:TDoublePoint;dy:Double):TDoublePoint;
|
||
Function MHPoint(p:TDoublePoint;dx:Double):TDoublePoint;
|
||
Function MovePoint(p:TDoublePoint;dx,dy:Double):TDoublePoint;
|
||
procedure MovePt(p:PDoublePoint;dx,dy:Double);
|
||
Function MovePointTo(p,dp:TDoublePoint;dx,dy:Double):TDoublePoint;
|
||
Function GetRightPointIndex(p1,p2,eye:TDoublePoint):Integer;
|
||
|
||
Procedure DoubleBezier(p1,p2,p3,p4:TDoublePoint;var t: TDoublePointArr; thick: Double);
|
||
Function SubBezier(p0,p1,p2,p3: TDoublePoint; var dPoint,cp1,cp2,cp3,cp4:TDoublePoint; ts:Double):Boolean;overload;
|
||
Function SubBezier(p0,p1,p2,p3: TDoublePoint; var dPoint,cp1,cp2,cp3,cp4:TDoublePoint; ts:Double; bp1,bp2:TDoublepOint):Boolean;overload;
|
||
Procedure GetParallelPoints(p1,p2:TDoublePoint; var np1,np2: TDoublePoint; thick: Double);
|
||
Procedure GetShrinkedPoints(p1,p2:TDoublePoint; var np1,np2: TDoublePoint; thick: Double);
|
||
Procedure OffsetPoint(op,cp:TDoublePoint; var np:TDoublePoint; delta: Double);
|
||
Procedure SortDouble(var SArr:TDoubleArray);
|
||
Procedure SortItems(var SArr:TSortItemArr);
|
||
Procedure SortList(var sList:Tlist; GetValueFunc:TGetValueFunc);overload;
|
||
Procedure SortList(var sList:Tlist; GetValueFunc:TGetValueFuncEx; Data:Pointer);overload;
|
||
|
||
Procedure SortPointsOnLine(p1,p2: TDoublePoint;var pArr:TDoublePointArr);
|
||
Procedure InSertPointToArray(var pArr:TDoublePointArr; index:Integer; p:TDoublePoint);
|
||
Function CheckSelfIntersection(var pArr:TDoublePointArr):Boolean;
|
||
Function CheckLineOnLine(pArr:TDoublePointArr):Boolean;overload;
|
||
Function CheckLineOnLine(p1,p2,p3,p4:TDoublePoint):Boolean;overload;
|
||
Function LinesIntersect(p1,p2,p3,p4:TDoublePoint):Boolean;
|
||
Function GetInterSectionPoint(p1,p2,p3,p4:TDoublePoint; var p:TDoublePoint; extend:Boolean=True;UseTips:Boolean=False): Boolean;
|
||
Function GetLineCircleIntersection(p1,p2,cp:TdoublePoint;radius:Double; var np1,np2: TDoublePoint;var icnt:Integer; extend:Boolean = true):Boolean;
|
||
Function GetLineEllipseIntersection(p1,p2,cp:TdoublePoint;aLen,Blen,Angle:Double; var np1,np2: TDoublePoint;var icnt:Integer; extend:Boolean = true):Boolean;
|
||
Function GetCircleCircleIntersection(cp1:TdoublePoint;rad1:Double;cp2:TdoublePoint;rad2:Double; var np1,np2: TDoublePoint;var icnt: Integer):Boolean;
|
||
Function GetLineBezierIntersection(p1,p2,bp1,bp2,bp3,bp4:TDoublePoint; var pArr:TDoublePointArr;
|
||
var icnt:Integer; extend:Boolean = true):Boolean;
|
||
Function GetClosePoint(cPoint,p1,p2:TDoublePoint):TDoublePoint;
|
||
Function TraceBezier(bp1,bp2,bp3,bp4,tPoint:TDoublePoint; tIndex: Integer; var t1,t2: Double): integer;
|
||
Function GetBezierTime(bp1,bp2,bp3,bp4,dp:TDoublePoint):Double;overload;
|
||
Function GetBezierTime(bp1,bp2,bp3,bp4,p1,p2:TDoublePoint):Double;overload;
|
||
Function DP2P(pt:TDoublepoint):TPoint;overload;
|
||
Function DP2P(ptx,pty:Double):TPoint;overload;
|
||
Function DR2R(x1,y1,x2,y2:Double):Trect;overload;
|
||
Function DR2R(r:TDoubleRect):Trect;overload;
|
||
Function EQDP(p1,p2: TDoublePoint):Boolean;
|
||
Function EQDPZ(p1,p2: TDoublePoint):Boolean;
|
||
Function NormalizePoint(p:TDoublePoint):TDoublePoint;
|
||
Function EQD(a1,a2: Double):Boolean;
|
||
Function Sign(number:Double):Integer;
|
||
Function DoubleRect(Left,Top,Right,Bottom:Double):TDoubleRect;overload;
|
||
Function DoubleRect(iRect:Trect):TDoubleRect;overload;
|
||
Function RectOverlaps(r1,r2:TDoubleRect):Boolean;
|
||
Function BetWeen(x,x1,x2:Double):Boolean;
|
||
Function FaceOverlaps(f1,f2:T3DFace):Boolean;overload;
|
||
Function FaceOverlaps(f1,f2:TDoublePointArr;freg1,freg2:HRGN):Boolean;overload;
|
||
Function Convert3DPoint(p:T3DPoint; YHeight: Double = 0):TDoublePoint;
|
||
Function GetCloserFace(f1,f2:T3DFace;Camera:T3DPoint):Integer;
|
||
Function GetCameraPos(cPoint,oPoint:T3DPoint; HorzAngle,VertAngle:Double):T3DPoint;
|
||
Function Rotate3DPoint(cPOint,oPoint:T3DPoint; Ang:Double;axis:T3DAxis):T3DPoint;
|
||
Function Make5Face(p1,p2,p3,p4,p5:T3DPoint):T3DFace;
|
||
Function Make4Face(p1,p2,p3,p4:T3DPoint):T3DFace;
|
||
Function Make4FaceMar(p1,p2,p3,p4:T3DPoint;Mar:Double):T3DFace;
|
||
Function Make2Face(p1,p2:T3DPoint):T3DFace;
|
||
Function Make3Face(p1,p2,p3:T3DPoint):T3DFace;
|
||
Procedure GetFaceDraw(Face:T3DFace;var pArr:TdoublePointArr);
|
||
Function ConvertIsometricPoint(p:TDoublePoint;h,izalfa:Double;isoType:Byte=0):TDoublePoint;
|
||
Function DeConvertIsometricPoint(p:TDoublePoint;h,izalfa:Double;isoType:Byte=0):TDoublePoint;
|
||
procedure setupPixelFormat(DC:HDC);
|
||
|
||
procedure EllipseToBezier( elpR: TRect;var bzPoints: Array of TPoint);
|
||
//Function GetBezierPolyPoints(var polypoints: array of TPoint;
|
||
//bezPoints: array of TPoint;PointCount:integer;DEngine:Pointer):integer;
|
||
Function GetBezierDistance(p0,p1,p2,p3,p4:TDoublePoint):Real;
|
||
Function GetBezierPatch(p1,p2,p3,p4:TDoublePoint;pWidth: Double;
|
||
var LastIndex: Integer; var pi,pf:TDoublePoint; ToEnd: Boolean;res: Integer):Double;
|
||
Function GetBezierBegin(p1,p2,p3,p4:TDoublePoint;pWidth: Double;res: Integer):TDoublePoint;
|
||
Function GetBezierEnd(p1,p2,p3,p4:TDoublePoint; pWidth: Double;res: Integer):TDoublePoint;
|
||
|
||
Function GetLinePatch(p1,p2:TDoublePoint;pWidth: Double;var cumWidth:Double;
|
||
var pi,pf:TDoublePoint):Double;
|
||
Function GetVectorPenPoints(Style:Integer;var VectorPoints: TList): Integer;
|
||
|
||
Function InputDouble(Caption,Prompt:String; var Value:DOuble):Boolean;
|
||
Function InputInteger(Caption,Prompt:String; var Value:Integer):Boolean;
|
||
Function InputString(Caption,Prompt:String; var Value:String):Boolean;
|
||
Function InputStringEdit(Caption,Prompt:String; var Value:String; px,py:Integer):Boolean;
|
||
Function InputDoubleEdit(Prompt:String; var Value:Double; px,py:Integer):Boolean;
|
||
Function InputIntegerEdit(Prompt:String; var Value:Integer; px,py:Integer):Boolean;
|
||
Function InputMemo(Caption,Prompt:String; var Value:String):Boolean;
|
||
|
||
|
||
Procedure DrawBitmap(fCanvas:TCanvas; Fbitmap:Graphics.TBitmap;x,y: Integer; Enabled:Boolean);
|
||
Function GetPreviewImage(fileName:String): Graphics.TBitmap;
|
||
function GetBmpDPI(bmpName:String): LongInt;overload;
|
||
function GetBmpDPI(bmpStream:TStream): LongInt;overload;
|
||
function GetJpgdpi(filename:String):Integer;
|
||
Function CreateUniqueId:Integer;
|
||
Function OleShiftToDelphiSet(oleState:Integer):TShiftState;
|
||
Function DelphiSetToOleShift(Shift:TShiftState):Integer;
|
||
Function OleCursor(cr:TCursor):Integer;
|
||
function DelphiLoaded : boolean;
|
||
function FolderDialog(Caption: String) : String;
|
||
Procedure RegWrite(IName,IValue:String;Key:String='');overload;
|
||
Procedure RegRead(IName:String; var IValue:String;Key:String='');overload;
|
||
Procedure RegWrite(IName:String;IValue:Integer;Key:String='');overload;
|
||
Procedure RegRead(IName:String; var IValue:Integer;Key:String='');overload;
|
||
Procedure RegWrite(IName:String;IValue:Boolean;Key:String='');overload;
|
||
Procedure RegRead(IName:String; var IValue:Boolean;Key:String='');overload;
|
||
Procedure CloseFace(var Face:T3dFace);
|
||
Procedure MatrixMultiply( cCount: Integer; ml: array of Double; mr : array of Double; var m: array of Double);
|
||
Function RegInReg(inReg,Reg:Integer):Boolean;
|
||
Function MakeFloat(str:String;def:Extended):Extended;
|
||
Function BByte(Value:Boolean):Byte;
|
||
Function BBool(Value:Byte):Boolean;
|
||
function GetColorBetween(StartColor,EndColor: TColor; Pointvalue, Von,Bis : Extended): TColor;
|
||
procedure DrawGradientBox(DC: HDC; const R: TRect; Colors: array of TRGB);
|
||
Procedure MakeGradBitmap(ColorBegin,ColorEnd:TColor;GStyle:TGradStyle;var GradBmp:Graphics.TBitmap);
|
||
Function MakeRgb(r,g,b:Double):TRGB;
|
||
Function DoubleRound(Val:Double; Dec:Integer):Double;
|
||
Function RoundUp(Val:Double):Integer;
|
||
Function AddToFileName(FName,add:String):String;
|
||
function RegisterAssociation(const aExeName, aFileExt, aFileDesc,aFileIcon: string): Boolean;
|
||
procedure GetVerInfo(forModule: tHandle; var V1, V2, V3, V4: Word);
|
||
Function Like(s1,s2:String):Boolean;
|
||
Function GetPointsDist(Points:TDoublePOintArr):Double;
|
||
Function ByteToHexStr(val:Byte):String;
|
||
Function HexStrToByte(val:String):Byte;
|
||
Function GetHexVal(str:String):Byte;
|
||
function SaveAsExcelFile(AGrid: TStringGrid; ASheetName, AFileName: string): Boolean;
|
||
procedure PrintGrid(sGrid: TStringGrid; sTitle: string);
|
||
Function Obeb(a,b:Integer):Integer;
|
||
Function InttoStrL(val:integer; sCount:Integer):String;
|
||
Function LeadStr(val:String; sCount:Integer):String;
|
||
Function FormatSqlDate(xDate:Integer):Integer;
|
||
Function FirstWords(Str:String; cnt:Integer):String;
|
||
Procedure DrawTraceText(x,y:Integer;Color:TColor;Text,FontName:String;
|
||
FontSize:Integer;Canvas:TCanvas);
|
||
Function GetHatchStyle(brStyle: Byte):THatchStyle;
|
||
Function GetFillType(brStyle: Byte):TFillType;
|
||
Function GetGradStyle(brStyle: Byte):TGradStyle;
|
||
Function GetTextureStyle(brStyle: Byte):TTextureStyle;
|
||
|
||
function GetAreaFromPolygon(APolygon: TDoublePointArr): Double;
|
||
function GetLineLength3D(p1, p2: T3DPoint): Double;
|
||
//function GetLineLength3D(p1, p2: PDoublePoint): Double; overload;
|
||
function GetTriangleArea3D(p1, p2, p3: T3DPoint): Double;
|
||
function IsPointNear(APointX, ApointY, ANearX, ANearY: Double): Boolean; //#From Oleg# //05.10.2010
|
||
function Intersect(p1,p2,p3,p4:TDoublePoint):Boolean;
|
||
|
||
procedure DeletePointFromArray(var Arr: TDoublePointArr; Index: Integer);
|
||
|
||
var FigureClasses:TList;
|
||
FigureClassesSL: TStringList; //01.11.2011
|
||
OSVersion: TOSVersionInfo;
|
||
GlobalZ: Double=0;
|
||
CompSign :Double= 5298467.0876;
|
||
TextureBmp: Graphics.TBitmap;
|
||
GrayedColor: TColor = clSilver; //03.08.2012 - <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
|
||
|
||
|
||
Const bsHorzGrad = 9;
|
||
Const bsVertGrad = 10;
|
||
Const bsRadGrad = 11;
|
||
Const bsDiagFGrad = 12;
|
||
Const bsDiagBGrad = 13;
|
||
Const bsMirrorGrad = 14;
|
||
Const bstxtNewsPrint = 15;
|
||
Const bstxtStationery = 16;
|
||
Const bstxtWhiteMarble = 17;
|
||
Const bstxtWovenMat = 18;
|
||
Const bstxtPaperBag = 19;
|
||
Const bstxtMediumWood = 20;
|
||
Const bsExHatch = 21;
|
||
Const bsExGrad = 22;
|
||
Const bsExTexture = 23;
|
||
|
||
|
||
|
||
|
||
|
||
implementation
|
||
|
||
{$R fill.RES}
|
||
|
||
(* ========================================================================== *)
|
||
|
||
// UTILITY IMPLEMENTATION //
|
||
|
||
(* ========================================================================== *)
|
||
|
||
|
||
Procedure GetTokensInLine(statement: string; var tokencount: integer;
|
||
var tokens : TTokenarray);
|
||
var token : string;
|
||
ch : string[1];
|
||
tab : boolean;
|
||
len : integer;
|
||
a: Integer;
|
||
begin
|
||
len := length(statement);
|
||
tab := true;
|
||
token := '';
|
||
tokencount := 0;
|
||
for a := 1 to Len do
|
||
begin
|
||
ch := copy(statement,a,1);
|
||
if ch = ' ' then
|
||
begin
|
||
if not tab then
|
||
begin
|
||
tokencount := tokencount+1;
|
||
tokens[tokencount-1] := token;
|
||
token := '';
|
||
end;
|
||
end
|
||
else if ch = '''' then
|
||
begin
|
||
token := copy(statement,a+1,len-a);
|
||
tokencount := tokencount+1;
|
||
tokens[tokencount-1] := token;
|
||
token := '';
|
||
exit;
|
||
end
|
||
else
|
||
begin
|
||
tab := false;
|
||
token := token + ch;
|
||
end;
|
||
end;
|
||
if token<> '' then begin
|
||
tokencount := tokencount+1;
|
||
tokens[tokencount-1] := token;
|
||
end;
|
||
end;
|
||
|
||
Function CheckStatement(statement: string; var sName: string; var sValue: string ): Boolean;
|
||
var tokencount: integer;
|
||
tokens: TTokenArray;
|
||
Begin
|
||
GetTokensInLine(statement,tokencount,tokens);
|
||
result := false;
|
||
if tokencount = 3 then
|
||
begin
|
||
if tokens[1] <> '=' then
|
||
begin
|
||
result := false;
|
||
end
|
||
else
|
||
begin
|
||
result := true;
|
||
sName := tokens[0];
|
||
sValue := tokens[2];
|
||
end;
|
||
end;
|
||
End;
|
||
|
||
Function CheckHeader(statement: string):TStatementType;
|
||
var tokencount: integer;
|
||
tokens: TTokenArray;
|
||
sType : TStatementType;
|
||
Begin
|
||
GetTokensInLine(statement,tokencount,tokens);
|
||
if tokencount = 1 then
|
||
begin
|
||
if tokens[0]= 'DocBegin' then sType := stDocBegin
|
||
else if tokens[0]= 'LayerBegin' then sType := stLayerBegin
|
||
else if tokens[0]= 'BlockBegin' then sType := stBlockBegin
|
||
else if tokens[0]= 'FigureBegin' then sType := stFigureBegin
|
||
else if tokens[0]= 'InFigureBegin' then sType := stInFigureBegin
|
||
else if tokens[0]= 'DocEnd' then sType := stDocEnd
|
||
else if tokens[0]= 'LayerEnd' then sType := stLayerEnd
|
||
else if tokens[0]= 'BlockEnd' then sType := stBlockEnd
|
||
else if tokens[0]= 'FigureEnd' then sType := stFigureEnd
|
||
else if tokens[0]= 'InFigureEnd' then sType := stInFigureEnd
|
||
else if tokens[0]= 'TablesBegin' then sType := stTablesBegin
|
||
else if tokens[0]= 'TablesEnd' then sType := stTablesEnd
|
||
else sType := stUndefined;
|
||
end
|
||
else sType := stUndefined;
|
||
result := sType;
|
||
end;
|
||
|
||
Function GetValFromStrArray(index: integer; Source: string): String;
|
||
var a,len: integer;
|
||
vals: string;
|
||
vcnt: integer;
|
||
begin
|
||
len := Length(Source);
|
||
Source := Copy(Source,2,len-2);
|
||
vals := '';
|
||
vcnt := 0;
|
||
For a := 1 to len do begin
|
||
if Copy(source,a,1) <> ',' then begin
|
||
vals := vals + Copy(source,a,1);
|
||
end
|
||
else begin
|
||
vcnt := vcnt+1;
|
||
if vcnt = index then begin
|
||
result := vals;
|
||
exit;
|
||
end;
|
||
vals := '';
|
||
end;
|
||
end;
|
||
if (vcnt = index -1) and (vals <> '') then result := vals;
|
||
end;
|
||
|
||
Function GetPointFromSource(index: integer; Source: string): TPoint;
|
||
var len,count,start,a,b: integer;
|
||
xstr,ystr,pstr: string;
|
||
Opened,Closed : Boolean;
|
||
ch : string[1];
|
||
second : boolean;
|
||
Begin
|
||
len := length(source);
|
||
xstr := '';
|
||
ystr := '';
|
||
Opened := false; closed := TRUE; second := false;
|
||
start := -1;
|
||
count := 0;
|
||
For a := 1 to len do
|
||
begin
|
||
ch := copy(source,a,1);
|
||
if ch = '[' then begin
|
||
if closed then
|
||
begin
|
||
opened := true;
|
||
start := a;
|
||
end
|
||
else
|
||
begin
|
||
// error
|
||
end;
|
||
end;
|
||
if ch = ']' then
|
||
begin
|
||
if opened then
|
||
begin
|
||
closed := true;
|
||
count := count +1;
|
||
if count = index then
|
||
begin
|
||
pstr := copy(source,start+1, a -1 -start);
|
||
for b := 1 to length(pstr) do
|
||
begin
|
||
ch := copy(pstr,b,1);
|
||
if ch = ',' then
|
||
begin
|
||
second := true;
|
||
end
|
||
else
|
||
if not second then xstr := xstr+ ch else ystr := ystr + ch;
|
||
end;
|
||
end;
|
||
end
|
||
else
|
||
begin
|
||
// error
|
||
end;
|
||
end;
|
||
end;
|
||
try
|
||
result := Point(strtoInt(xstr),strtoInt(ystr));
|
||
except
|
||
end;
|
||
end;
|
||
|
||
|
||
Function readInt(ptr: pointer; index: integer): Pint;
|
||
begin
|
||
result := pInt(pchar(ptr)+ (index -1)*sizeof(integer));
|
||
end;
|
||
|
||
function Get2DPoint(X, Y, Z,dx,dy: Extended): TPoint;
|
||
var
|
||
ratio: extended;
|
||
begin
|
||
ratio := 30;
|
||
Result := Point(Round(dx + Ratio * (X - Y * 1/sqrt(2))),
|
||
Round(dy + Ratio * (-Z + y *1/sqrt(2))));
|
||
end;
|
||
|
||
Procedure SplitWebResult(Res:String; var sArr:T2DStringArr;delim:String='=');
|
||
var sList: TStringList;
|
||
i: Integer;
|
||
sx:TStringArray;
|
||
begin
|
||
Res := StringReplace(Res,'<br>',#13,[rfReplaceAll,rfIgnoreCase]);
|
||
sList := TstringList.Create;
|
||
sList.Text := Res;
|
||
SetLength(sArr,0);
|
||
for i := 0 to sList.Count-1 do
|
||
begin
|
||
SetLength(sArr,i+1);
|
||
SplitStr(sList[i],sx,delim);
|
||
sArr[i,0] := '';
|
||
sArr[i,1] := '';
|
||
if Length(sx) > 0 then sArr[i,0] := sx[0];
|
||
if Length(sx) > 1 then sArr[i,1] := sx[1];
|
||
end;
|
||
sList.Free;
|
||
end;
|
||
|
||
Function ReadTag(tName,tDef:String;var xTags:T2DStringArr):String;
|
||
var i: Integer;
|
||
begin
|
||
result := tDef;
|
||
for i := 0 to Length(xTags)-1 do
|
||
begin
|
||
if lowercase(xTags[i,0]) = lowercase(tName) then
|
||
begin
|
||
result := Trim(xTags[i,1]);
|
||
break;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
Procedure WriteTag(tName,tVal:String;var xTags:T2DStringArr);
|
||
var i,Len: Integer;
|
||
found: Boolean;
|
||
begin
|
||
found := false;
|
||
for i := 0 to Length(xTags)-1 do
|
||
begin
|
||
if lowercase(xTags[i,0]) = lowercase(tName) then
|
||
begin
|
||
xTags[i,1] := tVal;
|
||
found := true;
|
||
break;
|
||
end;
|
||
end;
|
||
if not found then
|
||
begin
|
||
Len := Length(xTags);
|
||
SetLength(xTags,Len+1);
|
||
xTags[Len,0] := tName;
|
||
xTags[Len,1] := tVal;
|
||
end;
|
||
end;
|
||
|
||
Procedure WriteHexStringAsStream(str:String; Stream:TStream);
|
||
var sText: String;
|
||
p:Integer;
|
||
len: Integer;
|
||
mStream: TMemoryStream;
|
||
hStr: String;
|
||
val: Byte;
|
||
i:Integer;
|
||
begin
|
||
if str <> '' then begin
|
||
sText := str;
|
||
len := Length(sText) div 2;
|
||
for i := 1 to len do begin
|
||
hStr := Copy(sText,(i-1)*2+1,2);
|
||
val := HexStrToByte(hStr);
|
||
Stream.Write(val,1);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
Function StreamAsHexString(Stream:TStream):String;
|
||
var by:Byte;
|
||
begin
|
||
result := '';
|
||
Stream.Position := 0;
|
||
repeat
|
||
Stream.Read(by,1);
|
||
result := result+ ByteToHexStr(by);
|
||
until (Stream.Position >= Stream.Size);
|
||
end;
|
||
|
||
|
||
procedure ReadTagFromStream(Stream: TStream;
|
||
var TagArr: T2dStringArr);
|
||
var done: Boolean;
|
||
xTag: String;
|
||
xVal: String;
|
||
len: Integer;
|
||
isTag: Boolean;
|
||
xPos: Integer;
|
||
begin
|
||
done := false;
|
||
len := 0;
|
||
SetLength(TagArr,0);
|
||
isTag := False;
|
||
xPos := Stream.Position;
|
||
xtag := ReadstringfromStream(Stream);
|
||
if xTag <> '<TAG>' then begin
|
||
Stream.Position := xPos;
|
||
exit;
|
||
end;
|
||
Stream.Position := xPos;
|
||
repeat
|
||
xtag := ReadstringfromStream(Stream);
|
||
if xtag = '<TAG>' then begin
|
||
end else if xTag = '<TAGEND>' then begin
|
||
done := True;
|
||
end else begin
|
||
isTag := not isTag;
|
||
if isTag then begin
|
||
Len := Len+1;
|
||
SetLength(TagArr,Len);
|
||
TagArr[Len-1,0] := xTag;
|
||
end else begin
|
||
TagArr[Len-1,1] := xTag;
|
||
end;
|
||
end;
|
||
until done or (Stream.Position >= Stream.Size);
|
||
end;
|
||
|
||
procedure WriteTagToStream(Stream: TStream; TagArr: T2dStringArr);
|
||
var xTagArr:T2dStringArr;
|
||
DataStream: TMemoryStream;
|
||
Len,i: Integer;
|
||
begin
|
||
{$ifndef viewer}
|
||
Len := Length(TagArr);
|
||
Stream.Position := 0;
|
||
ReadTagFromStream(Stream,xTagArr);
|
||
DataStream := TMemoryStream.Create;
|
||
StreamToStream(Stream,DataStream,Stream.Size-Stream.Position);
|
||
DataStream.Position := 0;
|
||
Stream.Size := 0;
|
||
Stream.Position := 0;
|
||
|
||
WriteStringToStream(Stream,'<TAG>');
|
||
for i := 0 to Len-1 do begin
|
||
WriteStringToStream(Stream,TagArr[i,0]);
|
||
WriteStringToStream(Stream,TagArr[i,1]);
|
||
end;
|
||
WriteStringToStream(Stream,'<TAGEND>');
|
||
StreamToStream(DataStream,Stream,DataStream.Size);
|
||
DataStream.Free;
|
||
Stream.Position := 0;
|
||
{$endif viewer}
|
||
end;
|
||
|
||
|
||
Function SplitStr(Line: string; var s: TStringArray; delim: String = ','): Integer;
|
||
var
|
||
a, sIdx: integer;
|
||
temp: string;
|
||
begin
|
||
Line := StringReplace(Line, #13, ' ', [rfReplaceAll]);
|
||
Line := StringReplace(Line, #$D#$A, ' ', [rfReplaceAll]);
|
||
delim := delim[1];
|
||
try
|
||
sIdx := 0;
|
||
temp := '';
|
||
for a := 1 to Length(Line) do
|
||
begin
|
||
if Copy(line,a, 1) <> delim then
|
||
begin
|
||
temp := temp + Copy(line, a, 1);
|
||
end
|
||
else
|
||
begin
|
||
SetLength(s,sIdx + 1);
|
||
s[sIdx] := temp;
|
||
sIdx := sIdx + 1;
|
||
temp := '';
|
||
end;
|
||
end;
|
||
if temp <> '' then
|
||
begin
|
||
SetLength(s, sIdx + 1);
|
||
s[sIdx] := temp;
|
||
sIdx := sIdx + 1;
|
||
end;
|
||
if Copy(Line, Length(Line), 1) = delim then
|
||
begin
|
||
SetLength(s, sIdx + 1);
|
||
s[sIdx] := '';
|
||
sIdx := sIdx + 1;
|
||
end;
|
||
result := sIdx;
|
||
except
|
||
result := 0;
|
||
end;
|
||
end;
|
||
|
||
Function getRelativePointbyAngle(angle: integer;cPoint,oPoint: TPoint) : TPoint;
|
||
var rad,angD, angO, angN, newY, newX: extended;
|
||
p : TPoint;
|
||
begin
|
||
(*
|
||
angle := angle *-1;
|
||
oPoint := Point (oPoint.x-cpoint.x,oPoint.y-cPoint.y);
|
||
angD := (pi/180)*(angle/10);
|
||
p.y := round(oPoint.x * sin(angD) + oPoint.y*cos(angD));
|
||
p.x := round(oPoint.x * cos(angD) - oPoint.y*sin(angD));
|
||
p := Point(p.x+cpoint.x,p.y+cpoint.y);
|
||
result := p;
|
||
exit;
|
||
*)
|
||
//Get Radius
|
||
try
|
||
rad := sqrt(sqr(oPoint.y - cPoint.y)+sqr(oPoint.x - cPoint.x));
|
||
except
|
||
rad := 0;
|
||
end;
|
||
//Get Or<4F>g<EFBFBD>nal Angle
|
||
If oPoint.y = cPoint.y then
|
||
begin
|
||
if cpoint.x > oPoint.x then angO := Pi else angO := 0;
|
||
end
|
||
else if oPoint.x = cPoint.x then
|
||
begin
|
||
if cPoint.y > oPoint.y then angO := -1*(Pi/2) else angO := (Pi/2);
|
||
end
|
||
else
|
||
begin
|
||
angO := ArcTan(abs(oPoint.y - cPoint.y)/abs(oPoint.x - cPoint.x));
|
||
if (oPoint.x > cPoint.x) and (oPoint.y > cPoint.y) then angO := angO
|
||
else if (oPoint.x < cPoint.x) and (oPoint.y > cPoint.y) then angO := pi - angO
|
||
else if (oPoint.x < cPoint.x) and (oPoint.y < cPoint.y) then angO := pi + angO
|
||
else if (oPoint.x > cPoint.x) and (oPoint.y < cPoint.y) then angO := (2*Pi) - angO;
|
||
end;
|
||
// Covert delta angle to Radyan
|
||
angD := (pi/180)*(angle/10);
|
||
// New Angle
|
||
angN := angO - angD;
|
||
|
||
// new coords
|
||
newx := rad * cos (angN);
|
||
newy := rad * sin (angN);
|
||
|
||
p.x := cPoint.x + round(newx); p.y := cPoint.y + round(newy);
|
||
result := p;
|
||
end;
|
||
|
||
Function GetRelativePointbyAngleFloat(angle: Double;cPoint,oPoint: TDoublePoint): TDoublePoint;
|
||
var rad,angD, angO, angN, newY, newX: extended;
|
||
p : TDoublePoint;
|
||
begin
|
||
//Get Radius
|
||
try
|
||
rad := sqrt(sqr(oPoint.y - cPoint.y)+sqr(oPoint.x - cPoint.x));
|
||
except
|
||
rad := 0;
|
||
end;
|
||
//Get Or<4F>g<EFBFBD>nal Angle
|
||
If oPoint.y = cPoint.y then
|
||
begin
|
||
if cpoint.x > oPoint.x then angO := Pi else angO := 0;
|
||
end
|
||
else if oPoint.x = cPoint.x then
|
||
begin
|
||
if cPoint.y > oPoint.y then
|
||
angO := -1*(Pi/2)
|
||
else
|
||
angO := (Pi/2);
|
||
end
|
||
else
|
||
begin
|
||
angO := ArcTan(abs(oPoint.y - cPoint.y)/abs(oPoint.x - cPoint.x));
|
||
if (oPoint.x > cPoint.x) and (oPoint.y > cPoint.y) then
|
||
angO := angO
|
||
else if (oPoint.x < cPoint.x) and (oPoint.y > cPoint.y) then
|
||
angO := pi - angO
|
||
else if (oPoint.x < cPoint.x) and (oPoint.y < cPoint.y) then
|
||
angO := pi + angO
|
||
else if (oPoint.x > cPoint.x) and (oPoint.y < cPoint.y) then
|
||
angO := (2*Pi) - angO;
|
||
end;
|
||
// Covert delta angle to Radyan
|
||
angD := (pi/180)*(angle);
|
||
// New Angle
|
||
angN := angO - angD;
|
||
|
||
// new coords
|
||
newx := rad * cos (angN);
|
||
newy := rad * sin (angN);
|
||
|
||
p.x := cPoint.x + {round(}newx{)};
|
||
p.y := cPoint.y + {round(}newy{)};
|
||
result := p;
|
||
end;
|
||
|
||
Procedure ScalePoints(var points:array of TPoint;percentx,percenty: integer; rPoint: TPoint);
|
||
var i: Integer;
|
||
begin
|
||
for i := low(points) to High(Points) do
|
||
begin
|
||
points[i] := GetRelativePointbyScale(percentx,percenty,rPoint,points[i]);
|
||
end;
|
||
end;
|
||
|
||
Function getRelativePointbyscale(percentx,percenty: integer; rPoint,oPoint: TPoint) : TPoint;
|
||
var respoint: TPoint;
|
||
deltax,deltay : extended;
|
||
begin
|
||
if percentx = 100 then begin
|
||
respoint.x := oPoint.x;
|
||
end else begin
|
||
deltax := rPoint.x - oPoint.x;
|
||
deltax := deltax * (percentx/100);
|
||
respoint.x := rpoint.x - round(deltax);
|
||
end;
|
||
|
||
if percenty = 100 then begin
|
||
respoint.y := oPoint.y;
|
||
end else begin
|
||
deltay := rPoint.y - oPoint.y;
|
||
deltay := deltay * (percenty/100);
|
||
if percenty = 100 then deltay := 0;
|
||
respoint.y := rpoint.y - round(deltay);
|
||
end;
|
||
result := respoint;
|
||
end;
|
||
|
||
Procedure GenerateBezierCPoints(p1,p2,p3: TDoublepoint;
|
||
var cp1,cp2:TDoublepoint; Corner: Boolean);
|
||
var na1,na2,a1,a2,a3,a4,ra: double;
|
||
r1,r2:Integer;
|
||
l1,l2: integer;
|
||
mp1,mp3 : TDoublePoint;
|
||
pia: Double;
|
||
begin
|
||
l1 := -1; l2 := 1;
|
||
//a1 := GetAngleOfLine(DP2P(p2),DP2P(p1),r1);
|
||
//a2 := GetAngleOfLine(DP2P(p2),DP2P(p3),r2);
|
||
a1 := GetRadOfLine(p2,p1);
|
||
a2 := GetRadOfLine(p2,p3);
|
||
a3 := abs(a2-a1);
|
||
if a3 > (pi) then a4 := (2*pi) -a3 else a4 := a3;
|
||
ra := (pi-a4) /2;
|
||
|
||
mp1 := DoublePoint((p1.x+p2.x) / 2, (p1.y+p2.y) / 2);
|
||
mp3 := DoublePoint((p3.x+p2.x) / 2, (p3.y+p2.y) / 2);
|
||
mp1 := DoublePoint((mp1.x+p2.x) / 2, (mp1.y+p2.y) / 2);
|
||
mp3 := DoublePoint((mp3.x+p2.x) / 2, (mp3.y+p2.y) / 2);
|
||
|
||
//think positive
|
||
na1 := a1+ra; na2 := a2-ra;
|
||
pia := abs(na1-na2) - (pi);
|
||
if corner then ra := 2*ra;
|
||
if (pia < 0.0001) and (pia > -0.0001) then
|
||
begin
|
||
cp1 := rotatepoint(p2,mp1,ra);
|
||
cp2 := rotatepoint(p2,mp3,-1*ra);
|
||
end else begin
|
||
cp1 := rotatepoint(p2,mp1,-1*ra);
|
||
cp2 := rotatepoint(p2,mp3,ra);
|
||
end;
|
||
(*
|
||
//exit;
|
||
//ra := (1800-a4) / 2;
|
||
|
||
if [r1,r2] = [1,2] then if r1 = 1 then begin l1 := 1; l2 := -1 end else begin l1 := -1; l2 := 1;end;
|
||
if [r1,r2] = [2,3] then if r1 = 2 then begin l1 := 1; l2 := -1 end else begin l1 := -1; l2 := 1;end;
|
||
if [r1,r2] = [3,4] then if r1 = 3 then begin l1 := 1; l2 := -1 end else begin l1 := -1; l2 := 1;end;
|
||
if [r1,r2] = [4,1] then if r1 = 4 then begin l1 := 1; l2 := -1 end else begin l1 := -1; l2 := 1;end;
|
||
if [r1,r2] = [3,1] then begin
|
||
if r1 = 1 then begin
|
||
if a2-1800 > a1 then l1 := -1 else l1 := 1;
|
||
end else begin
|
||
if a2 > a1-1800 then l1 := -1 else l1 := 1;
|
||
end;
|
||
l2 := l1*-1;
|
||
end;
|
||
if [r1,r2] = [2,4] then begin
|
||
if r1 = 2 then begin
|
||
if a2-2700 > a1-900 then l1 := -1 else l1 := 1;
|
||
end else begin
|
||
if 3600-a1 > a2-900 then l1 := -1 else l1 := 1;
|
||
end;
|
||
l2 := l1*-1;
|
||
end;
|
||
if (r1 = r2) then if a2 > a1 then begin l1 := 1; l2 := -1 end else begin l1 := -1; l2 := 1;end;
|
||
|
||
|
||
|
||
mp1 := DoublePoint((p1.x+p2.x) / 2, (p1.y+p2.y) / 2);
|
||
mp3 := DoublePoint((p3.x+p2.x) / 2, (p3.y+p2.y) / 2);
|
||
mp1 := DoublePoint((mp1.x+p2.x) / 2, (mp1.y+p2.y) / 2);
|
||
mp3 := DoublePoint((mp3.x+p2.x) / 2, (mp3.y+p2.y) / 2);
|
||
cp1 := DoublePoint(getRelativePointbyAngle(round(l1*ra),DP2P(p2),DP2P(mp1)));
|
||
cp2 := DoublePoint(getRelativePointbyAngle(round(l2*ra),DP2P(p2),DP2P(mp3)));
|
||
*)
|
||
end;
|
||
|
||
Function IspointInBezier(p1,p2,p3,p4,point:TDoublepoint):boolean;
|
||
var x,y: Double;
|
||
a: integer;
|
||
ctrl: real;
|
||
tx,px,py : real;
|
||
t : array[1..4] of real;
|
||
mcol,mrow: integer;
|
||
pntx,pnty: array[1..4] of Double;
|
||
begin
|
||
result := false;
|
||
|
||
x := point.x;
|
||
y := point.y;
|
||
pntx[1] := p1.x;
|
||
pntx[2] := p2.x;
|
||
pntx[3] := p3.x;
|
||
pntx[4] := p4.x;
|
||
pnty[1] := p1.y;
|
||
pnty[2] := p2.y;
|
||
pnty[3] := p3.y;
|
||
pnty[4] := p4.y;
|
||
|
||
for a := 0 to 500 do
|
||
begin
|
||
tx := a / 500;
|
||
t[1] := tx*tx*tx;
|
||
t[2] := tx*tx;
|
||
t[3] := tx;
|
||
t[4] := 1;
|
||
px := 0;
|
||
py := 0;
|
||
|
||
for mcol := 1 to 4 do begin
|
||
for mrow := 1 to 4 do begin
|
||
px := px + mval[mrow,mcol]* t[mrow]*pntx[mcol];
|
||
py := py + mval[mrow,mcol]* t[mrow]*pnty[mcol];
|
||
end;
|
||
end;
|
||
if (abs(px - x) <= 0.3) and (abs(py - y) <= 0.3) then
|
||
begin
|
||
result := true;
|
||
exit;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
Procedure BeziersToPolyline(bpoints:TDoublePointArr;var pPoints:TDoublePointArr; PatchLen:Double);
|
||
var i,pCnt,cnt,lCnt: Integer;
|
||
p1,p2,p3,p4: TdoublePoint;
|
||
begin
|
||
i := 0;
|
||
pCnt:= Length(bPoints);
|
||
if pCnt < 4 then exit;
|
||
repeat
|
||
p1 := bPoints[i];
|
||
p2 := bPoints[i+1];
|
||
p3 := bPoints[i+2];
|
||
p4 := bPoints[i+3];
|
||
|
||
if EQDP(p1,p2) and EQDP(p3,p4) then begin
|
||
if i = 0 then cnt := 2 else cnt := 1;
|
||
lCnt := Length(pPoints);
|
||
SetLength(pPoints,lCnt+cnt);
|
||
if i = 0 then pPoints[lCnt+cnt-2] := p1;
|
||
pPoints[lCnt+cnt-1] := p4;
|
||
end else
|
||
BezierToPolyline(p1,p2,p3,p4,pPoints,PatchLen,i=0);
|
||
i := i+3;
|
||
until i >= pCnt-1;
|
||
end;
|
||
|
||
Procedure BezierToPolyline(p1,p2,p3,p4:TDoublePoint;var pPoints:TDoublePointArr; PatchLen:Double;incFirst:Boolean);
|
||
var LastIndex,res:Integer;
|
||
rDist:Double;
|
||
xCnt,pCnt,bCnt: Integer;
|
||
pi,pf: TdoublePOint;
|
||
begin
|
||
res := 500;
|
||
LastIndex := 0;
|
||
xCnt := 0;
|
||
pCnt := 0;
|
||
repeat
|
||
rDist := GetBezierPatch(p1,p2,p3,p4,PatchLen,LastIndex,pi,pf,false,res);
|
||
pCnt := pCnt +1;
|
||
Until LastIndex = res;
|
||
|
||
if (pCnt > 1) and (rDist < (PatchLen * 0.9)) then
|
||
begin
|
||
pCnt := pCnt -1;
|
||
if rDist < (PatchLen / 2) then begin
|
||
PatchLen := PatchLen + round(rDist/pCnt);
|
||
end else begin
|
||
PatchLen := ((PatchLen * pCnt)+rDist) / (pcnt+1);
|
||
pCnt := pCnt+1;
|
||
end;
|
||
end;
|
||
|
||
LastIndex := 0;
|
||
xCnt := 0;
|
||
bCnt := Length(pPoints);
|
||
repeat
|
||
xCnt := xCnt +1;
|
||
if xCnt = pCnt then
|
||
rDist := GetBezierPatch(p1,p2,p3,p4,PatchLen,LastIndex,pi,pf,True,res)
|
||
else
|
||
rDist := GetBezierPatch(p1,p2,p3,p4,PatchLen,LastIndex,pi,pf,False,res);
|
||
if (xCnt = 1) and incFirst then begin
|
||
bCnt := bCnt+1;
|
||
SetLength(pPoints,bCnt);
|
||
pPoints[bCnt-1] := pi;
|
||
end;
|
||
bCnt := bCnt+1;
|
||
SetLength(pPoints,bCnt);
|
||
pPoints[bCnt-1] := pf;
|
||
Until LastIndex = res;
|
||
|
||
end;
|
||
|
||
|
||
Function GetBezierSample(p1,p2,p3,p4:TDoublepoint;tx:Double):TDoublePoint;overload;
|
||
var x,y,a: integer;
|
||
ctrl: real;
|
||
px,py : real;
|
||
t : array[1..4] of real;
|
||
mcol,mrow: integer;
|
||
pntx,pnty: array[1..4] of Double;
|
||
begin
|
||
result := DoublePoint(0,0);
|
||
if (tx < 0) or (tx > 1) then exit;
|
||
pntx[1] := p1.x;
|
||
pntx[2] := p2.x;
|
||
pntx[3] := p3.x;
|
||
pntx[4] := p4.x;
|
||
pnty[1] := p1.y;
|
||
pnty[2] := p2.y;
|
||
pnty[3] := p3.y;
|
||
pnty[4] := p4.y;
|
||
t[1] := tx*tx*tx;
|
||
t[2] := tx*tx;
|
||
t[3] := tx;
|
||
t[4] := 1;
|
||
px := 0;
|
||
py := 0;
|
||
for mcol := 1 to 4 do begin
|
||
for mrow := 1 to 4 do begin
|
||
px := px + mval[mrow,mcol]* t[mrow]*pntx[mcol];
|
||
py := py + mval[mrow,mcol]* t[mrow]*pnty[mcol];
|
||
end;
|
||
end;
|
||
Result := DoublePoint(px,py);
|
||
end;
|
||
|
||
Function GetBezierSample(p1,p2,p3,p4:TDoublepoint;Index,Resolution:Integer):TDoublePoint;
|
||
begin
|
||
result := GetBezierSample(p1,p2,p3,p4,Index/Resolution);
|
||
end;
|
||
|
||
Function IspointInPolyBezier(Points:TdoublePointArr; Point:TDoublepoint):boolean;
|
||
var I: integer;
|
||
p1,p2,p3,p4:TDoublePoint;
|
||
nbrPoint: Integer;
|
||
begin
|
||
nbrPoint := Length(Points);
|
||
result := false;
|
||
if nbrPoint < 4 then exit;
|
||
I := 0;
|
||
repeat
|
||
p1 := Points[i];
|
||
p2 := Points[i+1];
|
||
p3 := Points[i+2];
|
||
p4 := Points[i+3];
|
||
I := I+3;
|
||
result := IspointInBezier(p1,p2,p3,p4,Point);
|
||
until (I >= nbrPoint-1) or result;
|
||
end;
|
||
|
||
Function IspointInCircle(x,y,cx,cy,radius:Double):Boolean;
|
||
var a,b,nx,ny: real;
|
||
ctrl: real;
|
||
begin
|
||
result := false;
|
||
a := radius;
|
||
b := radius;
|
||
nx := x-cx;
|
||
ny := y-cy;
|
||
if (a = 0) or (b=0) then exit;
|
||
ctrl := ((nx*nx)/(a*a))+((ny*ny)/(b*b));
|
||
if (ctrl < 1.1) and (ctrl > 0.9) then result := true;
|
||
end;
|
||
|
||
Function IspointInEllipse(x,y,cx,cy,alen,blen,angle:Double):Boolean;
|
||
var
|
||
ctrl,nx,ny: real;
|
||
p2,pt,pc : TDoublePoint;
|
||
begin
|
||
pt.x := x; pt.y := y;
|
||
p2 := RotatePoint(DoublePoint(cx,cy),pt,-1*angle);
|
||
nx := p2.x - cx;
|
||
ny := p2.y - cy;
|
||
if alen*blen = 0 then
|
||
begin
|
||
result := false;
|
||
exit;
|
||
end;
|
||
ctrl := ((nx*nx)/(alen*alen))+((ny*ny)/(blen*blen));
|
||
if (ctrl < 1.1) and (ctrl > 0.9) then result := true;
|
||
end;
|
||
|
||
Function IspointInArc(hp,cp:TDoublePoint;rad: Double;arcstyle:Integer;a1,a2:Double):Boolean;
|
||
var cnt,cntA,I :Integer;
|
||
Points: T2DPointArray;
|
||
P: TDoublePointArr;
|
||
begin
|
||
if a1 = a2 then begin
|
||
result := isPointInCircle(hp.x,hp.y,cp.x,cp.y,rad);
|
||
exit;
|
||
end;
|
||
BezierArcPoints(Points,cp.x,cp.y,Rad,a1,a2);
|
||
cnt := Length(Points);
|
||
cntA := 0;
|
||
if arcStyle = 1 then cntA := 6
|
||
else if ArcStyle = 2 then cntA := 3;
|
||
SetLength(p,cnt+cntA);
|
||
for I := 0 to cnt-1 do
|
||
begin
|
||
P[I] := DoublePoint(Points[I].X,Points[I].Y);
|
||
end;
|
||
if arcStyle = 1 then begin
|
||
P[cnt-1+1] := P[cnt-1];
|
||
P[cnt-1+2] := DoublePoint(cp.x,cp.y);
|
||
P[cnt-1+3] := DoublePoint(cp.x,cp.y);
|
||
P[cnt-1+4] := DoublePoint(cp.x,cp.y);
|
||
P[cnt-1+5] := P[0];
|
||
P[cnt-1+6] := P[0];
|
||
cntA := 6;
|
||
end else if ArcStyle = 2 then begin
|
||
P[cnt-1+1] := P[cnt-1];
|
||
P[cnt-1+2] := P[0];
|
||
P[cnt-1+3] := P[0];
|
||
cntA := 3;
|
||
end;
|
||
result := IsPointInPolyBezier(P,hp);
|
||
//Tolik 21/05/2018
|
||
SetLength(p, 0);
|
||
SetLength(Points, 0);
|
||
//
|
||
end;
|
||
|
||
Function IspointInArc(hp,cp:TDoublePoint;rad: Double;arcstyle:Integer;ap1,ap2:TDoublepoint;inverted:Boolean):Boolean;
|
||
var cnt,cntA,I :Integer;
|
||
Points: T2DPointArray;
|
||
P: TDoublePointArr;
|
||
a1,a2: Double;
|
||
begin
|
||
if Inverted then begin
|
||
a1 := GetRadOfLine(cp,ap1);
|
||
a2 := GetRadOfLine(cp,ap2);
|
||
end else begin
|
||
a1 := GetRadOfLine(cp,ap2);
|
||
a2 := GetRadOfLine(cp,ap1);
|
||
end;
|
||
result := IspointInArc(hp,cp,rad,arcStyle,a1,a2);
|
||
end;
|
||
|
||
|
||
Function GetArcCenter(p1,p2:TDoublepoint;Angle:Double):TDoublePoint;
|
||
var mp,cp:TDoublepoint;
|
||
rad: Double;
|
||
mx,my: Double;
|
||
t : double;
|
||
begin
|
||
mp := DoublePoint( (p1.x+p2.x) / 2, (p1.y+p2.y) / 2);
|
||
if abs(angle - pi) < 0.001 then
|
||
begin
|
||
result := mp;
|
||
exit;
|
||
end;
|
||
rad := GetRadOfLine(p1,mp);
|
||
mp := RotatePoint(p1,mp,-rad);
|
||
mx := GetLineLenght(p1,mp);
|
||
t := tan(angle/2);
|
||
if t<> 0 then my := mx/t else my := 0;
|
||
cp := DoublePoint(p1.x+mx,p1.y-my);
|
||
cp := RotatePoint(p1,cp,rad);
|
||
result := cp;
|
||
end;
|
||
|
||
Procedure DoubleArcToPolyGon(cx,cy,rad1,rad2,a1,a2,a3,a4:Double; var p:TdoublePointArr);
|
||
var bPoints: TdoublePointArr;
|
||
begin
|
||
GetDoubleArcPoints(cx,cy,rad1,rad2,a1,a2,a3,a4,bPoints);
|
||
BeziersToPolyLine(bPoints,p,3);
|
||
//Tolik 21/05/2018 --
|
||
SetLength(bPoints, 0);
|
||
//
|
||
end;
|
||
|
||
Procedure GetDoubleArcPoints(cx,cy,rad1,rad2,a1,a2,a3,a4:Double; var p:TdoublePointArr);
|
||
var Points: T2DPointArray;
|
||
I,a: integer;
|
||
cnt,pcnt : integer;
|
||
r: Integer;
|
||
x,y: Double;
|
||
begin
|
||
BezierArcPoints(Points,cx,cy,Rad1,a1,a2);
|
||
cnt := Length(Points);
|
||
SetLength(p,cnt);
|
||
for I := 0 to cnt-1 do
|
||
begin
|
||
P[I].X := Points[I].X;
|
||
P[I].Y := Points[I].Y;
|
||
end;
|
||
|
||
BezierArcPoints(Points,cx,cy,Rad2,a3,a4);
|
||
pcnt := Length(Points);
|
||
|
||
SetLength(p,cnt+2);
|
||
|
||
P[Cnt-2+2] := P[Cnt-1];
|
||
P[Cnt-1+2] := DoublePoint(Points[pcnt-1].x,Points[pcnt-1].y);
|
||
|
||
|
||
cnt := cnt+2;
|
||
|
||
SetLength(p,cnt+pcnt);
|
||
for I := 0 to pcnt-1 do
|
||
begin
|
||
P[cnt+I].X := Points[pcnt-1-I].X;
|
||
P[cnt+I].Y := Points[pcnt-1-I].Y;
|
||
end;
|
||
|
||
cnt := cnt+pCnt;
|
||
|
||
SetLength(p,cnt+3);
|
||
|
||
P[Cnt-3+3] := P[Cnt-1];
|
||
P[Cnt-2+3] := P[0];
|
||
P[Cnt-1+3] := P[0];
|
||
cnt := cnt+3;
|
||
// Tolik --21/05/2018 --
|
||
SetLength(Points, 0);
|
||
//
|
||
end;
|
||
|
||
|
||
Procedure GetArcBounds(p1:TDoublePoint; rad1,rad2: Double; arcStyle: Integer;
|
||
a1,a2,a: Double; var figMaxX,figMaxY,figMinX,figMinY: double);
|
||
var cnt,cntA,I :Integer;
|
||
Points: T2DPointArray;
|
||
P: TDoublePointArr;
|
||
begin
|
||
if a1 = a2 then
|
||
begin
|
||
figMaxX := p1.x+rad1;
|
||
figMinX := p1.x-rad1;
|
||
figMaxY := p1.y+rad2;
|
||
figMinY := p1.y-rad2;
|
||
//exit;
|
||
end;
|
||
|
||
BezierElpArcPoints(Points,p1.x,p1.y,Rad1,rad2,a,a1,a2);
|
||
cnt := Length(Points);
|
||
if cnt = 0 then exit;
|
||
cntA := 0;
|
||
if arcStyle = 1 then cntA := 6
|
||
else if ArcStyle = 2 then cntA := 3;
|
||
SetLength(p,cnt+cntA);
|
||
|
||
for I := 0 to cnt-1 do
|
||
begin
|
||
P[I] := DoublePoint(Points[I].X,Points[I].Y);
|
||
end;
|
||
if arcStyle = 1 then begin
|
||
P[cnt-1+1] := P[cnt-1];
|
||
P[cnt-1+2] := DoublePoint(p1.x,p1.y);
|
||
P[cnt-1+3] := DoublePoint(p1.x,p1.y);
|
||
P[cnt-1+4] := DoublePoint(p1.x,p1.y);
|
||
P[cnt-1+5] := P[0];
|
||
P[cnt-1+6] := P[0];
|
||
cntA := 6;
|
||
end else if ArcStyle = 2 then begin
|
||
P[cnt-1+1] := P[cnt-1];
|
||
P[cnt-1+2] := P[0];
|
||
P[cnt-1+3] := P[0];
|
||
cntA := 3;
|
||
end;
|
||
GetPolyBezierBounds(P,figMaxX,figMaxY,figMinX,figMinY);
|
||
// Tolik --21/05/2018 --
|
||
SetLength(Points, 0);
|
||
SetLength(P, 0);
|
||
//
|
||
end;
|
||
|
||
Procedure GetPolyBezierBounds(Points:TdoublePointArr;var figMaxX,figMaxY,figMinX,figMinY: Double);
|
||
var I,nbrPoint: integer;
|
||
p1,p2,p3,p4:TDoublePoint;
|
||
bMaxX,bMaxY,bMinX,bMinY:double;
|
||
begin
|
||
I := 0;
|
||
nbrPoint := Length(Points);
|
||
figMaxX := Points[0].x;
|
||
figMinX := Points[0].x;
|
||
figMaxY := Points[0].y;
|
||
figMinY := Points[0].y;
|
||
|
||
repeat
|
||
p1 := Points[i];
|
||
p2 := Points[i+1];
|
||
p3 := Points[i+2];
|
||
p4 := Points[i+3];
|
||
I := I+3;
|
||
GetBezierBounds(p1,p2,p3,p4,bMaxX,bMaxY,bMinX,bMinY);
|
||
if bMaxX > figMaxX then figMaxX := bMaxX;
|
||
if bMinX < figMinX then figMinX := bMinX;
|
||
if bMaxY > figMaxY then figMaxY := bMaxY;
|
||
if bMinY < figMinY then figMinY := bMinY;
|
||
until I >= nbrPoint-1;
|
||
|
||
end;
|
||
|
||
Procedure GetPolylineBounds(Points:TDoublePointArr;var figMaxX,figMaxY,figMinX,figMinY: double);
|
||
var i: INteger;
|
||
pt: TDoublePOint;
|
||
begin
|
||
if Length(Points) = 0 then exit;
|
||
figMaxX := points[0].x;
|
||
figMinX := points[0].x;
|
||
figMaxY := points[0].y;
|
||
figMinY := points[0].y;
|
||
for i := 1 to Length(Points)-1 do
|
||
begin
|
||
pt := Points[i];
|
||
if pt.x > FigMaxX then FigMaxX := pt.x;
|
||
if pt.x < FigMinX then FigMinX := pt.x;
|
||
if pt.y > FigMaxY then FigMaxY := pt.y;
|
||
if pt.y < FigMinY then FigMinY := pt.y;
|
||
end;
|
||
|
||
end;
|
||
|
||
Procedure GetBezierBounds(p1,p2,p3,p4:TDoublePoint;var figMaxX,figMaxY,figMinX,figMinY: double);
|
||
var a: integer;
|
||
ctrl: real;
|
||
tx,px,py : real;
|
||
t : array[1..4] of real;
|
||
mcol,mrow: integer;
|
||
pntx,pnty: array[1..4] of double;
|
||
|
||
begin
|
||
pntx[1] := p1.x;
|
||
pntx[2] := p2.x;
|
||
pntx[3] := p3.x;
|
||
pntx[4] := p4.x;
|
||
pnty[1] := p1.y;
|
||
pnty[2] := p2.y;
|
||
pnty[3] := p3.y;
|
||
pnty[4] := p4.y;
|
||
|
||
|
||
figMaxX := pntx[1];
|
||
figMinX := pntx[1];
|
||
figMaxY := pnty[1];
|
||
figMinY := pnty[1];
|
||
|
||
for a := 0 to 500 do
|
||
begin
|
||
tx := a / 500;
|
||
t[1] := tx*tx*tx;
|
||
t[2] := tx*tx;
|
||
t[3] := tx;
|
||
t[4] := 1;
|
||
px := 0;
|
||
py := 0;
|
||
for mcol := 1 to 4 do begin
|
||
for mrow := 1 to 4 do begin
|
||
px := px + mval[mrow,mcol]* t[mrow]*pntx[mcol];
|
||
py := py + mval[mrow,mcol]* t[mrow]*pnty[mcol];
|
||
end;
|
||
end;
|
||
if px > figMaxX then figMaxX := px;
|
||
if px < figMinX then figMinX := px;
|
||
if py > figMaxY then figMaxY := py;
|
||
if py < figMinY then figMinY := py;
|
||
end;
|
||
end;
|
||
|
||
Procedure PutSign(canvas:Tcanvas;point:Tpoint);
|
||
begin
|
||
canvas.rectangle(point.x-4,point.y-4,point.x+4,point.y+4);
|
||
end;
|
||
|
||
|
||
procedure EllipseToBezier( elpR: TRect;var bzPoints: Array of TPoint);
|
||
var
|
||
offsetx,offsety: integer;
|
||
Center: TPoint;
|
||
const EToBConst = 0.2761423749154;
|
||
begin
|
||
offsetx := round(abs(elpR.left-elpR.right) * EToBConst);
|
||
offsety := round(abs(elpR.top-elpR.bottom) * EToBConst);
|
||
Center := Point( (elpR.left+elpR.right) div 2,(elpR.top+elpR.bottom) div 2);
|
||
|
||
bzPoints[0].x := elpR.left;
|
||
bzPoints[1].x := bzPoints[0].x;
|
||
bzPoints[11].x := bzPoints[0].x;
|
||
bzPoints[12].x := bzPoints[0].x;
|
||
|
||
bzPoints[5].x := elpR.right;
|
||
bzPoints[6].x := bzPoints[5].x;
|
||
bzPoints[7].x := bzPoints[5].x;
|
||
|
||
bzPoints[2].x := Center.x - offsetx;
|
||
bzPoints[10].x := Center.x - offsetx;
|
||
|
||
bzPoints[4].x := Center.x + offsetx;
|
||
bzPoints[8].x := Center.x + offsetx;
|
||
|
||
bzPoints[3].x := Center.x;
|
||
bzPoints[9].x := Center.x;
|
||
|
||
bzPoints[2].y := elpR.top;
|
||
bzPoints[3].y := elpR.top;
|
||
bzPoints[4].y := elpR.top;
|
||
|
||
bzPoints[8].y := elpR.bottom;
|
||
bzPoints[9].y := elpR.bottom;
|
||
bzPoints[10].y := elpR.bottom;
|
||
|
||
bzPoints[7].y := Center.y + offsety;
|
||
bzPoints[11].y := Center.y + offsety;
|
||
|
||
bzPoints[1].y := Center.y - offsety;
|
||
bzPoints[5].y := Center.y - offsety;
|
||
|
||
bzPoints[0].y := Center.y;
|
||
bzPoints[6].y := Center.y;
|
||
bzPoints[12].y := Center.y;
|
||
|
||
end;
|
||
|
||
|
||
Function GetPointOnEllipse(cx,cy,a,b,elpAngle,pAngle:integer):TPoint;
|
||
var res: TPoint;
|
||
tanangle,m,angle: real;
|
||
sa,sb: extended;
|
||
top : extended;
|
||
bot: extended;
|
||
xs,xr: extended;
|
||
Begin
|
||
if (pangle = 0) or (pangle = 3600) then
|
||
begin
|
||
res.x := cx + a;
|
||
res.y := cy;
|
||
end
|
||
else if pangle = 900 then
|
||
begin
|
||
res.x := cx;
|
||
res.y := cy + b;
|
||
end
|
||
else if pangle = 1800 then
|
||
begin
|
||
res.x := cx - a;
|
||
res.y := cy;
|
||
end
|
||
else if pangle = 2700 then
|
||
begin
|
||
res.x := cx;
|
||
res.y := cy - b;
|
||
end
|
||
else
|
||
begin
|
||
angle := (pangle / 1800) *PI;
|
||
tanAngle := tan (angle);
|
||
m := sqr(tanangle);
|
||
sa := (a * a)/1000; sb := (b * b)/1000;
|
||
top := sa * sb;
|
||
bot := (sb + (sa*m))/(1000*1000);
|
||
xs := top/bot;
|
||
xr := sqrt(xs);
|
||
res.x := round(xr);
|
||
res.y := round(tanAngle*xr);
|
||
res.x := res.x + cx;
|
||
res.y := res.y + cy;
|
||
end;
|
||
if elpangle <> 0 then
|
||
result := getRelativePointbyAngle(elpAngle,Point(cx,cy),res)
|
||
else
|
||
result := res;
|
||
end;
|
||
|
||
Function GetSymetricPoint(sPoint,lPoint1,lPoint2: TDoublePoint): TDoublePoint;
|
||
var ResPoint : TDoublePoint;
|
||
resx, resy,mLine1,mLine2,a1,a2,b1,b2,c1,c2,interX,interY : Double;
|
||
begin
|
||
if lpoint2.x = lpoint1.x then
|
||
begin
|
||
resY := sPoint.y;
|
||
resX := lPoint1.x + (lPoint1.x - sPoint.x);
|
||
end
|
||
else if lpoint2.y = lpoint1.y then
|
||
begin
|
||
resX := sPoint.x;
|
||
resY := lPoint1.y + (lPoint1.y - sPoint.y);
|
||
end
|
||
else
|
||
begin
|
||
// ax + by + c = 0
|
||
|
||
mLine1 := ((lpoint1.y-lpoint2.y) / (lpoint1.x-lpoint2.x));
|
||
|
||
|
||
a1 := -1* mLine1;
|
||
b1 := 1;
|
||
c1 := mLine1*lPoint1.x - lPoint1.y;
|
||
|
||
mline2 := -1 / mLine1;
|
||
|
||
a2 := -1* mLine2;
|
||
b2 := 1;
|
||
c2 := mLine2*sPoint.x - sPoint.y;
|
||
|
||
interX := (c2*b1 - c1*b2) / (a1*b2 - b1*a2);
|
||
interY := (c1*a2 - a1*c2) / (a1*b2 - b1*a2);
|
||
|
||
// distance to Line1 of sPoint
|
||
//h := abs(a1*sPoint.x + b1*sPoint.y + c1) / sqrt(a1*a1+b1*b1);
|
||
|
||
resX := 2*InterX - sPoint.x;
|
||
resY := 2*InterY - sPoint.Y;
|
||
|
||
end;
|
||
|
||
resPoint.x := resX;
|
||
resPoint.y := resY;
|
||
|
||
result := resPoint;
|
||
|
||
end;
|
||
|
||
Function AngleDist(a1,a2:Double):Double;
|
||
begin
|
||
if a2 > a1 then
|
||
result := a2-a1
|
||
else if a2 < a1 then begin
|
||
result := (2*pi-a1)+a2;
|
||
end else if a2 = a1 then begin
|
||
result := 0;
|
||
end;
|
||
end;
|
||
|
||
Function Gray(level:Byte):TColor;
|
||
begin
|
||
Result := RGB(level,level,level);
|
||
end;
|
||
|
||
Function Bluer(level:Byte):TColor;
|
||
begin
|
||
Result := RGB(0,0,level);
|
||
end;
|
||
|
||
Function SurfaceColor(a1,a2:TDoublePoint):TColor;
|
||
var dp: TdoublePoint;
|
||
rad: double;
|
||
begin
|
||
dp := MPoint(a1,a2);
|
||
rad := GetRadOfLine(dp,DoublePoint(0,0));
|
||
if rad < 0 then rad := (2*pi)+rad;
|
||
if rad > (pi/4) then begin
|
||
rad := rad- (Trunc(rad / (pi/4))*(pi/4));
|
||
end;
|
||
result := Gray(100+Round(60*(rad / (pi/4))));
|
||
end;
|
||
|
||
Function SurfaceColor(Face:T3DPointArray;light:T3DPoint):TColor;
|
||
var pCnt: Integer;
|
||
i: Integer;
|
||
dp: TdoublePoint;
|
||
rad: double;
|
||
begin
|
||
result := clSilver;
|
||
pCnt := Length(Face);
|
||
if pcnt = 4 then begin
|
||
if (Face[0].z = Face[1].z) and (Face[0].z = Face[2].z) and(Face[0].z = Face[3].z) then
|
||
begin
|
||
result := Gray(60+Round(60*(Face[0].z /60)));
|
||
end else begin
|
||
dP := Mpoint(DoublePoint(Face[0].x,Face[0].y),DoublePoint(Face[1].x,Face[1].y));
|
||
rad := GetRadOfLine(dp,DoublePoint(light.x,light.y));
|
||
if rad < 0 then rad := (2*pi)+rad;
|
||
if rad > (pi/4) then begin
|
||
rad := rad- (Trunc(rad / (pi/4))*(pi/4));
|
||
end;
|
||
result := Gray(100+Round(60*(rad / (pi/4))));
|
||
end;
|
||
end else if pcnt = 3 then begin
|
||
if (Face[0].z = Face[1].z) and (Face[0].z = Face[2].z) then
|
||
begin
|
||
result := Gray(100+Round(60*(Face[0].z /250)));
|
||
end else begin
|
||
dP := Mpoint(DoublePoint(Face[0].x,Face[0].y),DoublePoint(Face[1].x,Face[1].y));
|
||
rad := GetRadOfLine(dp,DoublePoint(light.x,light.y));
|
||
if rad < 0 then rad := (2*pi)+rad;
|
||
if rad > (pi/4) then begin
|
||
rad := rad- (Trunc(rad / (pi/4))*(pi/4));
|
||
end;
|
||
result := Gray(100+Round(60*(rad / (pi/4))));
|
||
end;
|
||
|
||
|
||
end;
|
||
end;
|
||
|
||
Function SurfaceColor(a,b,c,light:T3DPoint):TColor;
|
||
var
|
||
Center,toA,toL: T3DPoint;
|
||
Cos,Angle: Double;
|
||
grayLevel: Integer;
|
||
Function IMUL(x1,x2:Double):Double;
|
||
begin
|
||
result := x1*x2;
|
||
end;
|
||
Function Delta(p1,p2:T3DPoint):T3DPoint;
|
||
begin
|
||
result := DoublePOint((p1.x-p2.x),(p1.y-p2.y),(p1.z-p2.z));
|
||
end;
|
||
Function InnerProduct(p1,p2:T3DPoint):Double;
|
||
begin
|
||
result := IMUL(p1.x,p2.x)+IMUL(p1.y,p2.y)+IMUL(p1.z,p2.z);
|
||
end;
|
||
begin
|
||
Center := DoublePoint((a.x+b.x+c.x) / 3,
|
||
(a.y+b.y+c.y) / 3,
|
||
(a.z+b.z+c.z) / 3);
|
||
ToA := delta(A,Center);
|
||
ToL := Delta(Center,light);
|
||
Try
|
||
Cos := InnerProduct(ToA,ToL) /
|
||
( Sqrt(InnerProduct(ToA,ToA))*
|
||
Sqrt(InnerProduct(ToL,ToL))
|
||
);
|
||
try
|
||
Angle := ArcTan(sqrt(1-Sqr(Cos))/Cos);
|
||
except
|
||
Angle := pi/2;
|
||
end;
|
||
GrayLevel := 255 - Round(255*(Abs(Angle)/ (pi/2)));
|
||
except
|
||
GrayLevel := 255;
|
||
end;
|
||
Result := PaletteRgb(GrayLevel,GrayLevel,GrayLevel);
|
||
|
||
end;
|
||
|
||
Function DirectionOfAngle(rad1,rad2:Double):TMapDirection;
|
||
var da: Double;
|
||
r1,r2: Integer;
|
||
begin
|
||
if rad1 > rad2 then da := rad1-rad2 else da := rad1 + ((2*pi)-rad2);
|
||
if da < pi then begin
|
||
r1 := CoRegOfLine(Rad1);
|
||
r2 := CoRegOfLine(Rad2);
|
||
end else begin
|
||
r1 := CoRegOfLine(Rad2);
|
||
r2 := CoRegOfLine(Rad1);
|
||
end;
|
||
if (r1 = 1) and (r2 = 4) then
|
||
result := mdEast
|
||
else if (r1 = 1) and (r2 = 1) then
|
||
result := mdSouthEast
|
||
else if (r1 = 2) and (r2 = 1) then
|
||
result := mdSouth
|
||
else if (r1 = 2) and (r2=2) then
|
||
result := mdSouthWest
|
||
else if (r1=3) and (r2 = 2) then
|
||
result := mdWest
|
||
else if (r1 = 3) and (r2 =3) then
|
||
result := mdNorthWest
|
||
else if (r1 = 4) and (r2 =3) then
|
||
result := mdNorth
|
||
else if (r1 = 4) and (r2=4) then
|
||
result := mdNorthEast;
|
||
end;
|
||
|
||
Function CoRegOfLine(Rad:Double):Integer;
|
||
begin
|
||
if (rad >= 0) and (rad < (pi/2)) then
|
||
result := 1
|
||
else if (rad >= (pi/2)) and (rad < pi) then
|
||
result := 2
|
||
else if (rad >= pi) and (rad < (3*(pi/2))) then
|
||
result := 3
|
||
else result := 4;
|
||
end;
|
||
|
||
Function GetRadOf2Lines(p1,p2,p3:TDoublePoint):Real;
|
||
var rad1,rad2: Double;
|
||
begin
|
||
rad1 := GetRadOfLine(p1,p2);
|
||
rad2 := GetRadOfLine(p3,p2);
|
||
result := rad2-rad1;
|
||
end;
|
||
|
||
// Tolik 26/04/2019 - - <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> - <20><>. <20><><EFBFBD><EFBFBD>
|
||
Function GetRadOfLine(cp,p: TDoublePoint):Real;overload;
|
||
var //dx,dy: Real;
|
||
dx,dy: Extended;
|
||
ang: real;
|
||
reg: integer;
|
||
rx, ry : Double;
|
||
Begin
|
||
result := 0;
|
||
try
|
||
// dx := RoundTo( abs(p.x - cp.x), -3);
|
||
// dy := RoundTo( abs(p.y - cp.y), -3);
|
||
GetPrecisionMode;
|
||
//Tolik 23/08/2019 --
|
||
//SetPrecisionMode(pmDouble);
|
||
GetRoundMode;
|
||
//
|
||
rx := p.x - cp.x;
|
||
ry := p.y - cp.y;
|
||
rx := Abs(rx);
|
||
ry := Abs(ry);
|
||
dx := RoundTo(rx, -3);
|
||
dy := RoundTo(ry, -3);
|
||
except
|
||
try
|
||
//dx := RoundTo( abs(p.x - cp.x), -3);
|
||
//dy := RoundTo( abs(p.y - cp.y), -3);
|
||
rx := p.x - cp.x;
|
||
ry := p.y - cp.y;
|
||
rx := Abs(rx);
|
||
ry := Abs(ry);
|
||
dx := RoundTo(rx, -3);
|
||
dy := RoundTo(ry, -3);
|
||
except
|
||
end;
|
||
end;
|
||
if (dx=0) and (dy=0) then // error
|
||
begin
|
||
//result := 0;
|
||
exit;
|
||
end;
|
||
if dx = 0 then
|
||
begin
|
||
if p.y > cp.y then result := pi/2
|
||
else result := pi*1.5;
|
||
end
|
||
else if dy = 0 then
|
||
begin
|
||
if p.x > cp.x then result := 0
|
||
else result := pi;
|
||
end
|
||
else
|
||
begin
|
||
ang := arctan(dy/dx);
|
||
if (p.x > cp.x) and (p.y > cp.y) then begin
|
||
ang := ang; reg := 1; end
|
||
else if (p.x < cp.x) and (p.y > cp.y) then begin
|
||
ang := PI - ang; reg := 2; end
|
||
else if (p.x < cp.x) and (p.y < cp.y) then begin
|
||
ang := PI + ang; reg := 3; end
|
||
else if (p.x > cp.x) and (p.y < cp.y) then begin
|
||
ang := 2*PI - ang; reg := 4; end;
|
||
|
||
Result := ang;
|
||
end;
|
||
end;
|
||
{
|
||
Function GetRadOfLine(cp,p: TDoublePoint):Real;overload;
|
||
var dx,dy: Real;
|
||
ang: real;
|
||
reg:integer;
|
||
Begin
|
||
try
|
||
dx := RoundTo( abs(p.x - cp.x), -3);
|
||
dy := RoundTo( abs(p.y - cp.y), -3);
|
||
except
|
||
try
|
||
dx := RoundTo( abs(p.x - cp.x), -3);
|
||
dy := RoundTo( abs(p.y - cp.y), -3);
|
||
except
|
||
end;
|
||
end;
|
||
if (dx=0) and (dy=0) then // error
|
||
begin
|
||
result := 0;
|
||
exit;
|
||
end;
|
||
if dx = 0 then
|
||
begin
|
||
if p.y > cp.y then result := pi/2
|
||
else result := pi*1.5;
|
||
end
|
||
else if dy = 0 then
|
||
begin
|
||
if p.x > cp.x then result := 0
|
||
else result := pi;
|
||
end
|
||
else
|
||
begin
|
||
ang := arctan(dy/dx);
|
||
if (p.x > cp.x) and (p.y > cp.y) then begin
|
||
ang := ang; reg := 1; end
|
||
else if (p.x < cp.x) and (p.y > cp.y) then begin
|
||
ang := PI - ang; reg := 2; end
|
||
else if (p.x < cp.x) and (p.y < cp.y) then begin
|
||
ang := PI + ang; reg := 3; end
|
||
else if (p.x > cp.x) and (p.y < cp.y) then begin
|
||
ang := 2*PI - ang; reg := 4; end;
|
||
|
||
Result := ang;
|
||
end;
|
||
end;
|
||
}
|
||
Function GetRadOfLine(cp,p: TPoint):Real;
|
||
var dx,dy: integer;
|
||
ang: real;
|
||
reg:integer;
|
||
Begin
|
||
|
||
dx := abs(p.x - cp.x);
|
||
dy := abs(p.y - cp.y);
|
||
|
||
if (dx=0) and (dy=0) then // error
|
||
begin
|
||
result := 0;
|
||
exit;
|
||
end;
|
||
if dx = 0 then
|
||
begin
|
||
if p.y > cp.y then result := pi/2
|
||
else result := pi*1.5;
|
||
end
|
||
else if dy = 0 then
|
||
begin
|
||
if p.x > cp.x then result := 0
|
||
else result := pi;
|
||
end
|
||
else
|
||
begin
|
||
ang := arctan(dy/dx);
|
||
if (p.x > cp.x) and (p.y > cp.y) then begin
|
||
ang := ang; reg := 1; end
|
||
else if (p.x < cp.x) and (p.y > cp.y) then begin
|
||
ang := PI - ang; reg := 2; end
|
||
else if (p.x < cp.x) and (p.y < cp.y) then begin
|
||
ang := PI + ang; reg := 3; end
|
||
else if (p.x > cp.x) and (p.y < cp.y) then begin
|
||
ang := 2*PI - ang; reg := 4; end;
|
||
|
||
Result := ang;
|
||
end;
|
||
|
||
|
||
end;
|
||
|
||
Function GetAngleofLine(cp,p: TPoint; var reg:integer):integer;
|
||
var dx,dy: integer;
|
||
ang: real;
|
||
Begin
|
||
|
||
dx := abs(p.x - cp.x);
|
||
dy := abs(p.y - cp.y);
|
||
|
||
if (dx=0) and (dy=0) then // error
|
||
begin
|
||
result := 0;
|
||
exit;
|
||
end;
|
||
if dx = 0 then
|
||
begin
|
||
if p.y > cp.y then result := 900
|
||
else result := 2700;
|
||
end
|
||
else if dy = 0 then
|
||
begin
|
||
if p.x > cp.x then result := 0
|
||
else result := 1800;
|
||
end
|
||
else
|
||
begin
|
||
ang := arctan(dy/dx);
|
||
if (p.x > cp.x) and (p.y > cp.y) then begin
|
||
ang := ang; reg := 1; end
|
||
else if (p.x < cp.x) and (p.y > cp.y) then begin
|
||
ang := PI - ang; reg := 2; end
|
||
else if (p.x < cp.x) and (p.y < cp.y) then begin
|
||
ang := PI + ang; reg := 3; end
|
||
else if (p.x > cp.x) and (p.y < cp.y) then begin
|
||
ang := 2*PI - ang; reg := 4; end;
|
||
|
||
Result := round((ang/PI)*1800);
|
||
end;
|
||
|
||
End;
|
||
|
||
{Function GetAngleOf2Lines(p11,p12, p21, p22: TDoblePoint):Double;
|
||
var
|
||
p1, p2, cp: PDoublePoint;
|
||
begin
|
||
|
||
end;}
|
||
|
||
Function GetLineFormula(p1,p2: TDoublepoint;var a,b: double):Boolean;
|
||
var x1,x2,y1,y2: double;
|
||
t1,t2: double;
|
||
begin
|
||
result := true;
|
||
p1 := NormalizePoint(p1);
|
||
p2 := NormalizePoint(p2);
|
||
if EQDP(p1,p2) then begin
|
||
a:= 0;
|
||
b:= 0;
|
||
result := false;
|
||
exit;
|
||
end;
|
||
// y = ax+b
|
||
x1 := p1.x;
|
||
x2 := p2.x;
|
||
y1 := p1.y;
|
||
y2 := p2.y;
|
||
|
||
if EQD(y1 ,y2) then begin
|
||
a := 0; b := y1;
|
||
end else if EQD(x1 ,x2) then begin
|
||
a := 0; b := 0;
|
||
end else begin
|
||
t1 := y1/x1;
|
||
t2 := y2/x2;
|
||
b := (t1-t2) / ((x2-x1)/(x1*x2));
|
||
a := (y1-b)/x1;
|
||
if eqd(y1,b) then a := 0;
|
||
end;
|
||
end;
|
||
|
||
Function Get90LineFormula(p1,p2: TDoublepoint;var a,b: double):Boolean;
|
||
var x1,x2,y1,y2: double;
|
||
t1,t2: double;
|
||
ml,m90: double;
|
||
mp: TDoublePoint;
|
||
begin
|
||
result := true;
|
||
if (p1.x = p2.x) and (p1.y = p2.y) then begin
|
||
result := false;
|
||
exit;
|
||
end;
|
||
GetLineFormula(p1,p2,a,b);
|
||
mp := DoublePoint((p1.x+p2.x) / 2, (p1.y+p2.y) / 2);
|
||
if (a=0) and (b=0) then begin
|
||
a := 0; b := mp.y;
|
||
end else if (a=0) then begin
|
||
a := 0; b := 0;
|
||
end else begin
|
||
// for x 10 & 20
|
||
x1 := 10;
|
||
y1 := a*x1+b;
|
||
x2 := 20;
|
||
y2 := a*x2+b;
|
||
ml := (y2-y1)/(x2-x1);
|
||
m90 := -1/ml;
|
||
a := m90;
|
||
b := mp.y-(a*mp.x);
|
||
end;
|
||
|
||
end;
|
||
|
||
Function GetDistToLine(p1,p2,p:TDoublePoint):Double;
|
||
var d1,d2: Double;
|
||
mp: TDoublePoint;
|
||
begin
|
||
mp := DoublePoint(p.x,p.y);
|
||
PointToLine(p1,p2,mp.x,mp.y);
|
||
if isPointInLine(p1,p2,mp,1) then begin
|
||
result := GetLineLenght(mp,p);
|
||
end else begin
|
||
d1 := GetLineLenght(p1,p);
|
||
d2 := GetLineLenght(p2,p);
|
||
result := Min(d1,d2);
|
||
end;
|
||
|
||
|
||
end;
|
||
|
||
Procedure PointToLineByLen(p1,p2:TDoublePoint; var p: TDoublePoint);
|
||
var len,ol: Double;
|
||
begin
|
||
Len := GetLineLength(p1,p);
|
||
ol := GetLineLength(p1,p2);
|
||
if Len > ol then begin
|
||
p := Mpoint(p2,p1,ol-Len);
|
||
end else begin
|
||
p := Mpoint(p1,p2,Len);
|
||
end;
|
||
end;
|
||
|
||
Procedure PointToLineByAngle(p1,p2:TDoublePoint; var p: TDoublePoint);
|
||
var angle,dx,len,ol: Double;
|
||
begin
|
||
len := GetLineLength(p1,p);
|
||
ol := GetLineLength(p1,p2);
|
||
angle := GetRadOf2Lines(p,p1,p2);
|
||
dx := len*Cos(angle);
|
||
if dx > ol then begin
|
||
p := Mpoint(p2,p1,ol-dx);
|
||
end else begin
|
||
p := Mpoint(p1,p2,dx);
|
||
end;
|
||
end;
|
||
|
||
Procedure PointToLine(p1,p2: TDoublePoint; var x,y: Double);
|
||
var mx,my: Double;
|
||
p,px,py,mp: TDoublePoint;
|
||
lx,ly,dx,dy: Double;
|
||
a,b: Double;
|
||
rad: Double;
|
||
begin
|
||
// y = ax+b
|
||
// x = (b-y)/a
|
||
if isPointinLine(p1,p2,DoublePoint(x,y),1,0.1) then exit;
|
||
if GetLineFormula(p1,p2,a,b) then
|
||
begin
|
||
if (a = 0) and (b = 0) then
|
||
begin
|
||
mx := p1.x;
|
||
x := mx;
|
||
end else begin
|
||
if a = 0 then
|
||
begin
|
||
my := b;
|
||
y := my;
|
||
end else
|
||
begin
|
||
mx := (y-b)/a;
|
||
my := a*x+b;
|
||
px := DoublePoint(mx,y);
|
||
py := DoublePoint(x,my);
|
||
p := DoublePoint(x,y);
|
||
lx := GetLineLenght(px,p);
|
||
ly := GetLineLenght(py,p);
|
||
if p1.y < p2.y then begin
|
||
mp := p1;
|
||
p1 := p2;
|
||
p2 := mp;
|
||
end;
|
||
rad := GetRadOfLine(p1,p2);
|
||
dx := lx*cos(rad);
|
||
mp := MPoint(px,py,dx);
|
||
x := mp.x;
|
||
y := mp.y;
|
||
//if lx < ly then x := mx else y := my;
|
||
end;
|
||
end;
|
||
end else
|
||
begin
|
||
|
||
end;
|
||
end;
|
||
|
||
Procedure PointTo90Line(p1,p2: TDoublePoint; var x,y: Double);
|
||
var mx,my: double;
|
||
p,px,py: TDoublePoint;
|
||
lx,ly: Double;
|
||
a,b: Double;
|
||
begin
|
||
// y = ax+b
|
||
// x = (b-y)/a
|
||
if Get90LineFormula(p1,p2,a,b) then
|
||
begin
|
||
if (a = 0) and (b = 0) then
|
||
begin
|
||
mx := (p1.x+p2.x) / 2;
|
||
x := mx;
|
||
end else begin
|
||
if a = 0 then
|
||
begin
|
||
my := round(b);
|
||
y := my;
|
||
end else
|
||
begin
|
||
mx := round((y-b)/a);
|
||
my := round(a*x+b);
|
||
px := DoublePoint(mx,y);
|
||
py := DoublePoint(x,my);
|
||
p := DoublePoint(x,y);
|
||
lx := GetLineLenght(px,p);
|
||
ly := GetLineLenght(py,p);
|
||
if lx < ly then x := mx else y := my;
|
||
end;
|
||
end;
|
||
end else
|
||
begin
|
||
|
||
end;
|
||
end;
|
||
|
||
|
||
Procedure PointToParallelLine(p1,p2:TDoublepoint; var x,y: Double);
|
||
var a,b,aa,bb,ix: double;
|
||
begin
|
||
GetLineFormula(p1,p2,a,b);
|
||
if (a = 0) and (b= 0) then begin
|
||
y := (p1.y+p2.y) / 2;
|
||
end else if a = 0 then begin
|
||
x := (p1.x+p2.x) / 2;
|
||
end else begin
|
||
b := y-(a*x);
|
||
Get90LineFormula(p1,p2,aa,bb);
|
||
ix := (bb-b) / (a-aa);
|
||
y := a*ix+b;
|
||
x := ix;
|
||
end;
|
||
end;
|
||
|
||
Function PointByDistToLine(p1,p2:TDoublePoint; Dist:Double):TDoublePoint;
|
||
var rad: Double;
|
||
xp2: TDoublePoint;
|
||
np : TDoublePoint;
|
||
begin
|
||
rad := GetRadOfLine(p1,p2);
|
||
xp2 := RotatePoint(p1,p2,-rad);
|
||
np := MVPoint(xp2,dist);
|
||
np := RotatePoint(p1,np,rad);
|
||
result := np;
|
||
end;
|
||
|
||
Function PointByDistToLineA(p1,p2:TDoublePoint; Dist,Angle:Double):TDoublePoint;
|
||
var rad: Double;
|
||
xp1,xp2: TDoublePoint;
|
||
np : TDoublePoint;
|
||
begin
|
||
rad := GetRadOfLine(p1,p2);
|
||
xp2 := RotatePoint(p1,p2,Angle);
|
||
xp1 := p2;
|
||
ExtendLine(xp1,xp2,dist*2);
|
||
np := Mpoint(p1,xp2,dist);
|
||
result := np;
|
||
end;
|
||
|
||
Function PointOutToLine(p1,p2,xp:TDoublePoint; Dist:Double):TDoublePoint;
|
||
var rad: Double;
|
||
xp2: TDoublePoint;
|
||
np : TDoublePoint;
|
||
begin
|
||
rad := GetRadOfLine(p1,p2);
|
||
xp2 := RotatePoint(p1,xp,-rad);
|
||
np := MVPoint(xp2,dist);
|
||
np := RotatePoint(p1,np,rad);
|
||
result := np;
|
||
end;
|
||
Function GetLineNormal(p1,p2:TDoublePoint;dist:Double):TDoublePoint;
|
||
var np1,np2: TdoublePoint;
|
||
begin
|
||
GetParallelPoints(p1,p2,np1,np2,dist);
|
||
result := MPoint(np1,np2);
|
||
end;
|
||
|
||
function GetLineLenght(p1,p2: TDoublePoint; Planer:Boolean = True):Real;
|
||
var dp,hz: Double;
|
||
xp1,xp2: TdoublePoint;
|
||
begin
|
||
if EQD(p1.z,p2.z) or planer then begin
|
||
if EQDP(p1,p2) then
|
||
result := 0
|
||
else
|
||
result := sqrt(sqr(p1.x - p2.x)+sqr(p1.y - p2.y));
|
||
end else begin
|
||
xp1 := DoublePoint(p1.x,p1.y);
|
||
xp2 := DoublePoint(p2.x,p2.y);
|
||
dp := GetLineLenght(xp1,xp2,true);
|
||
hz := p2.z -p1.z;
|
||
result := sqrt((dp*dp)+(hz*hz));
|
||
end;
|
||
end;
|
||
|
||
function GetLineLength(p1,p2: TDoublePoint; Planer:Boolean = True):Real;
|
||
begin
|
||
result := GetLineLenght(p1,p2,planer);
|
||
end;
|
||
|
||
Function GetLineSegmentPoint(p1,p2:TDoublepoint; ratio: double):TDoublePoint;
|
||
var a,l: double;
|
||
dx,dy,dx0,dy0: double;
|
||
begin
|
||
l := GetLineLenght(p1,p2);
|
||
if l > 0 then begin
|
||
dx := p2.x-p1.x;
|
||
dy := p2.y-p1.y;
|
||
a := ratio*l;
|
||
dx0 := (a*dx)/l;
|
||
dy0 := (a*dy)/l;
|
||
end else begin
|
||
dx0 := 0;
|
||
dy0 := 0;
|
||
end;
|
||
result := DoublePoint(p1.x+dx0,p1.y+dy0);
|
||
end;
|
||
|
||
Function GetAreaofPGon(p:TdoublePointArr):real;
|
||
var posSum,negSum: real;
|
||
xidx,yidx: integer;
|
||
i,nPoint: integer;
|
||
begin
|
||
result := 0;
|
||
nPoint := Length(p);
|
||
if nPoint < 3 then exit;
|
||
posSum := 0;negSum := 0;
|
||
for i := 0 to nPoint-1 do
|
||
begin
|
||
xidx := i;
|
||
yidx := i+1;
|
||
if yidx = nPoint then yIdx :=0;
|
||
posSum := posSum + (p[xidx].x*p[yidx].y);
|
||
yidx := i;
|
||
xidx := i+1;
|
||
if xidx = nPoint then xIdx :=0;
|
||
negSum := negSum + (p[xidx].x*p[yidx].y);
|
||
end;
|
||
result := abs((PosSum - negSum)/2);
|
||
end;
|
||
|
||
|
||
Function GetAreaofPGon(p:array of Tpoint; nPoint: integer):Real;
|
||
var posSum,negSum: real;
|
||
xidx,yidx: integer;
|
||
i: integer;
|
||
begin
|
||
posSum := 0;negSum := 0;
|
||
for i := 0 to nPoint-1 do
|
||
begin
|
||
xidx := i;
|
||
yidx := i+1;
|
||
if yidx = nPoint then yIdx :=0;
|
||
posSum := posSum + (p[xidx].x*p[yidx].y);
|
||
yidx := i;
|
||
xidx := i+1;
|
||
if xidx = nPoint then xIdx :=0;
|
||
negSum := negSum + (p[xidx].x*p[yidx].y);
|
||
end;
|
||
result := abs((PosSum - negSum)/2);
|
||
end;
|
||
|
||
Function GetPerimeterOfCircle(r:double): real;
|
||
begin
|
||
result := 2 * PI * r;
|
||
end;
|
||
|
||
Function GetAreaOfCircle(r:double): real;
|
||
begin
|
||
result := pi * r * r;
|
||
end;
|
||
|
||
Function CreateLinearRgn(p1,p2: TDoublepoint): HRGN;
|
||
var rad: double;
|
||
points : array [0..3] of TDoublePoint;
|
||
ipoints: array [0..3] of TPoint;
|
||
pt: TDoublepoint;
|
||
a : integer;
|
||
begin
|
||
if p1.x > p2.x then
|
||
begin
|
||
pt := p1;
|
||
p1 := p2;
|
||
p2 := pt;
|
||
end;
|
||
|
||
rad := GetRadOfLine(p1,p2);
|
||
p2 := RotatePoint(p1,p2,-rad);
|
||
|
||
points[0] := DoublePoint(p1.x-2,p1.y-2);
|
||
points[1] := DoublePoint(p1.x-2,p1.y+2);
|
||
points[2] := DoublePoint(p2.x+2,p2.y+2);
|
||
points[3] := DoublePoint(p2.x-2,p2.y-2);
|
||
|
||
for a := 0 to 3 do
|
||
ipoints[a] := Dp2P(RotatePoint(p1,points[a],rad));
|
||
|
||
result := CreatePolygonRgn(ipoints,4,WINDING);
|
||
|
||
end;
|
||
|
||
Function CreateRotatedRgn(p1: TDoublepoint; w,h: Double; rad: double): HRGN;
|
||
var points: array [0..3] of TDoublePoint;
|
||
ipoints: array [0..3] of TPoint;
|
||
a: integer;
|
||
begin
|
||
|
||
points[0] := DoublePoint(p1.x,p1.y);
|
||
points[1] := DoublePoint(p1.x+w,p1.y);
|
||
points[2] := DoublePoint(p1.x+w,p1.y+h);
|
||
points[3] := DoublePoint(p1.x,p1.y+h);
|
||
|
||
for a := 0 to 3 do
|
||
ipoints[a] := DP2P(RotatePoint(p1,points[a],rad));
|
||
|
||
result := CreatePolygonRgn(ipoints,4,WINDING);
|
||
|
||
end;
|
||
|
||
Procedure FlipCanvas(Handle:HDC; fMode: TFlipMode;delta:double=0);
|
||
var xForm: TXForm;
|
||
f: integer;
|
||
dx,dy: Double;
|
||
begin
|
||
dx := 0;
|
||
dy := 0;
|
||
if fMode = fmHorz then f := 1 else f := -1;
|
||
if fMode = fmHorz then dx := delta else dy := delta;
|
||
SetGraphicsMode(Handle,GM_ADVANCED);
|
||
xform.eDx := dx;
|
||
xform.eDy := dy;
|
||
xform.eM11 := -1*f;
|
||
xform.eM12 := 0;
|
||
xform.em21 := 0;
|
||
xform.eM22 := 1*f;
|
||
SetWorldTransform(handle,xform);
|
||
end;
|
||
|
||
|
||
Procedure RotateCanvas(Handle:HDC; Ang: Real);
|
||
var xForm: TXForm;
|
||
begin
|
||
SetGraphicsMode(Handle,GM_ADVANCED);
|
||
xform.eDx := 0;
|
||
xform.eDy := 0;
|
||
xform.eM11 := cos(ang);
|
||
xform.eM12 := sin(ang);
|
||
xform.em21 := -1*sin(ang);
|
||
xform.eM22 := cos(ang);
|
||
SetWorldTransform(handle,xform);
|
||
end;
|
||
|
||
Procedure ResetCanvas(Handle:HDC);
|
||
var xForm: TXForm;
|
||
begin
|
||
ModifyWorldTransform(Handle,xForm,MWT_IDENTITY);
|
||
SetGraphicsMode(Handle,GM_COMPATIBLE);
|
||
end;
|
||
|
||
Function RotatePoint(cpoint, opoint: Tpoint; ang: real):TPoint;
|
||
var p:Tpoint;
|
||
begin
|
||
oPoint := Point (oPoint.x-cpoint.x,oPoint.y-cPoint.y);
|
||
p.y := round(oPoint.x * sin(ang) + oPoint.y*cos(ang));
|
||
p.x := round(oPoint.x * cos(ang) - oPoint.y*sin(ang));
|
||
p := Point(p.x+cpoint.x,p.y+cpoint.y);
|
||
result := p;
|
||
end;
|
||
|
||
Function RotatePoint(cpoint, opoint: TDoublepoint; ang: real):TDoublePoint;overload;
|
||
begin
|
||
result := RotateDPoint(cpoint, opoint, ang);
|
||
end;
|
||
//Tolik -- 12/02/2016 -- <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> (<28><>. <20><><EFBFBD><EFBFBD>)
|
||
// <20> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>
|
||
Function RotateDPoint(cpoint, opoint: TDoublepoint; ang: double):TDoublePoint;
|
||
var p:TDoublepoint;
|
||
RotAngle: Double;
|
||
begin
|
||
RotAngle := RoundTo(ang, -5);
|
||
oPoint := DoublePoint (oPoint.x-cpoint.x,oPoint.y-cPoint.y,oPoint.z);
|
||
p.y := (oPoint.x * sin(RotAngle) + oPoint.y*cos(RotAngle));
|
||
p.x := oPoint.x * cos(RotAngle) - oPoint.y*sin(RotAngle);
|
||
// Tolik 15/02/2018
|
||
// Tolik 19/12/2018 -- <20> <20><><EFBFBD><EFBFBD><EFBFBD>, <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD> <20> <20><> <20><><EFBFBD><EFBFBD><EFBFBD>, <20>.<2E>. <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
|
||
// TRichText (<28><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>)
|
||
p := DoublePoint(p.x+cpoint.x,p.y+cpoint.y,oPoint.z); // <20><><EFBFBD><EFBFBD> <20><><EFBFBD>(<28><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>) <20><><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
|
||
// <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD>-<2D><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD>, <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> ...
|
||
//p := DoublePoint(RoundTo((p.x+cpoint.x), -3),RoundTo((p.y+cpoint.y), -3), RoundTo(oPoint.z, -3));
|
||
|
||
//p := DoublePoint(Trunc((p.x+cpoint.x)*10000)/10000, Trunc((p.y+cpoint.y)*10000)/10000, Trunc((oPoint.z)*10000)/10000);
|
||
//
|
||
result := p;
|
||
end;
|
||
{
|
||
Function RotateDPoint(cpoint, opoint: TDoublepoint; ang: real):TDoublePoint;
|
||
var p:TDoublepoint;
|
||
begin
|
||
oPoint := DoublePoint (oPoint.x-cpoint.x,oPoint.y-cPoint.y,oPoint.z);
|
||
p.y := oPoint.x * sin(ang) + oPoint.y*cos(ang);
|
||
p.x := oPoint.x * cos(ang) - oPoint.y*sin(ang);
|
||
p := DoublePoint(p.x+cpoint.x,p.y+cpoint.y,oPoint.z);
|
||
result := p;
|
||
end;
|
||
}
|
||
|
||
Function ScalePoint(cpoint, opoint: TDoublepoint; px,py: real): TDoublePoint;
|
||
var
|
||
respoint: TDoublePoint;
|
||
deltax,deltay: double;
|
||
begin
|
||
// Tolik 02/05/2019 - - Init ResPoint.z;
|
||
respoint.z := 0;
|
||
//
|
||
if px = 1 then
|
||
begin
|
||
respoint.x := oPoint.x;
|
||
end
|
||
else
|
||
begin
|
||
deltax := cPoint.x - oPoint.x;
|
||
deltax := deltax * px;
|
||
respoint.x := cpoint.x - deltax;
|
||
end;
|
||
|
||
if py = 1 then
|
||
begin
|
||
respoint.y := oPoint.y;
|
||
end
|
||
else
|
||
begin
|
||
deltay := cPoint.y - oPoint.y;
|
||
deltay := deltay * py;
|
||
respoint.y := cpoint.y - deltay;
|
||
end;
|
||
result := respoint;
|
||
end;
|
||
|
||
Procedure GetParallelPoints(p1,p2:TDoublePoint; var np1,np2: TDoublePoint; thick:Double);
|
||
var rad:Double;
|
||
begin
|
||
rad := GetRadOfLine(p1,p2);
|
||
np2 := RotatePoint(p1,p2,-rad);
|
||
np1 := DoublePoint(p1.x,p1.y+thick);
|
||
np2 := DoublePoint(np2.x,np2.y+thick);
|
||
np1 := RotatePoint(p1,np1,rad);
|
||
np2 := RotatePoint(p1,np2,rad);
|
||
end;
|
||
|
||
Procedure GetShrinkedPoints(p1,p2:TDoublePoint; var np1,np2: TDoublePoint; thick:Double);
|
||
var rad:Double;
|
||
begin
|
||
rad := GetRadOfLine(p1,p2);
|
||
np2 := RotatePoint(p1,p2,-rad);
|
||
np1 := DoublePoint(p1.x+thick,p1.y);
|
||
np2 := DoublePoint(np2.x-thick,np2.y);
|
||
np1 := RotatePoint(p1,np1,rad);
|
||
np2 := RotatePoint(p1,np2,rad);
|
||
end;
|
||
|
||
Procedure OffsetPoint(op,cp:TDoublePoint; var np:TDoublePoint; delta: Double);
|
||
var rad:Double;
|
||
begin
|
||
rad := GetRadOfLine(cp,op);
|
||
np := RotatePoint(cp,op,-rad);
|
||
if cp.x < np.x then delta := -delta;
|
||
np := DoublePoint(np.x+delta,np.y);
|
||
np := RotatePoint(cp,np,rad);
|
||
end;
|
||
|
||
Function GetClosePoint(cPoint,p1,p2:TDoublePoint):TDoublePoint;
|
||
var d1,d2: Double;
|
||
begin
|
||
d1 := GetLineLenght(cPoint,p1);
|
||
d2 := GetLineLenght(cPoint,p2);
|
||
if d1 < d2 then result := p1 else result := p2;
|
||
end;
|
||
|
||
Function GetBezierTime(bp1,bp2,bp3,bp4,p1,p2:TDoublePoint):Double;
|
||
var t1,t2,dt: Double;
|
||
step: Integer;
|
||
done: boolean;
|
||
res: Integer;
|
||
rp,op1,op2: TDoublePOint;
|
||
Angle: Double;
|
||
begin
|
||
op1 := p1;
|
||
op2 := p2;
|
||
result := -1;
|
||
t1 := 0;
|
||
t2 := 1;
|
||
step := 0;
|
||
done := false;
|
||
|
||
Angle := GetRadOfLine(p1,p2);
|
||
|
||
p2 := RotatePoint(p1,p2,-Angle);
|
||
bp1 := RotatePoint(p1,bp1,-Angle);
|
||
bp2 := RotatePoint(p1,bp2,-Angle);
|
||
bp3 := RotatePoint(p1,bp3,-Angle);
|
||
bp4 := RotatePoint(p1,bp4,-Angle);
|
||
repeat
|
||
res := TraceBezier(bp1,bp2,bp3,bp4,p1,2,t1,t2);
|
||
if res = 1 then begin
|
||
result := t1;
|
||
done := true;
|
||
end else if res = 2 then begin
|
||
dt := t2-t1;
|
||
if (dt < 0.000001) or (step > 10) then begin
|
||
result := (t1+t2)/2;
|
||
done := true;
|
||
end;
|
||
end else begin
|
||
result := -1;
|
||
done := true;
|
||
end;
|
||
step := step+1;
|
||
until done ;
|
||
if (result <> -1) then begin
|
||
rp := GetBezierSample(bp1,bp2,bp3,bp4,result) ;
|
||
rp.y := p1.y;
|
||
rp := RotatePoint(op1,rp,Angle);
|
||
if not (isPOintInLine(op1,op2,rp,2)) then begin
|
||
result := -1;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
|
||
Function GetBezierTime(bp1,bp2,bp3,bp4,dp:TDoublePoint):Double;
|
||
var t1,t2,dt: Double;
|
||
step: Integer;
|
||
done: boolean;
|
||
res: Integer;
|
||
|
||
begin
|
||
result := -1;
|
||
t1 := 0;
|
||
t2 := 1;
|
||
step := 0;
|
||
done := false;
|
||
repeat
|
||
res := TraceBezier(bp1,bp2,bp3,bp4,dp,0,t1,t2);
|
||
if res = 1 then begin
|
||
result := t1;
|
||
done := true;
|
||
end else if res = 2 then begin
|
||
dt := t2-t1;
|
||
if (dt < 0.000001) or (step > 10) then begin
|
||
result := (t1+t2)/2;
|
||
done := true;
|
||
end;
|
||
end else begin
|
||
result := -1;
|
||
done := true;
|
||
end;
|
||
step := step+1;
|
||
until done ;
|
||
|
||
end;
|
||
|
||
Function GetLineBezierIntersection(p1,p2,bp1,bp2,bp3,bp4:TDoublePoint; var pArr:TDoublePointArr;
|
||
var icnt:Integer; extend:Boolean = true):Boolean;
|
||
var op1,op2: TDoublePoint;
|
||
d,Angle: Double;
|
||
t1,t2: Double;
|
||
res: Integer;
|
||
done: boolean;
|
||
step: Integer;
|
||
rp: TdoublePoint;
|
||
dt:Double;
|
||
valid: Boolean;
|
||
Procedure AddPointByT(tval: Double);
|
||
begin
|
||
rp := GetBezierSample(bp1,bp2,bp3,bp4,tval) ;
|
||
rp.y := p1.y;
|
||
rp := RotatePoint(op1,rp,Angle);
|
||
valid := true;
|
||
if not extend then begin
|
||
valid := (isPointInLine(op1,op2,rp,1,0.1)) and (not EQDP(op1,rp)) and (not EQDP(op2,rp));
|
||
end;
|
||
if valid then begin
|
||
iCnt := iCnt+1;
|
||
SetLength(pArr,iCnt);
|
||
pArr[iCnt-1] := rp;
|
||
end;
|
||
end;
|
||
begin
|
||
// move the system as if the line is x axis
|
||
op1 := p1;
|
||
op2 := p2;
|
||
Angle := GetRadOfLine(p1,p2);
|
||
|
||
p2 := RotatePoint(p1,p2,-Angle);
|
||
bp1 := RotatePoint(p1,bp1,-Angle);
|
||
bp2 := RotatePoint(p1,bp2,-Angle);
|
||
bp3 := RotatePoint(p1,bp3,-Angle);
|
||
bp4 := RotatePoint(p1,bp4,-Angle);
|
||
|
||
t1 := 0;
|
||
t2 := 1;
|
||
step := 0;
|
||
iCnt := 0;
|
||
done := false;
|
||
repeat
|
||
res := TraceBezier(bp1,bp2,bp3,bp4,p1,2,t1,t2);
|
||
if res = 1 then begin
|
||
AddPointbyT(t1);
|
||
t1 := t1+0.000001;
|
||
t2 := 1;
|
||
step := 0;
|
||
end else if res = 2 then begin
|
||
dt := t2-t1;
|
||
if (dt < 0.000001) or (step > 10) then begin
|
||
AddPointbyT((t1+t2)/2);
|
||
t1 := t2;
|
||
t2 := 1;
|
||
step := 0;
|
||
end;
|
||
end else begin
|
||
done := true;
|
||
end;
|
||
step := step+1;
|
||
until done ;
|
||
result := (icnt > 0);
|
||
|
||
end;
|
||
|
||
Function TraceBezier(bp1,bp2,bp3,bp4,tPoint:TDoublePoint; tIndex: Integer; var t1,t2: Double): integer;
|
||
var a: integer;
|
||
tx,px,py : real;
|
||
t : array[1..4] of real;
|
||
mcol,mrow: integer;
|
||
pntx,pnty: array[1..4] of Double;
|
||
sgn:Integer;
|
||
dx,dy,ox,oy: Double;
|
||
dt: Double;
|
||
sControl,sgx,sgy: Boolean;
|
||
begin
|
||
result := 0;
|
||
pntx[1] := bp1.x;
|
||
pntx[2] := bp2.x;
|
||
pntx[3] := bp3.x;
|
||
pntx[4] := bp4.x;
|
||
pnty[1] := bp1.y;
|
||
pnty[2] := bp2.y;
|
||
pnty[3] := bp3.y;
|
||
pnty[4] := bp4.y;
|
||
dt := t2-t1;
|
||
for a := 0 to 500 do
|
||
begin
|
||
tx := t1+(dt / 500)*a;
|
||
t[1] := tx*tx*tx;
|
||
t[2] := tx*tx;
|
||
t[3] := tx;
|
||
t[4] := 1;
|
||
px := 0;
|
||
py := 0;
|
||
for mcol := 1 to 4 do begin
|
||
for mrow := 1 to 4 do begin
|
||
px := px + mval[mrow,mcol]* t[mrow]*pntx[mcol];
|
||
py := py + mval[mrow,mcol]* t[mrow]*pnty[mcol];
|
||
end;
|
||
end;
|
||
dx := tPoint.x-px;
|
||
dy := tPoint.y-py;
|
||
if a = 0 then begin
|
||
sControl := ((tIndex = 1) and (dx = 0)) or ((tIndex = 1) and (dy = 0)) or
|
||
((tIndex = 2) and (dx = 0) and (dy = 0));
|
||
if sControl then begin
|
||
result := 1;
|
||
t1 := tx;
|
||
exit;
|
||
end;
|
||
end else begin
|
||
sControl := ((tIndex = 1) and (dx = 0)) or ((tIndex = 2) and (dy = 0)) or
|
||
((tIndex = 0) and (dx = 0) and (dy = 0));
|
||
if sControl then begin
|
||
result := 1;
|
||
t1 := tx;
|
||
exit;
|
||
end;
|
||
sgx := sign(ox) <> sign(dx);
|
||
sgy := sign(oy) <> sign(dy);
|
||
sControl := ((tIndex = 1) and (sgx)) or ((tIndex = 2) and (sgy)) or
|
||
((tIndex = 0) and (sgx) and (sgy));
|
||
if sControl then begin
|
||
result := 2;
|
||
t1 := t1+(dt / 500)*(a-1);
|
||
t2 := tx;
|
||
exit;
|
||
end;
|
||
end;
|
||
ox := dx;
|
||
oy := dy;
|
||
end;
|
||
end;
|
||
|
||
Function GetLineEllipseIntersection(p1,p2,cp:TdoublePoint;aLen,Blen,Angle:Double;
|
||
var np1,np2: TDoublePoint;var icnt:Integer; extend:Boolean = true):Boolean;
|
||
var D,x1,x2,y1,y2,c,k,xx,r,g,h,rx1,rx2,ry1,ry2,a,b: Double;
|
||
op1,op2: TdoublePoint;
|
||
i: integer;
|
||
res1,res2: Boolean;
|
||
begin
|
||
|
||
//move the system to the origin // rotate system
|
||
iCnt := 0;
|
||
result := false;
|
||
x1 := 0; x2 := 0;
|
||
y1 := 0; y2 := 0;
|
||
if EQDP(p1,p2) then exit;
|
||
op1 := p1;
|
||
op2 := p2;
|
||
p1 := RotatePoint(cp,p1,-Angle);
|
||
p2 := RotatePoint(cp,p2,-Angle);
|
||
|
||
p1 := DoublePoint(p1.x-cp.x,p1.y-cp.y);
|
||
p2 := DoublePoint(p2.x-cp.x,p2.y-cp.y);
|
||
a := aLen;
|
||
b := bLen;
|
||
|
||
x1 := p1.x; x2 := p2.x;
|
||
y1 := p1.y; y2 := p2.y;
|
||
|
||
GetLineformula(p1,p2,c,k);
|
||
|
||
if c<>0 then begin
|
||
g := (1/(a*a))+((c*c)/(b*b));
|
||
h := (2*c*k)/(b*b);
|
||
r := (k*k - b*b)/(b*b);
|
||
D := (h*h)-(4*g*r);
|
||
if d > 0 then begin
|
||
iCnt := 2;
|
||
rx1 := (-h+sqrt(d))/(2*g);
|
||
rx2 := (-h-sqrt(d))/(2*g);
|
||
ry1 := c*rx1+k;
|
||
ry2 := c*rx2+k;
|
||
np1 := DoublePoint(rx1,ry1);
|
||
np2 := DoublePoint(rx2,ry2);
|
||
end else if d = 0 then begin
|
||
iCnt := 1;
|
||
rx1 := (-h+sqrt(d))/(2*g);
|
||
ry1 := c*rx1+k;
|
||
np1 := DoublePoint(rx1,ry1);
|
||
end else if d < 0 then begin
|
||
iCnt := 0;
|
||
end;
|
||
|
||
end else begin
|
||
if EQD(x1 ,x2) then begin
|
||
if (EQD(abs(x1) , alen)) then begin
|
||
icnt := 1;
|
||
np1.x := x1;
|
||
np1.y := bLen*sqrt(1-(x1/aLen)*(x1/aLen));
|
||
end else if between(x1,aLen,-aLen) then begin
|
||
icnt := 2;
|
||
np1.x := x1; np2.x := x1;
|
||
np1.y := bLen*sqrt(1-(x1/aLen)*(x1/aLen));
|
||
np2.y := -1*bLen*sqrt(1-(x1/aLen)*(x1/aLen));
|
||
end;
|
||
end else if EQD(y1 ,y2) then begin
|
||
if (EQD(abs(y1) , blen)) then begin
|
||
icnt := 1;
|
||
np1.y := y1;
|
||
np1.x := aLen*sqrt(1-(y1/bLen)*(y1/bLen));
|
||
end else if between(y1,bLen,-bLen) then begin
|
||
icnt := 2;
|
||
np1.y := y1; np2.y := y1;
|
||
np1.x := aLen*sqrt(1-(y1/bLen)*(y1/bLen));
|
||
np2.x := -1*aLen*sqrt(1-(y1/bLen)*(y1/bLen));
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
if icnt > 0 then begin
|
||
result := true;
|
||
np1 := DoublePoint(np1.x+cp.x,np1.y+cp.y);
|
||
np2 := DoublePoint(np2.x+cp.x,np2.y+cp.y);
|
||
np1 := RotatePoint(cp,np1,Angle);
|
||
np2 := RotatePoint(cp,np2,Angle);
|
||
end;
|
||
|
||
res1 := false;
|
||
res2 := false;
|
||
if result and not extend then begin
|
||
res1 := isPointinLine(op1,op2,np1,1,0.1)
|
||
and (not EQDP(np1,op1)) and (not EQDP(np1,op2));
|
||
res2 := isPointinLine(op1,op2,np2,1,0.1)
|
||
and (not EQDP(np2,op1)) and (not EQDP(np2,op2));
|
||
if icnt = 1 then begin
|
||
result := res1;
|
||
end else if icnt = 2 then begin
|
||
if not res1 then begin
|
||
icnt := 1;
|
||
np1 := np2;
|
||
result := res2;
|
||
end else begin
|
||
if not res2 then iCnt := 1;
|
||
end;
|
||
end;
|
||
if not result then icnt := 0;
|
||
end;
|
||
|
||
end;
|
||
|
||
|
||
Function GetLineCircleIntersection(p1,p2,cp:TdoublePoint;radius:Double; var np1,np2: TDoublePoint; var icnt:Integer;extend:Boolean = true):Boolean;
|
||
var dx,dy,dr,D,delta,r,x1,x2,y1,y2: Double;
|
||
xcnt: Integer;
|
||
op1,op2: TDoublePoint;
|
||
res1,res2: Boolean;
|
||
Function sgn(x:Double): Integer;
|
||
begin
|
||
result := sign(x);
|
||
if result = 0 then result := 1;
|
||
end;
|
||
begin
|
||
//move the system to the origin
|
||
op1 := p1;
|
||
op2 := p2;
|
||
x1 := 0; y1 := 0; x2 := 0; y2 := 0;
|
||
p1 := DoublePoint(p1.x-cp.x,p1.y-cp.y);
|
||
p2 := DoublePoint(p2.x-cp.x,p2.y-cp.y);
|
||
|
||
r := Radius;
|
||
dx := p2.x-p1.x;
|
||
dy := p2.y-p1.y;
|
||
dr := sqrt(dx*dx+dy*dy);
|
||
D := p1.x*p2.y-p2.x*p1.y;
|
||
|
||
Delta := r*r*dr*dr-D*D;
|
||
|
||
if Delta < 0 then begin
|
||
result := false;
|
||
icnt := 0;
|
||
end else if Delta = 0 then begin
|
||
result := True;
|
||
icnt := 1;
|
||
x1 := (D*dy+sgn(dy)*dx*sqrt(delta))/(dr*dr);
|
||
y1 := (-D*dx+abs(dy)*sqrt(delta))/(dr*dr);
|
||
x1 := x1 + cp.x; y1 :=y1 + cp.y;
|
||
end else if Delta > 0 then begin
|
||
result := True;
|
||
icnt := 2;
|
||
x1 := (D*dy+sgn(dy)*dx*sqrt(delta))/(dr*dr);
|
||
y1 := (-D*dx+abs(dy)*sqrt(delta))/(dr*dr);
|
||
x1 := x1 + cp.x; y1 :=y1 + cp.y;
|
||
x2 := (D*dy-sgn(dy)*dx*sqrt(delta))/(dr*dr);
|
||
y2 := (-D*dx-abs(dy)*sqrt(delta))/(dr*dr);
|
||
x2 := x2 + cp.x; y2 :=y2 + cp.y;
|
||
end;
|
||
if result then begin
|
||
np1 := DoublePoint(x1,y1);
|
||
np2 := DoublePoint(x2,y2);
|
||
end;
|
||
res1 := false;
|
||
res2 := false;
|
||
if result and not extend then begin
|
||
res1 := isPointinLine(op1,op2,np1,1,0.1)
|
||
and (not EQDP(np1,op1)) and (not EQDP(np1,op2));
|
||
res2 := isPointinLine(op1,op2,np2,1,0.1)
|
||
and (not EQDP(np2,op1)) and (not EQDP(np2,op2));
|
||
if icnt = 1 then begin
|
||
result := res1;
|
||
end else if icnt = 2 then begin
|
||
if not res1 then begin
|
||
icnt := 1;
|
||
np1 := np2;
|
||
result := res2;
|
||
end else begin
|
||
if not res2 then iCnt := 1;
|
||
end;
|
||
end;
|
||
if not result then icnt := 0;
|
||
end;
|
||
|
||
end;
|
||
(*
|
||
Function GetLineEllipseIntersection(p1,p2,cp:TdoublePoint;aLen,Blen,Angle:Double; var np1,np2: TDoublePoint; var icnt:Integer;extend:Boolean = true):Boolean;
|
||
var dx,dy,dr,D,delta,x1,x2,y1,y2: Double;
|
||
xcnt: Integer;
|
||
op1,op2: TDoublePoint;
|
||
Function sgn(x:Double): Integer;
|
||
begin
|
||
result := sign(x);
|
||
if result = 0 then result := 1;
|
||
end;
|
||
begin
|
||
//move the system to the origin
|
||
|
||
iCnt := 0;
|
||
result := false;
|
||
if EQDP(p1,p2) then exit;
|
||
|
||
op1 := p1;
|
||
op2 := p2;
|
||
|
||
p1 := RotatePoint(cp,p1,-Angle);
|
||
p2 := RotatePoint(cp,p2,-Angle);
|
||
|
||
x1 := 0; y1 := 0; x2 := 0; y2 := 0;
|
||
p1 := DoublePoint(p1.x-cp.x,p1.y-cp.y);
|
||
p2 := DoublePoint(p2.x-cp.x,p2.y-cp.y);
|
||
|
||
dx := p2.x-p1.x;
|
||
dy := p2.y-p1.y;
|
||
dr := sqrt(dx*dx+dy*dy);
|
||
D := p1.x*p2.y-p2.x*p1.y;
|
||
|
||
Delta := aLen*bLen*dr*dr-D*D;
|
||
|
||
if Delta < 0 then begin
|
||
result := false;
|
||
icnt := 0;
|
||
end else if Delta = 0 then begin
|
||
result := True;
|
||
icnt := 1;
|
||
x1 := (D*dy+sgn(dy)*dx*sqrt(delta))/(dr*dr);
|
||
y1 := (-D*dx+abs(dy)*sqrt(delta))/(dr*dr);
|
||
x1 := x1 + cp.x; y1 :=y1 + cp.y;
|
||
end else if Delta > 0 then begin
|
||
result := True;
|
||
icnt := 2;
|
||
x1 := (D*dy+sgn(dy)*dx*sqrt(delta))/(dr*dr);
|
||
y1 := (-D*dx+abs(dy)*sqrt(delta))/(dr*dr);
|
||
x1 := x1 + cp.x; y1 :=y1 + cp.y;
|
||
x2 := (D*dy-sgn(dy)*dx*sqrt(delta))/(dr*dr);
|
||
y2 := (-D*dx-abs(dy)*sqrt(delta))/(dr*dr);
|
||
x2 := x2 + cp.x; y2 :=y2 + cp.y;
|
||
end;
|
||
if result then begin
|
||
np1 := DoublePoint(x1,y1);
|
||
np2 := DoublePoint(x2,y2);
|
||
np1 := RotatePoint(cp,np1,Angle);
|
||
np2 := RotatePoint(cp,np2,Angle);
|
||
end;
|
||
if result and not extend then begin
|
||
if icnt = 1 then begin
|
||
result := isPointinLine(op1,op2,np1,2);
|
||
end else if icnt = 2 then begin
|
||
if not isPointinLine(op1,op2,np1,2) then begin
|
||
icnt := 1;
|
||
np1 := np2;
|
||
result := isPointinLine(op1,op2,np1,2);
|
||
end else begin
|
||
if not isPointinLine(op1,op2,np2,2) then iCnt := 1;
|
||
end;
|
||
end;
|
||
if not result then icnt := 0;
|
||
end;
|
||
|
||
end;
|
||
|
||
*)
|
||
Function GetCircleCircleIntersection(cp1:TdoublePoint;rad1:Double;cp2:TdoublePoint;
|
||
rad2:Double; var np1,np2: TDoublePoint; var icnt: Integer):Boolean;
|
||
var d,rad,x,y1,y2,a,f,g: Double;
|
||
|
||
begin
|
||
/// move system to the origin based distance
|
||
result := true;
|
||
rad := GetRadOfLine(cp1,cp2);
|
||
cp2 := RotatePoint(cp1,cp2,-rad);
|
||
d := cp2.x - cp1.x;
|
||
if (d = 0) or (abs(d) > (rad1+rad2)) or (abs(d)+rad2 < rad1) then begin
|
||
result := false;
|
||
icnt := 0;
|
||
exit;
|
||
end;
|
||
|
||
if result then begin
|
||
f := (d*d-rad2*rad2+rad1*rad1);
|
||
x := f / (2*d);
|
||
g := 4*d*d*rad1*rad1-power((f),2);
|
||
if g > 0 then begin
|
||
a := (1/d)*sqrt(g);
|
||
if a = 0 then icnt := 1 else icnt := 2;
|
||
y1 := a / 2;
|
||
y2 := -a/2;
|
||
np1 := DoublePOint(x,y1);
|
||
np2 := DoublePOint(x,y2);
|
||
np1 := DoublePoint(np1.x+cp1.x,np1.y+cp1.y);
|
||
np2 := DoublePoint(np2.x+cp1.x,np2.y+cp1.y);
|
||
np1 := RotatePoint(cp1,np1,rad);
|
||
np2 := RotatePoint(cp1,np2,rad);
|
||
end else begin
|
||
result := false;
|
||
icnt := 0;
|
||
exit;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
Procedure SortList(var sList:Tlist; GetValueFunc:TGetValueFunc);
|
||
var i,cnt:Integer;
|
||
SArr:TSortItemArr;
|
||
dList: TList;
|
||
begin
|
||
cnt := sList.Count;
|
||
if cnt < 2 then exit;
|
||
SetLength(sArr,cnt);
|
||
for i := 0 to Cnt-1 do
|
||
begin
|
||
sArr[i].Value := GetValueFunc(sList[i]);
|
||
sArr[i].Tag := i;
|
||
end;
|
||
SortItems(sArr);
|
||
dList := TList.Create;
|
||
for i := 0 to cnt-1 do
|
||
dList.Add(sList[i]);
|
||
sList.Clear;
|
||
for i := 0 to cnt-1 do begin
|
||
SList.Add(dList[sArr[i].Tag]);
|
||
end;
|
||
dList.Free;
|
||
setLength(sArr, 0); // Tolik 21/05/2018 - -
|
||
end;
|
||
|
||
Procedure SortList(var sList:Tlist; GetValueFunc:TGetValueFuncEx; Data:Pointer);
|
||
var i,cnt:Integer;
|
||
SArr:TSortItemArr;
|
||
dList: TList;
|
||
begin
|
||
cnt := sList.Count;
|
||
if cnt < 2 then exit;
|
||
SetLength(sArr,cnt);
|
||
for i := 0 to Cnt-1 do
|
||
begin
|
||
sArr[i].Value := GetValueFunc(sList[i],Data);
|
||
sArr[i].Tag := i;
|
||
end;
|
||
SortItems(sArr);
|
||
dList := TList.Create;
|
||
for i := 0 to cnt-1 do
|
||
dList.Add(sList[i]);
|
||
sList.Clear;
|
||
for i := 0 to cnt-1 do begin
|
||
SList.Add(dList[sArr[i].Tag]);
|
||
end;
|
||
dList.Free;
|
||
setLength(sArr, 0); // Tolik 21/05/2018 - -
|
||
end;
|
||
|
||
Procedure SortItems(var SArr:TSortItemArr);
|
||
procedure QuickSort(var A: TSortItemArr; iLo, iHi: Integer);
|
||
var
|
||
Lo, Hi: Integer;
|
||
Mid, T: TSortItem;
|
||
begin
|
||
Lo := iLo;
|
||
Hi := iHi;
|
||
Mid := A[(Lo + Hi) div 2];
|
||
repeat
|
||
while A[Lo].Value < Mid.Value do Inc(Lo);
|
||
while A[Hi].Value > Mid.Value do Dec(Hi);
|
||
if Lo <= Hi then
|
||
begin
|
||
T := A[Lo];
|
||
A[Lo] := A[Hi];
|
||
A[Hi] := T;
|
||
Inc(Lo);
|
||
Dec(Hi);
|
||
end;
|
||
until Lo > Hi;
|
||
if Hi > iLo then QuickSort(A, iLo, Hi);
|
||
if Lo < iHi then QuickSort(A, Lo, iHi);
|
||
end;
|
||
|
||
begin
|
||
QuickSort(SArr, Low(SArr), High(SArr));
|
||
end;
|
||
|
||
Procedure SortDouble(var SArr:TDoubleArray);
|
||
procedure QuickSort(var A: TDoubleArray; iLo, iHi: Integer);
|
||
var
|
||
Lo, Hi: Integer;
|
||
Mid, T: Double;
|
||
begin
|
||
Lo := iLo;
|
||
Hi := iHi;
|
||
Mid := A[(Lo + Hi) div 2];
|
||
repeat
|
||
while A[Lo] < Mid do Inc(Lo);
|
||
while A[Hi] > Mid do Dec(Hi);
|
||
if Lo <= Hi then
|
||
begin
|
||
T := A[Lo];
|
||
A[Lo] := A[Hi];
|
||
A[Hi] := T;
|
||
Inc(Lo);
|
||
Dec(Hi);
|
||
end;
|
||
until Lo > Hi;
|
||
if Hi > iLo then QuickSort(A, iLo, Hi);
|
||
if Lo < iHi then QuickSort(A, Lo, iHi);
|
||
end;
|
||
|
||
begin
|
||
QuickSort(SArr, Low(SArr), High(SArr));
|
||
end;
|
||
|
||
Procedure SortPointsOnLine(p1,p2: TDoublePoint; var pArr:TDoublePointArr);
|
||
var cnt,i: Integer;
|
||
sArr: TSortItemArr;
|
||
tArr: TDoublePointArr;
|
||
len: Double;
|
||
begin
|
||
cnt := Length(pArr);
|
||
SetLength(sArr,cnt);
|
||
SetLength(tArr,cnt);
|
||
for i := 0 to cnt-1 do
|
||
begin
|
||
len := GetLineLenght(p1,pArr[i]);
|
||
sArr[i].Value := len;
|
||
sArr[i].Tag := i;
|
||
tArr[i] := pArr[i];
|
||
end;
|
||
SortItems(sArr);
|
||
for i := 0 to cnt-1 do
|
||
begin
|
||
pArr[i] := tArr[sArr[i].Tag];
|
||
end;
|
||
setLength(sArr, 0); // Tolik 21/05/2018 - -
|
||
end;
|
||
|
||
Procedure InSertPointToArray(var pArr:TDoublePointArr; index:Integer; p:TDoublePoint);
|
||
var cnt,i: Integer;
|
||
begin
|
||
cnt := Length(pArr);
|
||
if (index > cnt) or (index <0) then exit;
|
||
SetLength(pArr,cnt+1);
|
||
for i:= cnt downto index+1 do
|
||
begin
|
||
pArr[i] := pArr[i-1];
|
||
end;
|
||
pArr[index] := p;
|
||
end;
|
||
|
||
Function CheckLineOnLine(pArr:TDoublePointArr):Boolean;
|
||
var i,k,cnt: Integer;
|
||
p1,p2,p3,p4: TDoublePoint;
|
||
begin
|
||
result := false;
|
||
cnt := Length(pArr);
|
||
for i := 0 to cnt-3 do
|
||
begin
|
||
p1 := pArr[i];
|
||
p2 := pArr[i+1];
|
||
for k := i+1 to cnt-2 do
|
||
begin
|
||
p3 := pArr[k];
|
||
p4 := pArr[k+1];
|
||
if (isPointinLine(p1,p2,p3,1,0.2) and isPointinLine(p1,p2,p4,1,0.2)) or
|
||
(isPointinLine(p3,p4,p1,1,0.2) and isPointinLine(p3,p4,p2,1,0.2)) then
|
||
begin
|
||
result := true;
|
||
exit;
|
||
end;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
Function CheckLineOnLine(p1,p2,p3,p4:TDoublePoint):Boolean;overload;
|
||
begin
|
||
result := false;
|
||
if (isPointinLine(p1,p2,p3,1,0.2) and isPointinLine(p1,p2,p4,1,0.2)) or
|
||
(isPointinLine(p3,p4,p1,1,0.2) and isPointinLine(p3,p4,p2,1,0.2)) then
|
||
begin
|
||
result := true;
|
||
exit;
|
||
end;
|
||
end;
|
||
|
||
Function LinesIntersect(p1,p2,p3,p4:TDoublePoint):Boolean;
|
||
var ip:TDoublePOint;
|
||
|
||
Function EQP(x1,x2:TDoublePOint):Boolean;
|
||
begin
|
||
result := EQDP(x1,x2) and EQD(x1.z,x2.z);
|
||
end;
|
||
|
||
Function bw(d1,d2,d3:Double):Boolean;
|
||
begin
|
||
result := ((d1 >= d2) and (d1 <= d3)) or ((d1 >= d3) and (d1 <= d2));
|
||
end;
|
||
|
||
Function PointOnLine(x1,x2,p:TDoublePOint):Boolean;
|
||
var z1,z2: Double;
|
||
begin
|
||
result := false;
|
||
if EQD(x1.z,x2.z) then begin
|
||
result := EQD(p.z,x1.z) and isPointinLine(x1,x2,p,1,0.1);
|
||
end else if EQDP(x1,x2) then begin
|
||
if x1.z < x2.z then begin
|
||
z1 := x1.z; z2 := x2.z;
|
||
end else begin
|
||
z1 := x2.z; z2 := x1.z;
|
||
end;
|
||
result := EQDP(x1,p) and ((p.z > x1.z) and (p.z < x2.z));
|
||
end;
|
||
end;
|
||
begin
|
||
result := false;
|
||
// check points p1
|
||
if PointOnLine(p3,p4,p1) and not (EQP(p1,p3) or EQP(p1,p3)) then
|
||
begin
|
||
result := true;
|
||
exit;
|
||
end;
|
||
|
||
// check points p2
|
||
if PointOnLine(p3,p4,p2) and not (EQP(p2,p3) or EQP(p2,p3)) then
|
||
begin
|
||
result := true;
|
||
exit;
|
||
end;
|
||
// check points p3
|
||
if PointOnLine(p1,p2,p3) and not (EQP(p3,p1) or EQP(p3,p2)) then
|
||
begin
|
||
result := true;
|
||
exit;
|
||
end;
|
||
// check points p4
|
||
if PointOnLine(p1,p2,p4) and not (EQP(p4,p1) or EQP(p4,p2)) then
|
||
begin
|
||
result := true;
|
||
exit;
|
||
end;
|
||
|
||
// check same lines
|
||
if (EQP(p1,p3) and EQP(p2,p4)) or (EQP(p2,p3) and EQP(p1,p4)) then begin
|
||
result := true;
|
||
exit;
|
||
end;
|
||
|
||
//check dikey intersect
|
||
if EQDP(p1,p2) and EQDP(p2,p3) and EQDP(p3,p4) then begin
|
||
if ((p1.z > p3.z) and (p1.z < p4.z)) or
|
||
((p1.z > p4.z) and (p1.z < p3.z)) or
|
||
((p2.z > p3.z) and (p2.z < p4.z)) or
|
||
((p2.z > p4.z) and (p2.z < p3.z)) or
|
||
((p3.z > p1.z) and (p3.z < p2.z)) or
|
||
((p3.z > p2.z) and (p3.z < p1.z)) or
|
||
((p4.z > p1.z) and (p4.z < p2.z)) or
|
||
((p4.z > p2.z) and (p4.z < p1.z)) then
|
||
begin
|
||
result := true;
|
||
exit;
|
||
|
||
end;
|
||
|
||
end;
|
||
|
||
|
||
// check planer intersects
|
||
|
||
if (EQD(p1.z,p2.z) and EQD(p2.z,p3.z) and EQD(p3.z,p4.z)) then begin
|
||
if GetIntersectionPoint(p1,p2,p3,p4,ip,false,false) then
|
||
result := True;
|
||
end else if (EQD(p1.z,p2.z) and (bw(p1.z,p3.z,p4.z))and EQDP(p3,p4) and not (EQDP(p3,p1) or EQDP(p3,p2))) then begin
|
||
if isPointInLine(p1,p2,p3,1,0.1) then
|
||
result := True;
|
||
end else if (EQD(p3.z,p4.z) and (bw(p3.z,p1.z,p2.z)) and EQDP(p1,p2) and not (EQDP(p1,p3) or EQDP(p1,p4))) then begin
|
||
if isPointInLine(p3,p4,p1,1,0.1) then
|
||
result := true;
|
||
end;
|
||
end;
|
||
|
||
Function CheckSelfIntersection(var pArr:TDoublePointArr):Boolean;
|
||
var i,cnt,k: Integer;
|
||
p1,p2,p3,p4,p: TDoublePOint;
|
||
exitFor,done: Boolean;
|
||
begin
|
||
result := True;
|
||
repeat
|
||
cnt := Length(pArr);
|
||
ExitFor := False;
|
||
done := true;
|
||
for i := 0 to cnt-3 do
|
||
begin
|
||
p1 := pArr[i];
|
||
p2 := pArr[i+1];
|
||
for k := i+1 to cnt-2 do
|
||
begin
|
||
p3 := pArr[k];
|
||
p4 := pArr[k+1];
|
||
if GetIntersectionPoint(p1,p2,p3,p4,p,false) then
|
||
begin
|
||
InsertPointToArray(pArr,k+1,p);
|
||
InsertPointToArray(pArr,i+1,p);
|
||
done := false;
|
||
exitFor := True;
|
||
break;
|
||
end;
|
||
end;
|
||
if ExitFor then break;
|
||
end;
|
||
until done;
|
||
end;
|
||
|
||
Function GetInterSectionPoint(p1, p2, p3, p4: TDoublePoint; var p: TDoublePoint; extend: Boolean = True; usetips: Boolean = False): Boolean;
|
||
var
|
||
x, y, a1, a2, b1, b2: Double;
|
||
v1, v2: Boolean;
|
||
l1, l2: Boolean;
|
||
begin
|
||
result := false;
|
||
if (not extend) and (EQDP(p1,p2) or EQDP(p1,p3) or EQDP(p2,p3) or EQDP(p2,p4) or EQDP(p3,p4) ) then
|
||
begin
|
||
result := false;
|
||
exit;
|
||
end;
|
||
try
|
||
l1 := GetLineFormula(p1, p2, a1, b1);
|
||
l2 := GetLineFormula(p3, p4, a2, b2);
|
||
v1 := (a1 = 0) and (b1 = 0);
|
||
v2 := (a2 = 0) and (b2 = 0);
|
||
a1 := Trunc(a1 * 100000)/100000;
|
||
b1 := Trunc(b1 * 100000)/100000;
|
||
a2 := Trunc(a2 * 100000)/100000;
|
||
b2 := Trunc(b2 * 100000)/100000;
|
||
if (l1 and l2) and (v1 and (not v2)) then
|
||
begin
|
||
result := true;
|
||
x := p1.x;
|
||
y := a2 * x + b2;
|
||
end
|
||
else
|
||
if (l1 and l2) and (v2 and (not v1)) then
|
||
begin
|
||
result := true;
|
||
x := p3.x;
|
||
y := a1 * x + b1;
|
||
end
|
||
else
|
||
if EQD(a1, a2) or (not l1) or (not l2) then
|
||
begin
|
||
result := True;
|
||
if EQDP(p2, p3) or EQDP(p2, p4) then
|
||
begin
|
||
x := p2.x;
|
||
y := p2.y;
|
||
end
|
||
else
|
||
if EQDP(p1, p3) or EQDP(p1, p4) then
|
||
begin
|
||
x := p1.x;
|
||
y := p1.y;
|
||
end
|
||
else
|
||
result := false;
|
||
end
|
||
else
|
||
begin
|
||
result := True;
|
||
x := (b2 - b1) / (a1 - a2);
|
||
y := a1 * x + b1;
|
||
end;
|
||
except
|
||
result := false;
|
||
end;
|
||
if result then
|
||
p := DoublePoint(x,y);
|
||
if result and not extend then
|
||
begin
|
||
result := isPointInLine(p1, p2, p, 1, 0.1) and isPointInLine(p3, p4, p, 1, 0.1);
|
||
if result and not usetips then
|
||
result := (not EQDP(p1,p3)) and (not EQDP(p2,p3)) and (not EQDP(p1,p4)) and (not EQDP(p2,p4));
|
||
// result := (not EQDP(p,p1)) and (not EQDP(p,p2)) and (not EQDP(p,p3)) and (not EQDP(p,p4));
|
||
end;
|
||
end;
|
||
|
||
Function SubBezier(p0,p1,p2,p3: TDoublePoint;
|
||
var dPoint,cp1,cp2,cp3,cp4:TDoublePoint;
|
||
ts:Double; bp1,bp2:TDoublepOint):Boolean;
|
||
var A,B,C,D,E,F:TDoublePoint;
|
||
begin
|
||
result := false;
|
||
if (ts < 0) or (ts > 1) then begin
|
||
ts := GetBezierTime(p0,p1,p2,p3,bp1,bp2);
|
||
end;
|
||
if (ts < 0) or (ts > 1) then exit;
|
||
|
||
A := DoublePoint( (1-ts)*P0.x + ts*P1.x,(1-ts)*P0.y + ts*P1.y);
|
||
B := DoublePoint( (1-ts)*P1.x + ts*P2.x,(1-ts)*P1.y + ts*P2.y);
|
||
C := DoublePoint( (1-ts)*P2.x + ts*P3.x,(1-ts)*P2.y + ts*P3.y);
|
||
D := DoublePoint( (1-ts)*A.x + ts*B.x,(1-ts)*A.y + ts*B.y);
|
||
E := DoublePoint( (1-ts)*B.x + ts*C.x,(1-ts)*B.y + ts*C.y);
|
||
F := DoublePoint( (1-ts)*D.x + ts*E.x,(1-ts)*D.y + ts*E.y);
|
||
dPoint := F;
|
||
cp1 := A;
|
||
cp2 := D;
|
||
cp3 := E;
|
||
cp4 := C;
|
||
result := true;
|
||
end;
|
||
|
||
Function SubBezier(p0,p1,p2,p3: TDoublePoint; var dPoint,cp1,cp2,cp3,cp4:TDoublePoint; ts:Double):Boolean;
|
||
var A,B,C,D,E,F:TDoublePoint;
|
||
begin
|
||
result := false;
|
||
if (ts < 0) or (ts > 1) then begin
|
||
ts := GetBezierTime(p0,p1,p2,p3,dPoint);
|
||
end;
|
||
if (ts < 0) or (ts > 1) then exit;
|
||
|
||
A := DoublePoint( (1-ts)*P0.x + ts*P1.x,(1-ts)*P0.y + ts*P1.y);
|
||
B := DoublePoint( (1-ts)*P1.x + ts*P2.x,(1-ts)*P1.y + ts*P2.y);
|
||
C := DoublePoint( (1-ts)*P2.x + ts*P3.x,(1-ts)*P2.y + ts*P3.y);
|
||
D := DoublePoint( (1-ts)*A.x + ts*B.x,(1-ts)*A.y + ts*B.y);
|
||
E := DoublePoint( (1-ts)*B.x + ts*C.x,(1-ts)*B.y + ts*C.y);
|
||
F := DoublePoint( (1-ts)*D.x + ts*E.x,(1-ts)*D.y + ts*E.y);
|
||
dPoint := F;
|
||
cp1 := A;
|
||
cp2 := D;
|
||
cp3 := E;
|
||
cp4 := C;
|
||
result := true;
|
||
end;
|
||
|
||
Procedure DoubleBezier(p1,p2,p3,p4:TDoublePoint;var t: TDoublePointArr; thick: Double);
|
||
var p: TDoublePointArr;
|
||
i: integer;
|
||
l1,l2,n1,n2:TDoublePoint;
|
||
i1,i2,i3,i4,ip:TDoublePoint;
|
||
sCount: Integer;
|
||
begin
|
||
sCount := 500;
|
||
SetLength(t,sCount+1);
|
||
SetLength(p,sCount+1);
|
||
for i:= 0 to sCount do
|
||
begin
|
||
p[i] := GetBezierSample(p1,p2,p3,p4,i/SCount);
|
||
end;
|
||
|
||
for i:= 0 to sCount-1 do begin
|
||
l1 := p[i];
|
||
l2 := p[i+1];
|
||
GetParallelPoints(l1,l2,n1,n2,thick);
|
||
t[i+1] := n2;
|
||
if i = 0 then
|
||
t[i] := n1
|
||
else begin
|
||
i1 := t[i-1];
|
||
i2 := t[i];
|
||
i3 := n1;
|
||
i4 := n2;
|
||
if GetIntersectionPoint(i1,i2,i3,i4,ip,false) then
|
||
begin
|
||
t[i] := ip;
|
||
end else begin
|
||
t[i] := n1;
|
||
end;
|
||
end;
|
||
end;
|
||
SetLength(p,0);
|
||
end;
|
||
|
||
Function DoublePoint(pt:Tpoint):TDoublePoint;
|
||
begin
|
||
Result.x := pt.x;
|
||
result.y := pt.y;
|
||
Result.z := 0;
|
||
end;
|
||
|
||
Function DP(pt:TPoint):TDoublePOint;
|
||
begin
|
||
result := DoublePoint(pt);
|
||
end;
|
||
|
||
Procedure SwapPoints(var p1,p2:TDOublePoint);
|
||
var xp:TDoublePoint;
|
||
begin
|
||
xp := p1;
|
||
p1 := p2;
|
||
p2 := xp;
|
||
end;
|
||
|
||
Function DoublePoint(x,y,z:Double):TDoublePoint;
|
||
begin
|
||
Result.x := x;
|
||
Result.y := y;
|
||
Result.z := z;
|
||
end;
|
||
|
||
|
||
Function DoublePoint(p:TdoublePoint;z:Double):TDoublePoint;
|
||
begin
|
||
Result.x := p.x;
|
||
Result.y := p.y;
|
||
Result.z := z;
|
||
end;
|
||
|
||
Function DoublePoint(x,y:Double):TDoublePoint;
|
||
begin
|
||
Result.x := x;
|
||
Result.y := y;
|
||
Result.z := 0;
|
||
end;
|
||
|
||
Procedure ShrinkLine(var p1,p2:TDoublePoint;d:Double);
|
||
begin
|
||
p1 := MPoint(p1,p2,d);
|
||
p2 := Mpoint(p2,p1,d);
|
||
end;
|
||
|
||
Procedure ExtendLine(var p1,p2:TDoublePoint;d:Double);
|
||
begin
|
||
p1 := MPoint(p1,p2,-d);
|
||
p2 := Mpoint(p2,p1,-d);
|
||
end;
|
||
|
||
Procedure ShrinkRect(var Rect:TDoubleRect;d:Double);
|
||
begin
|
||
rect.Left := rect.Left+d;
|
||
rect.right := rect.right-d;
|
||
rect.top := rect.top+d;
|
||
rect.Bottom := rect.Bottom -d;
|
||
end;
|
||
|
||
Function MPoint(p1,p2:TDoublePoint):TDoublePoint;
|
||
begin
|
||
Result := DoublePoint((p1.x+p2.x)/2,(p1.y+p2.y)/2,(p1.z+p2.z)/2);
|
||
end;
|
||
|
||
Function MPoint(r:TDoubleRect):TDoublePoint;overload;
|
||
begin
|
||
Result := MPoint(DoublePoint(r.Left,r.top),DoublePoint(r.right,r.bottom));
|
||
end;
|
||
|
||
Function MPoint(p1,p2:TDoublePoint;Step:Integer):TDoublePoint;
|
||
var i: Integer;
|
||
begin
|
||
result := p2;
|
||
for i := 1 to step do
|
||
begin
|
||
Result := DoublePoint((p1.x+result.x)/2,(p1.y+result.y)/2,(p1.z+result.z)/2);
|
||
end;
|
||
end;
|
||
|
||
Function FindGroundPoint(xp1,xp2:TDoublePoint;gLevel: Double):TDoublePoint;
|
||
var dz,dl: Double;
|
||
z2,l2: Double;
|
||
|
||
begin
|
||
if EQDP(xp1,xp2) then begin
|
||
result:= DoublePoint(xp1,gLevel);
|
||
end else begin
|
||
dz := abs(xp1.z-xp2.z);
|
||
z2:= abs(gLevel-xp2.z);
|
||
dl := GetLineLenght(xp1,xp2);
|
||
l2 := (z2*dl)/dz;
|
||
result := MPoint(xp2,xp1,l2);
|
||
result.z := gLevel;
|
||
end;
|
||
end;
|
||
|
||
Function GetRightPointIndex(p1,p2,eye:TDoublePoint):Integer;
|
||
var ep: TDoublePOint;
|
||
rad,rRad: Double;
|
||
xp1,xp2: TDoublePOint;
|
||
begin
|
||
ep := eye;
|
||
PointToLine(p1,p2,ep.x,ep.y);
|
||
rad := GetRadOfline(eye,ep);
|
||
rRad := rad-(3*(pi/2));
|
||
xp1 := RotatePoint(eye,p1,-RRad);
|
||
xp2 := RotatePoint(eye,p2,-RRad);
|
||
if xp1.x > xp2.x then result := 1 else result := 2;
|
||
end;
|
||
|
||
Function PushPoint(p1,p2:TDoublePoint;Delta:Double;var Ended:Boolean):TDoublePoint;
|
||
var l,ratio: Double;
|
||
dl,dz,dx,dy: Double;
|
||
xp1,xp2,xp: TdoublePoint;
|
||
begin
|
||
if EQDP(p1,p2) then begin
|
||
result := p1;
|
||
Ended := True;
|
||
exit;
|
||
end;
|
||
l := GetLineLenght(p1,p2);
|
||
if l < delta then begin
|
||
result := p2;
|
||
Ended := True;
|
||
exit;
|
||
end;
|
||
Ended := False;
|
||
ratio := delta/l;
|
||
Result := DoublePoint(p1.x+(p2.x-p1.x)*ratio,p1.y+(p2.y-p1.y)*ratio,p1.z+(p2.z-p1.z)*ratio);
|
||
end;
|
||
|
||
|
||
Function MPoint(p1,p2:TDoublePoint;Delta:Double;Planer:Boolean = True):TDoublePoint;
|
||
var l,ratio: Double;
|
||
dl,dz,dx,dy: Double;
|
||
xp1,xp2,xp: TdoublePoint;
|
||
tanA: Double;
|
||
a,z: Double;
|
||
begin
|
||
if EQDP(p1,p2) and planer then
|
||
begin
|
||
result := p1;
|
||
exit;
|
||
end;
|
||
if EQD(p1.z,p2.z) or Planer then
|
||
begin
|
||
l := GetLineLenght(p1,p2);
|
||
ratio := delta/l;
|
||
Result := DoublePoint(p1.x+(p2.x-p1.x)*ratio,p1.y+(p2.y-p1.y)*ratio,p1.z+(p2.z-p1.z)*ratio);
|
||
end
|
||
else
|
||
begin
|
||
xp1 := DoublePoint(p1.x,p1.y);
|
||
xp2 := DoublePoint(p2.x,p2.y);
|
||
if EQDP(xp1,xp2) then
|
||
begin
|
||
if p2.z > p1.z then
|
||
z := p1.z+delta
|
||
else
|
||
z := p1.z-delta;
|
||
result := DoublePoint(xp1.x,xp1.y,z);
|
||
end
|
||
else
|
||
begin
|
||
dl := GetLineLenght(xp1,xp2);
|
||
dz := abs(p2.z-p1.z);
|
||
tana := dz/dl;
|
||
a := arctan(tanA);
|
||
dx := delta*cos(a);
|
||
dy := delta*sin(a);
|
||
xp := Mpoint(xp1,xp2,dx);
|
||
if p2.z > p1.z then
|
||
z := p1.z+dy
|
||
else
|
||
z := p1.z-dy;
|
||
result := DoublePoint(xp.x,xp.y,z);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
|
||
Function QrPoint(p1,p2:TDoublePoint):TDoublePoint;
|
||
var m: TDoublePOint;
|
||
begin
|
||
m := MPoint(p1,p2);
|
||
result := MPoint(p1,m);
|
||
end;
|
||
|
||
Function MVPoint(p:TDoublePoint;dy:Double):TDoublePoint;
|
||
begin
|
||
Result := DoublePoint(p.x,p.y+dy);
|
||
end;
|
||
|
||
Function MHPoint(p:TDoublePoint;dx:Double):TDoublePoint;
|
||
begin
|
||
Result := DoublePoint(p.x+dx,p.y);
|
||
end;
|
||
|
||
Function MovePoint(p:TDoublePoint;dx,dy:Double):TDoublePoint;
|
||
begin
|
||
Result := DoublePoint(p.x+dx,p.y+dy,p.z);
|
||
end;
|
||
|
||
procedure MovePt(p:PDoublePoint; dx,dy:Double);
|
||
begin
|
||
p^.x := p^.x + dx;
|
||
p^.y := p^.y + dy;
|
||
end;
|
||
|
||
Function MovePointTo(p,dp:TDoublePoint;dx,dy:Double):TDoublePoint;
|
||
begin
|
||
if dp.x < p.x then dx := -dx;
|
||
if dp.y < p.y then dy := -dy;
|
||
result := MovePoint(p,dx,dy);
|
||
end;
|
||
|
||
Function DoubleRect(Left,Top,Right,Bottom:Double):TDoubleRect;
|
||
begin
|
||
Result.Left := Left;
|
||
Result.Top := Top;
|
||
Result.Right := Right;
|
||
Result.Bottom := Bottom;
|
||
end;
|
||
|
||
Function DoubleRect(iRect:Trect):TDoubleRect;
|
||
begin
|
||
Result.Left := iRect.Left;
|
||
Result.Top := iRect.Top;
|
||
Result.Right := iRect.Right;
|
||
Result.Bottom := iRect.Bottom;
|
||
end;
|
||
|
||
Function BetWeen(x,x1,x2:Double):Boolean;
|
||
begin
|
||
result := (x >= Min(x1,x2)) and (x <= Max(x1,x2));
|
||
end;
|
||
|
||
Function FaceOverlaps(f1,f2:TDoublePointArr;freg1,freg2:HRGN):Boolean;
|
||
var pCnt1,pCnt2,i,k,j: Integer;
|
||
xp1,xp2,yp1,yp2,p: TdoublePoint;
|
||
r:Trect;
|
||
begin
|
||
|
||
result := false;
|
||
pCnt1 := Length(f1);
|
||
pCnt2 := Length(f2);
|
||
|
||
for i := 0 to pcnt1-1 do
|
||
begin
|
||
xp1 := f1[i];
|
||
if i = pcnt1-1 then xp2 := f1[0] else xp2 := f1[i+1];
|
||
for k := 0 to pcnt2-1 do
|
||
begin
|
||
yp1 := f2[k];
|
||
if k = pcnt2-1 then yp2 := f2[0] else yp2 := f2[k+1];
|
||
|
||
if GetInterSectionPoint(xp1,xp2,yp1,yp2,p,false) then
|
||
begin
|
||
result := True;
|
||
exit;
|
||
end;
|
||
|
||
end;
|
||
end;
|
||
|
||
GetRgnBox(freg1,r);
|
||
result := RectInRegion(freg2,r);
|
||
end;
|
||
|
||
Function FaceOverlaps(f1,f2:T3DFace):Boolean;
|
||
var ps1,ps2: TDoublePointArr;
|
||
pCnt1,pCnt2,i,k,j: Integer;
|
||
xp1,xp2,yp1,yp2,p: TdoublePoint;
|
||
begin
|
||
result := false;
|
||
pCnt1 := Length(f1);
|
||
SetLength(ps1,pcnt1);
|
||
pCnt2 := Length(f2);
|
||
SetLength(ps2,pcnt2);
|
||
|
||
for i := 0 to pcnt1-1 do ps1[i] := Convert3DPoint(f1[i]);
|
||
for i := 0 to pcnt2-1 do ps2[i] := Convert3DPoint(f2[i]);
|
||
|
||
for i := 0 to pcnt1-1 do
|
||
begin
|
||
xp1 := ps1[i];
|
||
if i = pcnt1-1 then xp2 := ps1[0] else xp2 := ps1[i+1];
|
||
for k := 0 to pcnt2-1 do
|
||
begin
|
||
yp1 := ps2[k];
|
||
if k = pcnt2-1 then yp2 := ps2[0] else yp2 := ps2[k+1];
|
||
|
||
if GetInterSectionPoint(xp1,xp2,yp1,yp2,p,false) then
|
||
begin
|
||
result := True;
|
||
exit;
|
||
end;
|
||
|
||
end;
|
||
end;
|
||
|
||
|
||
end;
|
||
|
||
Function Convert3DPoint(p:T3DPoint;YHeight: Double = 0):TDoublePoint;
|
||
var x,y,z,t: Double;
|
||
xx,yy: Double;
|
||
begin
|
||
y := p.y;
|
||
x := p.x;
|
||
z := p.z;
|
||
if yHeight <> 0 then begin
|
||
//y := YHeight-y;
|
||
end;
|
||
t := tip;
|
||
xx := cos (spin*rd)*x
|
||
+sin(spin*rd)*y+0*z;
|
||
yy := -1*sin(t*rd)*sin(spin*rd)*x
|
||
+ sin(t*rd)*cos(spin*rd)*y
|
||
+ cos(t*rd)*z;
|
||
if yHeight <> 0 then begin
|
||
//yy := YHeight-yy;
|
||
end;
|
||
Result := DoublePoint(xx,yy);
|
||
end;
|
||
|
||
Type
|
||
TCGPlane = record
|
||
A, B, C, D: Single; // Plane equation (Ax + By + Cz + D = 0).
|
||
end;
|
||
TCGVector = record
|
||
x, y, z, w: Single; // Store w for OpenGL compatibility, but keep it 1.
|
||
end;
|
||
|
||
function cgVector(vx, vy, vz: Single): TCGVector;
|
||
begin
|
||
|
||
{ Create a TCGVector at [vx, vy, vz]. }
|
||
with Result do
|
||
begin
|
||
x := vx;
|
||
y := vy;
|
||
z := vz;
|
||
w := 1;
|
||
end;
|
||
|
||
end;
|
||
|
||
procedure cgMirror(var v: TCGVector; mx, my, mz: Boolean);
|
||
begin
|
||
|
||
{ Mirror v around any axis. }
|
||
with v do
|
||
begin
|
||
if mx then x := -x;
|
||
if my then y := -y;
|
||
if mz then z := -z;
|
||
end;
|
||
|
||
end;
|
||
|
||
procedure cgTranslate(var v: TCGVector; t: TCGVector);
|
||
begin
|
||
|
||
{ Translate vector v over vector t. }
|
||
with v do
|
||
begin
|
||
x := x + t.x;
|
||
y := y + t.y;
|
||
z := z + t.z;
|
||
end;
|
||
|
||
end;
|
||
|
||
function cgCrossProduct(v1, v2: TCGVector): TCGVector;
|
||
begin
|
||
|
||
// Return the cross product v1 x v2.
|
||
Result := cgVector(v1.y * v2.z - v2.y * v1.z,
|
||
v2.x * v1.z - v1.x * v2.z,
|
||
v1.x * v2.y - v2.x * v1.y);
|
||
|
||
end;
|
||
|
||
function cgVectorLength(v: TCGVector): Single;
|
||
begin
|
||
|
||
{ Calculate v's length (distance to the origin), using Pythagoras in 3D. }
|
||
Result := sqrt(v.x*v.x + v.y*v.y + v.z*v.z);
|
||
|
||
end;
|
||
|
||
procedure cgNormalize(var v: TCGVector);
|
||
var
|
||
l: Single;
|
||
begin
|
||
|
||
{ Normalize a vector by dividing its components by its length. }
|
||
l := cgVectorLength(v);
|
||
if l <> 0 then
|
||
begin
|
||
with v do
|
||
begin
|
||
x := x / l;
|
||
y := y / l;
|
||
z := z / l;
|
||
end;
|
||
end;
|
||
|
||
end;
|
||
|
||
function cgGetNormal(v1, v2, v3: TCGVector): TCGVector;
|
||
begin
|
||
|
||
// Return the normal vector to the plane defined by v1, v2 and v3.
|
||
cgMirror(v2, TRUE, TRUE, TRUE);
|
||
cgTranslate(v1, v2);
|
||
cgTranslate(v3, v2);
|
||
Result := cgCrossProduct(v1, v3);
|
||
cgNormalize(Result);
|
||
|
||
end;
|
||
|
||
function DistToPlane(p: TCGPlane; v: TCGVector): Single;
|
||
begin
|
||
|
||
// Substitute a point in the plane equation and return the result.
|
||
Result := (p.A*v.x + p.B*v.y + p.C*v.z + p.D);
|
||
|
||
end;
|
||
|
||
function cgPlaneFromPoints(p1, p2, p3: TCGVector): TCGPlane;
|
||
var
|
||
n: TCGVector;
|
||
begin
|
||
|
||
{ Create a TCGPlane from 3 coplanar points. To do this, calculate the normal
|
||
to the plane. The x, y and z components of the normal vector correspond to
|
||
the A, B and C components of the plane. D can then be very easily calculated
|
||
knowing that Ax + By + Cz + D = 0 for any point on the plane, such as p1. }
|
||
n := cgGetNormal(p1, p2, p3);
|
||
with Result do
|
||
begin
|
||
A := n.x;
|
||
B := n.y;
|
||
C := n.z;
|
||
D := -(A * p1.x + B * p1.y + c * p1.z);
|
||
end;
|
||
|
||
end;
|
||
|
||
|
||
|
||
|
||
Function PosToPlane(P:TCGPlane; v:TCGVector):Integer;overload;
|
||
var d: Double;
|
||
begin
|
||
d := DistToPlane(p, v);
|
||
result := 0;
|
||
if d > 0 then result := 1
|
||
else if d < 0 then result := -1;
|
||
end;
|
||
|
||
Function PosToPlane(P:TCGPlane; vArr: array of TCGVector):Integer;overload;
|
||
var d: Double;
|
||
i: Integer;
|
||
pCnt,nCnt: Integer;
|
||
begin
|
||
result := 0;
|
||
pCnt := 0;
|
||
nCnt := 0;
|
||
for i := 0 to Length(vArr) -1 do
|
||
begin
|
||
d := DistToPlane(p,vArr[i]);
|
||
if d > 0 then inc(pCnt)
|
||
else if d < 0 then inc(nCnt);
|
||
end;
|
||
if pCnt > nCnt then result := 1
|
||
else if pCnt < nCnt then result := -1;
|
||
end;
|
||
|
||
Function GetCloserFace(f1,f2:T3DFace;Camera:T3DPoint):Integer;
|
||
var p1,p2: TCGPlane;
|
||
v1,v2,v3,vcam: TCGVector;
|
||
d1,dc: Integer;
|
||
vArr: array of TCGVector;
|
||
begin
|
||
v1 := cgVector(f1[0].x,f1[0].y,f1[0].z);
|
||
v2 := cgVector(f1[1].x,f1[1].y,f1[1].z);
|
||
v3 := cgVector(f1[2].x,f1[2].y,f1[2].z);
|
||
p1 := cgPlaneFromPoints(v1,v2,v3);
|
||
setLength(vArr,3);
|
||
vArr[0] := v1; vArr[1] := v2; vArr[2] := v3;
|
||
v1 := cgVector(f2[0].x,f2[0].y,f2[0].z);
|
||
v2 := cgVector(f2[1].x,f2[1].y,f2[1].z);
|
||
v3 := cgVector(f2[2].x,f2[2].y,f2[2].z);
|
||
p2 := cgPlaneFromPoints(v1,v2,v3);
|
||
vCam := cgVector(Camera.x,Camera.y,Camera.z);
|
||
d1 := PosToPlane(p2,vArr);
|
||
dc := PosToPlane(p2,vCam);
|
||
if d1 = dc then result := 1
|
||
else result := 2;
|
||
setLength(vArr, 0); // Tolik 21/05/2018 - -
|
||
end;
|
||
(*
|
||
function InFrontOf(p1, p2: TTriangle): Integer;
|
||
var
|
||
pos, neg: Integer;
|
||
plane: TCGPlane;
|
||
i: Integer;
|
||
d: Single;
|
||
begin
|
||
|
||
// Test if triangle p1 is in front of p2.
|
||
plane := cgPlaneFromPoints(p2[0], p2[1], p2[2]);
|
||
pos := 0;
|
||
neg := 0;
|
||
for i := 0 to 2 do
|
||
begin
|
||
d := DistToPlane(plane, p1[i]);
|
||
if d < 0 then INC(neg)
|
||
else INC(pos);
|
||
end;
|
||
if pos = 3 then Result := 1
|
||
else if neg = 3 then Result := -1
|
||
else Result := 0;
|
||
|
||
end;
|
||
*)
|
||
(*
|
||
Function GetCloserFace(f1,f2:T3DFace;Camera:T3DPoint):Integer;
|
||
var d1,d2,d,dz,dMax:Double;
|
||
i: Integer;
|
||
cz: Double;
|
||
cp: TdoublePoint;
|
||
xp: TDoublePoint;
|
||
dz1,dz2: Double;
|
||
ep1,ep2: TDoublePoint;
|
||
mp1,mp2: TdoublePoint;
|
||
a1,a2,ca: Double;
|
||
begin
|
||
result := 0;
|
||
cz := Camera.z;
|
||
for i := 0 to Length(f1)-1 do begin
|
||
xp := DoublePoint(f1[i].x,f1[i].y);
|
||
cp := DoublePoint(Camera.x,Camera.y);
|
||
d := GetLineLenght(xp,cp);
|
||
dz := abs(cz- f1[i].z);
|
||
if i = 0 then begin
|
||
d1 := d;
|
||
dz1 := dz;
|
||
ep1 := xp;
|
||
mp1 := xp;
|
||
dMax := d;
|
||
end else begin
|
||
if d < d1 then begin
|
||
d1 := d;
|
||
ep1 := xp;
|
||
end;
|
||
if d > DMax then begin
|
||
dMax := d;
|
||
mp1 := xp;
|
||
end;
|
||
if dz < dz1 then dz1 := d;
|
||
end;
|
||
end;
|
||
for i := 0 to Length(f2)-1 do begin
|
||
xp := DoublePoint(f2[i].x,f2[i].y);
|
||
cp := DoublePoint(Camera.x,Camera.y);
|
||
d := GetLineLenght(xp,cp);
|
||
dz := abs(cz- f2[i].z);
|
||
|
||
if i = 0 then begin
|
||
d2 := d;
|
||
dz2 := dz;
|
||
ep2 := xp;
|
||
mp2 := xp;
|
||
dMax := d;
|
||
end else begin
|
||
if d < d2 then begin
|
||
d2 := d;
|
||
ep2 := xp;
|
||
end;
|
||
if d > dMax then begin
|
||
dMax := d;
|
||
mp2 := xp;
|
||
end;
|
||
if dz < dz2 then dz2:= d;
|
||
end;
|
||
end;
|
||
if dz1 < dz2 then result := 1 else if dz2 < dz1 then result := 2;
|
||
if result = 0 then begin
|
||
if d1 < d2 then result := 1 else if d2 < d1 then result := 2;
|
||
end;
|
||
if result = 0 then begin
|
||
a1 := GetRadOfLine(ep1,mp1);
|
||
a2 := GetRadOfLine(ep1,mp2);
|
||
ca := GetRadOfLine(ep1,cp);
|
||
if angleDist(a1,ca) < angleDist(a2,ca) then result := 1 else result := 2;
|
||
end;
|
||
end;
|
||
*)
|
||
Function GetCameraPos(cPoint,oPoint:T3DPoint; HorzAngle,VertAngle:Double):T3DPoint;
|
||
var ha,va,dx,dy: Double;
|
||
op: TdoublePOint;
|
||
cp: TdoublePOint;
|
||
xp: TdoublePOint;
|
||
begin
|
||
//if HorzAngle = 0 then ha := 0 else ha := 2*pi-HorzAngle;
|
||
ha := HorzAngle;
|
||
//va := 2*pi-VertAngle;
|
||
//va := (pi-VertAngle);
|
||
va := VertAngle;
|
||
cp := DoublePoint(cPoint.x,cPoint.y);
|
||
xp := DoublePoint(oPoint.x,oPoint.y);
|
||
xp := RotatePoint(cp,xp,ha);
|
||
|
||
oPoint.x := xp.x;
|
||
oPoint.y := xp.y;
|
||
if va <> 0 then
|
||
begin
|
||
op := DoublePoint(oPoint.x,oPoint.y);
|
||
dx := GetLineLenght(cp, op);
|
||
dy := oPoint.z - cPoint.z;
|
||
xp := RotatePoint(DoublePoint(0,0),DoublePoint(dx,dy),va);
|
||
oPoint.z := opoint.z+xp.y;
|
||
xp := Mpoint(op,cp,dx-xp.x);
|
||
oPoint.x := xp.x;
|
||
oPoint.y := xp.y;
|
||
end;
|
||
result := opoint;
|
||
end;
|
||
|
||
procedure setupPixelFormat(DC:HDC);
|
||
const
|
||
pfd:TPIXELFORMATDESCRIPTOR = (
|
||
nSize:sizeof(TPIXELFORMATDESCRIPTOR); // size
|
||
nVersion:1; // version
|
||
dwFlags:PFD_SUPPORT_OPENGL or PFD_DRAW_TO_WINDOW or
|
||
PFD_DOUBLEBUFFER; // support double-buffering
|
||
iPixelType:PFD_TYPE_RGBA; // color type
|
||
cColorBits:24; // preferred color depth
|
||
cRedBits:0; cRedShift:0; // color bits (ignored)
|
||
cGreenBits:0; cGreenShift:0;
|
||
cBlueBits:0; cBlueShift:0;
|
||
cAlphaBits:0; cAlphaShift:0; // no alpha buffer
|
||
cAccumBits: 0;
|
||
cAccumRedBits: 0; // no accumulation buffer,
|
||
cAccumGreenBits: 0; // accum bits (ignored)
|
||
cAccumBlueBits: 0;
|
||
cAccumAlphaBits: 0;
|
||
cDepthBits:16; // depth buffer
|
||
cStencilBits:0; // no stencil buffer
|
||
cAuxBuffers:0; // no auxiliary buffers
|
||
iLayerType:PFD_MAIN_PLANE; // main layer
|
||
bReserved: 0;
|
||
dwLayerMask: 0;
|
||
dwVisibleMask: 0;
|
||
dwDamageMask: 0; // no layer, visible, damage masks
|
||
);
|
||
|
||
var
|
||
pixelFormat:integer;
|
||
|
||
begin
|
||
pixelFormat := ChoosePixelFormat(DC, @pfd);
|
||
if (pixelFormat = 0) then
|
||
exit;
|
||
if (SetPixelFormat(DC, pixelFormat, @pfd) <> TRUE) then
|
||
exit;
|
||
end;
|
||
|
||
|
||
Function Make5Face(p1,p2,p3,p4,p5:T3DPoint):T3DFace;
|
||
begin
|
||
SetLength(result,5);
|
||
result[0] := p1;
|
||
result[1] := p2;
|
||
result[2] := p3;
|
||
result[3] := p4;
|
||
result[4] := p5;
|
||
end;
|
||
|
||
Function Make4Face(p1,p2,p3,p4:T3DPoint):T3DFace;
|
||
begin
|
||
SetLength(result,4);
|
||
result[0] := p1;
|
||
result[1] := p2;
|
||
result[2] := p3;
|
||
result[3] := p4;
|
||
end;
|
||
|
||
Function Make4FaceMar(p1,p2,p3,p4:T3DPoint;Mar:Double):T3DFace;
|
||
var s1,s2,s3,s4: TDoublePoint;
|
||
d1z,d2z: Double;
|
||
begin
|
||
s1 := DoublePOint(p1.x,p1.y);
|
||
s2 := DoublePOint(p2.x,p2.y);
|
||
s3 := DoublePOint(p3.x,p3.y);
|
||
s4 := DoublePOint(p4.x,p4.y);
|
||
|
||
if (p1.z = p2.z) and (p1.z = p3.z) and (p1.z = p4.z) then begin
|
||
s1 := MPoint(s1,s2,Mar);
|
||
s2 := MPoint(s2,s1,Mar);
|
||
s3 := MPoint(s3,s4,Mar);
|
||
s4 := MPoint(s4,s3,Mar);
|
||
s1 := MPoint(s1,s4,Mar);
|
||
s4 := MPoint(s4,s1,Mar);
|
||
s2 := MPoint(s2,s3,Mar);
|
||
s3 := MPoint(s3,s2,Mar);
|
||
p1 := DoublePoint(s1,p1.z);
|
||
p2 := DoublePoint(s2,p2.z);
|
||
p3 := DoublePoint(s3,p3.z);
|
||
p4 := DoublePoint(s4,p4.z);
|
||
end else begin
|
||
if p1.z > p4.z then
|
||
begin
|
||
d1z := -mar;
|
||
d2z := +mar;
|
||
end else begin
|
||
d1z := -mar;
|
||
d2z := +mar;
|
||
end;
|
||
s1 := MPoint(s1,s2,Mar);
|
||
s2 := MPoint(s2,s1,Mar);
|
||
s3 := MPoint(s3,s4,Mar);
|
||
s4 := MPoint(s4,s3,Mar);
|
||
p1 := DoublePoint(s1,p1.z+d1z);
|
||
p2 := DoublePoint(s2,p2.z+d1z);
|
||
p3 := DoublePoint(s3,p3.z+d2z);
|
||
p4 := DoublePoint(s4,p4.z+d2z);
|
||
end;
|
||
|
||
SetLength(result,4);
|
||
result[0] := p1;
|
||
result[1] := p2;
|
||
result[2] := p3;
|
||
result[3] := p4;
|
||
end;
|
||
|
||
|
||
Function Make3Face(p1,p2,p3:T3DPoint):T3DFace;
|
||
begin
|
||
SetLength(result,3);
|
||
result[0] := p1;
|
||
result[1] := p2;
|
||
result[2] := p3;
|
||
end;
|
||
|
||
Function Make2Face(p1,p2:T3DPoint):T3DFace;
|
||
begin
|
||
SetLength(result,2);
|
||
result[0] := p1;
|
||
result[1] := p2;
|
||
end;
|
||
|
||
Procedure GetFaceDraw(Face:T3DFace;var pArr:TdoublePointArr);
|
||
var pCnt,i: Integer;
|
||
|
||
begin
|
||
pCnt := Length(Face);
|
||
SetLength(pArr,pCnt);
|
||
For i := 0 to pCnt-1 do
|
||
pArr[i] := Convert3DPoint(Face[i]);
|
||
end;
|
||
|
||
Function ConvertIsometricPoint(p:TDoublePoint;h,izalfa:Double;isoType:Byte=0):TDoublePoint;
|
||
var x,y,z,izbeta: Double;
|
||
begin
|
||
|
||
x := p.x;
|
||
y := p.y;
|
||
z := p.z;
|
||
y := h - y;
|
||
|
||
if isoType = 0 then begin
|
||
x := x + (y* cos(izalfa));
|
||
y := z + (y* sin(izalfa));
|
||
end else if isoType = 1 then begin
|
||
x := x*cos(izalfa)-y*cos(izalfa);
|
||
y := p.x*sin(izalfa)+y*sin(izalfa)+z;
|
||
end else if isoType = 2 then begin
|
||
izbeta := pi/2 - izalfa;
|
||
x := x*cos(izBeta)-y*cos(izalfa);
|
||
y := p.x*sin(izBeta)+y*sin(izalfa)+z;
|
||
end else if isoType = 3 then begin
|
||
p := DoublepOint(x,y);
|
||
p := RotatePoint(DoublePoint(0,0),p,izAlfa);
|
||
x := p.x;
|
||
y := p.y+z;
|
||
end;
|
||
|
||
y := h - y;
|
||
result:= DoublePoint(x,y);
|
||
end;
|
||
|
||
Function DeConvertIsometricPoint(p:TDoublePoint;h,izalfa:Double;isoType:Byte=0):TDoublePoint;
|
||
var x,y,z: Double;
|
||
begin
|
||
x := p.x;
|
||
y := p.y;
|
||
z := p.z;
|
||
|
||
y := h-y;
|
||
y := y-z;
|
||
y := y / sin(izalfa);
|
||
y := h-y;
|
||
x := x - ((h-y)*cos(izalfa));
|
||
result := DoublePoint(x,y,z);
|
||
end;
|
||
|
||
Function Rotate3DPoint(cPOint,oPoint:T3DPoint; Ang:Double;axis:T3DAxis):T3DPoint;
|
||
var osp:T3DPoint;
|
||
op,cp: TdoublePoint;
|
||
opv,cpv: TdoublePoint;
|
||
lx,nz,nh,nx,ny: Double;
|
||
begin
|
||
if EqD(Ang,0) then Ang := 0;
|
||
|
||
//Move System To Origin
|
||
osp.x := oPoint.x - CPoint.x;
|
||
osp.y := oPoint.y - CPoint.y;
|
||
osp.z := oPoint.z - Cpoint.z;
|
||
|
||
// Rotating Around Origin Axis Now
|
||
|
||
Case axis of
|
||
aZ: begin
|
||
nz := osp.z;
|
||
nx := osp.x * cos(ang) - osp.y*sin(ang);
|
||
ny := osp.x * sin(ang) + osp.y*cos(ang);
|
||
end;
|
||
aX: begin
|
||
nx := osp.x;
|
||
ny := osp.z * cos(ang) - osp.y*sin(ang);
|
||
nz := osp.z * sin(ang) + osp.y*cos(ang);
|
||
end;
|
||
aY: begin
|
||
ny := osp.y;
|
||
nx := osp.x * cos(ang) - osp.z*sin(ang);
|
||
nz := osp.x * sin(ang) + osp.z*cos(ang);
|
||
end;
|
||
end;
|
||
if EQD(nx,0) then nx := 0;
|
||
if EQD(ny,0) then ny := 0;
|
||
if EQD(nz,0) then nz := 0;
|
||
|
||
nx := nx + CPoint.x;
|
||
ny := ny + CPoint.y;
|
||
nz := nz + CPoint.z;
|
||
result := DoublePoint(nx,ny,nz);
|
||
end;
|
||
|
||
Function RectOverlaps(r1,r2:TDoubleRect):Boolean;
|
||
var t,b,l,r:Double;
|
||
p1,p2,p3,p4:TDoublePoint;
|
||
t1,t2,t3,t4:TDoublePoint;
|
||
|
||
Function CrossIntersect(a1,a2,b1,b2:TDoublePoint):Boolean;
|
||
var x,y: Double;
|
||
vP,hp:TdoublePoint;
|
||
xOk,yOk:Boolean;
|
||
begin
|
||
Result := False;
|
||
if a1.x = a2.x then begin
|
||
xOk := Between(a1.x,b1.x,b2.x);
|
||
end else if b1.x = b2.x then begin
|
||
xOk := Between(b1.x,a1.x,a2.x);
|
||
end else exit;
|
||
|
||
if a1.y = a2.y then begin
|
||
yOk := Between(a1.y,b1.y,b2.y);
|
||
end else if b1.y = b2.y then begin
|
||
yOk := Between(b1.y,a1.y,a2.y);
|
||
end else exit;
|
||
|
||
result := xOk and yOk;
|
||
|
||
|
||
end;
|
||
|
||
begin
|
||
t := Min(r1.Top,r1.Bottom);
|
||
b := Max(r1.Top,r1.Bottom);
|
||
l := Min(r1.Left,r1.Right);
|
||
r := Max(r1.Left,r1.Right);
|
||
p1 := DoublePoint(r2.Left,r2.Top);
|
||
p2 := DoublePoint(r2.right,r2.Top);
|
||
p3 := DoublePoint(r2.Left,r2.Bottom);
|
||
p4 := DoublePoint(r2.right,r2.Bottom);
|
||
result := false;
|
||
if (p1.x >= l) and (p1.x <= r) and (p1.y >= t) and (p1.y <= b) then begin
|
||
result := true;
|
||
end else if (p1.x >= l) and (p1.x <= r) and (p1.y >= t) and (p1.y <= b) then begin
|
||
result := true;
|
||
end else if (p1.x >= l) and (p1.x <= r) and (p1.y >= t) and (p1.y <= b) then begin
|
||
result := true;
|
||
end else if (p1.x >= l) and (p1.x <= r) and (p1.y >= t) and (p1.y <= b) then begin
|
||
result := true;
|
||
end;
|
||
|
||
if not result then begin
|
||
t := Min(r2.Top,r2.Bottom);
|
||
b := Max(r2.Top,r2.Bottom);
|
||
l := Min(r2.Left,r2.Right);
|
||
r := Max(r2.Left,r2.Right);
|
||
p1 := DoublePoint(r1.Left,r1.Top);
|
||
p2 := DoublePoint(r1.right,r1.Top);
|
||
p3 := DoublePoint(r1.Left,r1.Bottom);
|
||
p4 := DoublePoint(r1.right,r1.Bottom);
|
||
result := false;
|
||
if (p1.x >= l) and (p1.x <= r) and (p1.y >= t) and (p1.y <= b) then begin
|
||
result := true;
|
||
end else if (p1.x >= l) and (p1.x <= r) and (p1.y >= t) and (p1.y <= b) then begin
|
||
result := true;
|
||
end else if (p1.x >= l) and (p1.x <= r) and (p1.y >= t) and (p1.y <= b) then begin
|
||
result := true;
|
||
end else if (p1.x >= l) and (p1.x <= r) and (p1.y >= t) and (p1.y <= b) then begin
|
||
result := true;
|
||
end;
|
||
end;
|
||
|
||
if not result then begin
|
||
p1 := DoublePoint(r1.Left,r1.Top);
|
||
p2 := DoublePoint(r1.right,r1.Top);
|
||
p3 := DoublePoint(r1.right,r1.Bottom);
|
||
p4 := DoublePoint(r1.Left,r1.Bottom);
|
||
t1 := DoublePoint(r2.Left,r2.Top);
|
||
t2 := DoublePoint(r2.right,r2.Top);
|
||
t3 := DoublePoint(r2.right,r2.Bottom);
|
||
t4 := DoublePoint(r2.Left,r2.Bottom);
|
||
|
||
if CrossIntersect(p1,p2,t1,t4) then result := true
|
||
else if CrossIntersect(p1,p2,t2,t3) then result := true
|
||
else if CrossIntersect(p4,p3,t1,t4) then result := true
|
||
else if CrossIntersect(p4,p3,t2,t3) then result := true
|
||
else if CrossIntersect(p1,p4,t1,t2) then result := true
|
||
else if CrossIntersect(p1,p4,t4,t3) then result := true
|
||
else if CrossIntersect(p2,p3,t1,t2) then result := true
|
||
else if CrossIntersect(p2,p3,t4,t4) then result := true;
|
||
end;
|
||
|
||
end;
|
||
|
||
Function DP2P(pt:TDoublepoint):TPoint;overload;
|
||
begin
|
||
result := Point(round(pt.x),round(pt.y));
|
||
end;
|
||
|
||
Function DP2P(ptx,pty:Double):TPoint;overload;
|
||
begin
|
||
result := Point(round(ptx),round(pty));
|
||
end;
|
||
|
||
Function DR2R(x1,y1,x2,y2:Double):Trect;overload;
|
||
begin
|
||
result := Rect(round(x1),round(y1),round(x2),round(y2));
|
||
end;
|
||
|
||
Function DR2R(r:TDoubleRect):Trect;overload;
|
||
begin
|
||
result := Rect(round(r.left),round(r.top),round(r.right),round(r.bottom));
|
||
end;
|
||
|
||
Function EQDP(p1,p2: TDoublePoint):Boolean; //<2F><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><> <20><><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD> <20> 2D. TRUE - <20><><EFBFBD><EFBFBD><EFBFBD>, FALSE - <20><> <20><><EFBFBD><EFBFBD><EFBFBD>
|
||
begin
|
||
result := (abs(p1.x - p2.x) < (1/50)) and (abs(p1.y - p2.y) < (1/50));
|
||
end;
|
||
|
||
Function EQDPZ(p1,p2: TDoublePoint):Boolean; //<2F><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><> <20><><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD> <20> 3D. TRUE - <20><><EFBFBD><EFBFBD><EFBFBD>, FALSE - <20><> <20><><EFBFBD><EFBFBD><EFBFBD>
|
||
begin
|
||
result := (abs(p1.x - p2.x) < (1/50)) and (abs(p1.y - p2.y) < (1/50)) and (abs(p1.z - p2.z) < (1/50));
|
||
end;
|
||
|
||
Function EQD(a1,a2: Double):Boolean;
|
||
begin
|
||
result := (abs(a1 - a2) < (1/1000));
|
||
end;
|
||
|
||
Function Sign(number:Double):Integer;
|
||
begin
|
||
if number = 0 then result := 0
|
||
else if number >0 then result := 1
|
||
else if number < 0 then result := -1;
|
||
end;
|
||
Function NormalizePoint(p:TDoublePoint):TDoublePoint;
|
||
begin
|
||
result := DoublePoint( Trunc(p.x * 10000)/10000,
|
||
Trunc(p.y * 10000)/10000);
|
||
end;
|
||
|
||
Function ParseCommand(Command: String; var StrArray: TStringArray):integer;
|
||
var CommandLen,paramLen: integer;
|
||
i,j,k: integer;
|
||
c: string;
|
||
root,param,params: string;
|
||
isExit : Boolean;
|
||
paramcount : integer;
|
||
begin
|
||
CommandLen := Length(Command);
|
||
if commandlen > 0 then
|
||
begin
|
||
root := '';
|
||
isExit := False;
|
||
i := 0;
|
||
repeat
|
||
i := i + 1;
|
||
c := Copy(Command,i,1);
|
||
if c <> ' ' then
|
||
root := root + c
|
||
else
|
||
isExit := true;
|
||
until (IsExit) or (i = CommandLen);
|
||
SetLength(strArray,1);
|
||
StrArray[0] := root;
|
||
|
||
/// look at the parameters
|
||
|
||
if CommandLen > i then
|
||
params := copy(command,i+1,CommandLen-(i))
|
||
else
|
||
begin
|
||
params := '';
|
||
result := 0;
|
||
end;
|
||
|
||
if params <> '' then
|
||
begin
|
||
ParamLen := Length(params);
|
||
param := '';
|
||
paramcount := 0;
|
||
for k := 1 to ParamLen do
|
||
begin
|
||
c := copy(params,k,1);
|
||
if (c = ',') or (c = ' ') then
|
||
begin
|
||
inc(paramcount);
|
||
SetLength(strArray,paramcount+1);
|
||
strArray[paramCount] := param;
|
||
param := '';
|
||
end
|
||
else
|
||
param := param + c;
|
||
end;
|
||
if param <> '' then
|
||
begin
|
||
inc(paramcount);
|
||
SetLength(strArray,paramcount+1);
|
||
strArray[paramCount] := param;
|
||
end;
|
||
result := paramcount;
|
||
end;
|
||
end
|
||
else
|
||
result := -1;
|
||
end;
|
||
|
||
(*
|
||
Function GetBezierPolyPoints(var polypoints: array of TPoint;
|
||
bezPoints: array of TPoint;
|
||
PointCount:integer;
|
||
DEngine:Pointer):integer;
|
||
var a,b:integer;
|
||
tx,px,py : real;
|
||
ipx,ipy: integer;
|
||
t : array[1..4] of real;
|
||
mcol,mrow,pIdx: integer;
|
||
pntx,pnty: array[1..4] of integer;
|
||
DrawEng:TPCDrawEngine;
|
||
begin
|
||
pIdx := 0;
|
||
if DEngine <> nil then
|
||
DrawEng := TPCDrawEngine(DEngine)
|
||
else
|
||
DrawEng := nil;
|
||
for b := 1 to ((PointCount-1) div 3) do begin
|
||
pntx[1] := bezPoints[((b-1)*3)+0].x;
|
||
pntx[2] := bezPoints[((b-1)*3)+1].x;
|
||
pntx[3] := bezPoints[((b-1)*3)+2].x;
|
||
pntx[4] := bezPoints[((b-1)*3)+3].x;
|
||
pnty[1] := bezPoints[((b-1)*3)+0].y;
|
||
pnty[2] := bezPoints[((b-1)*3)+1].y;
|
||
pnty[3] := bezPoints[((b-1)*3)+2].y;
|
||
pnty[4] := bezPoints[((b-1)*3)+3].y;
|
||
for a := 0 to 100 do
|
||
begin
|
||
tx := a / 100;
|
||
t[1] := tx*tx*tx;
|
||
t[2] := tx*tx;
|
||
t[3] := tx;
|
||
t[4] := 1;
|
||
px := 0;
|
||
py := 0;
|
||
for mcol := 1 to 4 do begin
|
||
for mrow := 1 to 4 do begin
|
||
px := px + mval[mrow,mcol]* t[mrow]*pntx[mcol];
|
||
py := py + mval[mrow,mcol]* t[mrow]*pnty[mcol];
|
||
end;
|
||
end;
|
||
ipx := Round(px);
|
||
ipy := Round(py);
|
||
if DrawEng <> nil then DrawEng.ConvertPoint(ipx,ipy);
|
||
polyPoints[pIdx].x := ipx;
|
||
polyPoints[pIdx].y := ipy;
|
||
inc(pIdx);
|
||
end;
|
||
end;
|
||
result := pIdx;
|
||
end;
|
||
*)
|
||
|
||
Function GetBezierDistance(p0,p1,p2,p3,p4:TDoublePoint):Real;
|
||
var res: Integer;
|
||
i: integer;
|
||
dp: TDoublePoint;
|
||
dist,mdist : double;
|
||
x,y,dx,dy: double;
|
||
begin
|
||
res := 500;
|
||
x := p0.x;
|
||
y := p0.y;
|
||
|
||
dp := GetBezierSample(p1,p2,p3,p4,0,res);
|
||
dx := dp.x-x; dy := dp.y - y;
|
||
mdist := sqrt(dx*dx+dy*dy);
|
||
for i := 0 to res do
|
||
begin
|
||
dp := GetBezierSample(p1,p2,p3,p4,i,res);
|
||
dx := dp.x-x; dy := dp.y - y;
|
||
dist := sqrt(dx*dx+dy*dy);
|
||
if dist < mdist then mdist := dist;
|
||
end;
|
||
result := mdist;
|
||
end;
|
||
|
||
Function GetLinePatch(p1,p2:TDoublePoint;pWidth: Double;var cumWidth: Double;
|
||
var pi,pf:TDoublePoint):Double;
|
||
var hy,hx,nx,ny,len: double;
|
||
s : Integer;
|
||
begin
|
||
if (p1.x = p2.x) and (p1.y = p2.y) then begin
|
||
|
||
end else if p1.x = p2.x then begin
|
||
if p2.y > p1.y then s := 1 else s := -1;
|
||
pf := DoublePoint(pi.x,pi.y+(s)*pWidth);
|
||
end else if p1.y = p2.y then begin
|
||
if p2.x > p1.x then s := 1 else s := -1;
|
||
pf := DoublePoint(pi.x+(s)*pWidth,pi.y);
|
||
end else begin
|
||
if cumwidth = 0 then
|
||
begin
|
||
len := GetLineLenght(p1,p2);
|
||
hy := len/(p2.y-p1.y);
|
||
hx := len/(p2.x-p1.x);
|
||
end else begin
|
||
hy := cumWidth / (pi.y-p1.y);
|
||
hx := cumWidth / (pi.x-p1.x);
|
||
end;
|
||
nx := (cumWidth+pWidth) / hx;
|
||
ny := (cumWidth+pWidth) / hy;
|
||
pf.x := p1.x+nx;
|
||
pf.y := p1.y+ny;
|
||
cumWidth := cumWidth+pWidth;
|
||
end;
|
||
result := pWidth;
|
||
end;
|
||
|
||
|
||
Function GetBezierPatch(p1,p2,p3,p4:TDoublePoint;pWidth:Double;
|
||
var LastIndex: Integer; var pi,pf:TDoublePoint;ToEnd:Boolean;res: Integer):Double;
|
||
var x,y,i,sIdx: integer;
|
||
dp: TDoublePoint;
|
||
dist : double;
|
||
dx,dy: double;
|
||
begin
|
||
sIdx := LastIndex;
|
||
for i := sIdx to res do
|
||
begin
|
||
dp := GetBezierSample(p1,p2,p3,p4,i,res);
|
||
if i = sIdx then
|
||
pi := dp
|
||
else begin
|
||
dx := dp.x-pi.x; dy := dp.y - pi.y;
|
||
dist := sqrt(dx*dx+dy*dy);
|
||
if (not toEnd) and (dist >= pWidth) then
|
||
begin
|
||
LastIndex := i;
|
||
pf := dp;
|
||
Result := Round(dist);
|
||
Exit;
|
||
end;
|
||
end;
|
||
end;
|
||
LastIndex := res;
|
||
pf := dp;
|
||
Result := Dist;
|
||
end;
|
||
|
||
Function GetBezierBegin(p1,p2,p3,p4:TDoublePoint;pWidth: Double;res: Integer):TDoublePoint;
|
||
var i: integer;
|
||
dp,pi: TDoublePoint;
|
||
dist : double;
|
||
dx,dy: double;
|
||
begin
|
||
Result := p1;
|
||
for i := 0 to res do
|
||
begin
|
||
dp := GetBezierSample(p1,p2,p3,p4,i,res);
|
||
if i = 0 then pi := dp;
|
||
dx := dp.x-pi.x; dy := dp.y - pi.y;
|
||
dist := sqrt(dx*dx+dy*dy);
|
||
if (dist >= pWidth) then
|
||
begin
|
||
Result := dp;
|
||
Exit;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
Function GetBezierEnd(p1,p2,p3,p4:TDoublePoint; pWidth: Double;res: Integer):TDoublePoint;
|
||
var i: integer;
|
||
dp,pi: TDoublePoint;
|
||
dist : double;
|
||
dx,dy: double;
|
||
begin
|
||
Result := p1;
|
||
for i := res downto 0 do
|
||
begin
|
||
dp := GetBezierSample(p1,p2,p3,p4,i,res);
|
||
if i = res then pi := dp;
|
||
dx := dp.x-pi.x; dy := dp.y - pi.y;
|
||
dist := sqrt(dx*dx+dy*dy);
|
||
if (dist >= pWidth) then
|
||
begin
|
||
Result := dp;
|
||
Exit;
|
||
end;
|
||
end;
|
||
end;
|
||
//Tolik 25/03/2019
|
||
Function ReadStringFromStream(stream:TStream):String;
|
||
var xByte: Byte;
|
||
res:string;
|
||
TempStr: AnsiString;
|
||
cnt: Integer;
|
||
begin
|
||
xByte := 0;
|
||
res := '';
|
||
cnt := 0;
|
||
TempStr := '';
|
||
repeat
|
||
stream.Read(xByte,1);
|
||
//if xByte <> 0 then res := res+ chr(xByte);
|
||
if xByte <> 0 then TempStr := TempStr + AnsiChar(xByte);
|
||
cnt := cnt + 1;
|
||
if cnt = 15000 then begin
|
||
xByte := 0;
|
||
TempStr := 'LONG STRING';
|
||
end;
|
||
until xByte = 0;
|
||
//result := res;
|
||
result := String(TempStr);
|
||
end;
|
||
{
|
||
Function ReadStringFromStream(stream:TStream):String;
|
||
var xByte: Byte;
|
||
res:string;
|
||
cnt: Integer;
|
||
begin
|
||
xByte := 0;
|
||
res := '';
|
||
cnt := 0;
|
||
repeat
|
||
stream.Read(xByte,1);
|
||
if xByte <> 0 then res := res+ chr(xByte);
|
||
cnt := cnt+1;
|
||
if cnt = 15000 then begin
|
||
xByte := 0;
|
||
res := 'LONG STRING';
|
||
end;
|
||
until xByte = 0;
|
||
result := res;
|
||
end;
|
||
}
|
||
|
||
Procedure WriteString(Stream:TStream; Str:string);
|
||
var xByte: Byte;
|
||
TempStr: AnsiString;
|
||
begin
|
||
xByte := 0;
|
||
TempStr := AnsiString(Str);
|
||
//Stream.Write(pchar(str)^,length(str));
|
||
Stream.Write(PAnsiChar(TempStr)^,length(TempStr));
|
||
Stream.Write(xByte,1);
|
||
end;
|
||
{
|
||
Procedure WriteString(Stream:TStream; str:string);
|
||
var xByte: Byte;
|
||
begin
|
||
xByte := 0;
|
||
Stream.Write(pchar(str)^,length(str));
|
||
Stream.Write(xByte,1);
|
||
end;
|
||
}
|
||
//
|
||
Procedure WriteStringToStream(Stream:TStream; str:string);
|
||
begin
|
||
WriteString(Stream,Str);
|
||
end;
|
||
|
||
Procedure WriteField(Code:Byte;Stream:TStream; Const Value; Size: integer);
|
||
begin
|
||
Stream.Write(Code,1);
|
||
Stream.Write(Value,Size);
|
||
end;
|
||
|
||
Procedure WriteStrField(Code:Byte;Stream:TStream; Const Value:String);
|
||
begin
|
||
Stream.Write(Code,1);
|
||
WriteString(Stream,Value);
|
||
end;
|
||
|
||
Procedure WriteBinField(Code:Byte; Stream:TStream; Const Value:pByte; Size: integer);
|
||
begin
|
||
Stream.Write(Code,1);
|
||
Stream.Write(Size,4);
|
||
Stream.Write(Value^,Size);
|
||
end;
|
||
|
||
Procedure WriteStreamField(Code:Byte; Stream:TStream; Const Value:TStream);
|
||
var Size:Integer;
|
||
begin
|
||
Stream.Write(Code,1);
|
||
Size := Value.Size;
|
||
Stream.Write(Size,4);
|
||
Value.Seek(0,soFromBeginning);
|
||
StreamToStream(Value,Stream,Size);
|
||
end;
|
||
|
||
Procedure StreamToStream(str:TStream; ToStr: TStream; Size:Integer);
|
||
var xByte: pByte;
|
||
oSize: Integer;
|
||
begin
|
||
GetMem(xByte,Size);
|
||
oSize := Size;
|
||
Size := str.read(xByte^,Size);
|
||
tostr.Write(xByte^,Size);
|
||
FreeMem(xByte,osize);
|
||
end;
|
||
|
||
Function StreamEqual(str1,str2:TStream):Boolean;
|
||
var b1,b2: Byte;
|
||
i: Integer;
|
||
begin
|
||
result := true;
|
||
str1.Position := 0;
|
||
str2.Position := 0;
|
||
if str1.Size <> str2.Size then begin
|
||
result := false;
|
||
end else begin
|
||
for i := 1 to str1.Size do begin
|
||
Str1.Read(b1,1) ;
|
||
Str2.Read(b2,1) ;
|
||
if b1 <> b2 then begin
|
||
result := false;
|
||
//showmessage(inttostr(i));
|
||
exit;
|
||
end;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
Procedure StreamToClipBoard(str:TMemoryStream;format:Word);
|
||
var
|
||
Data: THandle;
|
||
DataPtr: Pointer;
|
||
|
||
begin
|
||
if OpenClipBoard(0) then
|
||
begin
|
||
EmptyClipBoard;
|
||
try
|
||
Data := GlobalAlloc(GMEM_MOVEABLE+GMEM_DDESHARE, str.Size);
|
||
try
|
||
DataPtr := GlobalLock(Data);
|
||
try
|
||
Move((str.Memory)^, DataPtr^, str.Size);
|
||
SetClipboardData(format, Data);
|
||
finally
|
||
GlobalUnlock(Data);
|
||
end;
|
||
except
|
||
GlobalFree(Data);
|
||
raise;
|
||
end;
|
||
finally
|
||
CloseClipBoard;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
Procedure ClipBoardToStream(str:TMemoryStream;format:word);
|
||
var
|
||
Data: THandle;
|
||
DataPtr: Pointer;
|
||
MemStream: TMemoryStream;
|
||
begin
|
||
if OpenClipBoard(0) then
|
||
begin
|
||
try
|
||
Data := GetClipboardData(format);
|
||
if Data = 0 then Exit;
|
||
DataPtr := GlobalLock(Data);
|
||
if DataPtr = nil then Exit;
|
||
try
|
||
Str.WriteBuffer(DataPtr^, GlobalSize(Data));
|
||
Str.Position := 0;
|
||
except
|
||
end;
|
||
finally
|
||
GlobalUnlock(Data);
|
||
end;
|
||
CloseClipBoard;
|
||
end;
|
||
end;
|
||
|
||
{This is a proper declaration of TranslateCharsetInfo}
|
||
function TranslateCharsetInfo(lpSrc: Pointer; var lpCs: TCharsetInfo; dwFlags: DWORD): BOOL; stdcall;external gdi32;
|
||
function LengthEx(S: AnsiString; CP: Word): Integer;
|
||
var
|
||
P: PAnsiChar;
|
||
begin
|
||
Result:= 0;
|
||
P:= @S[1];
|
||
while (P^<>#0) do
|
||
begin
|
||
Inc(Result);
|
||
P:= CharNextEx(CP, P, 0);
|
||
end;
|
||
end;
|
||
|
||
function LanguageName(Language: TLanguage): String;
|
||
var
|
||
Buf: array[0..255] of Char;
|
||
begin
|
||
GetLocaleInfo(Language, LOCALE_SLanguage, Buf, 255);
|
||
Result:= StrPas(Buf);
|
||
end;
|
||
|
||
function CodePageFromLocale(Language: TLanguage): Integer;
|
||
var
|
||
Buf: array[0..6] of Char;
|
||
begin
|
||
GetLocaleInfo(Language, LOCALE_IDefaultAnsiCodePage, Buf, 6);
|
||
Result:= StrToIntDef(Buf, GetACP);
|
||
end;
|
||
|
||
function OEMCodePageFromLocale(Language: TLanguage): Integer;
|
||
var
|
||
Buf: array[0..6] of Char;
|
||
begin
|
||
GetLocaleInfo(Language, LOCALE_IDefaultCodePage, Buf, 6);
|
||
Result:= StrToIntDef(Buf, GetOEMCP);
|
||
end;
|
||
|
||
function CharSetFromLocale(Language: TLanguage): TFontCharSet;
|
||
var
|
||
CP: Integer;
|
||
CSI: TCharsetInfo;
|
||
begin
|
||
CP:= CodePageFromLocale(Language);
|
||
TranslateCharsetInfo(Pointer(CP), CSI, TCI_SRCCODEPAGE);
|
||
Result:= CSI.ciCharset;
|
||
end;
|
||
|
||
function CharToWide(const S:AnsiString; CodePage: Word): WideString;
|
||
var
|
||
L: Integer;
|
||
begin
|
||
if S='' then
|
||
Result:= ''
|
||
else
|
||
begin
|
||
L:= MultiByteToWideChar(CodePage, 0, PAnsiChar(@S[1]), -1, nil, 0);
|
||
SetLength(Result, L-1);
|
||
MultiByteToWideChar(CodePage, 0, PAnsiChar(@S[1]), -1, PWideChar(@Result[1]), L-1);
|
||
end;
|
||
end;
|
||
|
||
function WideToChar(const WS: WideString; CodePage: Word): AnsiString;
|
||
var
|
||
L: Integer;
|
||
begin
|
||
if WS='' then
|
||
Result:= ''
|
||
else
|
||
begin
|
||
L:= WideCharToMultiByte(CodePage, 0, @WS[1], -1, nil, 0, nil, nil);
|
||
SetLength(Result, L-1);
|
||
WideCharToMultiByte(CodePage, 0, @WS[1], -1, @Result[1], L-1, nil, nil);
|
||
end;
|
||
end;
|
||
|
||
function CharToChar(const S: AnsiString; CP1, CP2: Word): AnsiString;
|
||
begin
|
||
Result:= WideToChar(CharToWide(S, CP1), CP2);
|
||
end;
|
||
|
||
function LanguageToIdent(Language: Longint; var Ident: string): Boolean;
|
||
var
|
||
Buf: array[0..255]of Char;
|
||
begin
|
||
Result:= IsValidLocale(Language, LCID_INSTALLED);
|
||
if Result then
|
||
begin
|
||
GetLocaleInfo(Language, LOCALE_SLANGUAGE, Buf, 255);
|
||
SetString(Ident, Buf, StrLen(Buf));
|
||
end;
|
||
end;
|
||
|
||
var
|
||
SearchId: String;
|
||
SearchLang: Integer;
|
||
LCType: Integer;
|
||
|
||
function EnumGetLang(LocaleStr: LPSTR): Integer;
|
||
stdcall;
|
||
var
|
||
Buf: array[0..255]of Char;
|
||
Locale: LCID;
|
||
Z: Integer;
|
||
begin
|
||
Val('$'+StrPas(LocaleStr), Locale, Z);
|
||
Result:= 1;
|
||
GetLocaleInfo(Locale, LCType, Buf, 255);
|
||
if AnsiCompareText(SearchId, Buf)=0 then
|
||
begin
|
||
SearchLang:= Locale;
|
||
Result:= 0;
|
||
end;
|
||
end;
|
||
|
||
function IdentToLanguage(const Ident: string; var Language: Longint): Boolean;
|
||
begin
|
||
SearchId:= Ident;
|
||
SearchLang:= -1;
|
||
LCType:= LOCALE_SLANGUAGE;
|
||
EnumSystemLocales(@EnumGetLang, LCID_INSTALLED);
|
||
if SearchLang<0 then
|
||
begin
|
||
LCType:= LOCALE_SENGLANGUAGE;
|
||
EnumSystemLocales(@EnumGetLang, LCID_INSTALLED);
|
||
end;
|
||
if SearchLang<0 then
|
||
begin
|
||
LCType:= LOCALE_SABBREVLANGNAME;
|
||
EnumSystemLocales(@EnumGetLang, LCID_INSTALLED);
|
||
end;
|
||
Result:= SearchLang>-1;
|
||
if Result then
|
||
Language:= SearchLang;
|
||
end;
|
||
|
||
function GetTextureBitmap(idx: integer): Graphics.TBitmap;
|
||
var sRect: Trect;
|
||
begin
|
||
result := Graphics.TBitmap.Create;
|
||
result.Width := 128;
|
||
result.Height := 128;
|
||
Srect := Rect (0,(idx-1)*128,128,(idx)*128);
|
||
result.Canvas.CopyRect(Rect(0,0,128,128),TextureBmp.Canvas,sRect);
|
||
end;
|
||
|
||
function PointInRect(const P: TDoublePoint; const R: TDoubleRect): Boolean;
|
||
begin
|
||
with R do
|
||
Result := (Left <= P.X) and (Top <= P.Y) and
|
||
(Right >= P.X) and (Bottom >= P.Y);
|
||
end;
|
||
|
||
function PointInPolyRect(P: TDoublePoint; r1,r2,r3,r4: TDoublePoint): Boolean;
|
||
var rad:Double;
|
||
begin
|
||
rad := GetRadOfLine(r1,r2);
|
||
r2 := RotatePoint(r1,r2,-rad);
|
||
r3 := RotatePoint(r1,r3,-rad);
|
||
r4 := RotatePoint(r1,r4,-rad);
|
||
p := RotatePoint(r1,p,-rad);
|
||
result := PointInRect(p,DoubleRect(r1.x,r1.y,r3.x,r3.y));
|
||
end;
|
||
|
||
Function RectCenter(Rect:TDoubleRect):TDoublePoint;
|
||
begin
|
||
result := MPoint(DoublePOint(rect.Left,rect.top),DoublePoint(Rect.right,rect.bottom));
|
||
end;
|
||
function NormalizeRect(const x1,y1,x2,y2 : Double;MarginDelta:Double) : TDoubleRect;
|
||
begin
|
||
Result := DoubleRect(x1,y1,x2,y2);
|
||
if (x1 > x2) then if (y1 > y2) then Result := DoubleRect(x2,y2,x1,y1) else Result:=DoubleRect(x2,y1,x1,y2)
|
||
else if (y1 > y2) then Result := DoubleRect(x1,y2,x2,y1);
|
||
Result := DoubleRect(Result.Left - MarginDelta, Result.Top - MarginDelta, Result.Right + MarginDelta, Result.Bottom + MarginDelta);
|
||
end;
|
||
|
||
//Tolik 15/12/2021 --
|
||
function IsPointInLine3D(const m1,m2 : TDoublePoint;
|
||
const p : TDoublePoint;
|
||
PenWidth : double;
|
||
MarginDelta:Double = 2) : Boolean;
|
||
var l2,d12,d22 : Double;
|
||
dist2 : Double;
|
||
begin
|
||
Result := False;
|
||
|
||
try
|
||
l2 := (m1.X - m2.X)*(m1.X - m2.X) + (m1.Y - m2.Y)*(m1.Y - m2.Y);
|
||
if (l2 = 0) then
|
||
begin
|
||
Result := ((Abs(p.X - m1.X) <= (MarginDelta + sqrt(PenWidth))) and
|
||
(Abs(p.Y - m1.Y) <= (MarginDelta + sqrt(PenWidth))));
|
||
Exit;
|
||
end;
|
||
d12 := (m1.X - p.X)*(m1.X - p.X) + (m1.Y - p.Y)*(m1.Y - p.Y);
|
||
d22 := (m2.X - p.X)*(m2.X - p.X) + (m2.Y - p.Y)*(m2.Y - p.Y);
|
||
dist2 := Abs(4*d12*d22 - (l2 - d12 - d22)*(l2 - d12 - d22)) / (4*l2);
|
||
Result := (dist2 <= (MarginDelta + sqrt(PenWidth))*(MarginDelta + sqrt(PenWidth))) and
|
||
PointInRect(p,NormalizeRect(m1.X,m1.Y,m2.X,m2.Y,MarginDelta));
|
||
|
||
except
|
||
on E: Exception do
|
||
begin
|
||
Result := False;
|
||
end;
|
||
end;
|
||
end;
|
||
//Tolik 27/08/2019 --
|
||
function IsPointInLine(const m1,m2 : TDoublePoint;
|
||
const p : TDoublePoint;
|
||
const PenWidth : Integer;
|
||
MarginDelta:Double = 2) : Boolean;
|
||
var l2,d12,d22 : Double;
|
||
dist2 : Double;
|
||
begin
|
||
Result := False;
|
||
|
||
try
|
||
l2 := (m1.X - m2.X)*(m1.X - m2.X) + (m1.Y - m2.Y)*(m1.Y - m2.Y);
|
||
if (l2 = 0) then begin
|
||
Result := ((Abs(p.X - m1.X) <= (MarginDelta + PenWidth)) and
|
||
(Abs(p.Y - m1.Y) <= (MarginDelta + PenWidth)));
|
||
Exit;
|
||
end;
|
||
d12 := (m1.X - p.X)*(m1.X - p.X) + (m1.Y - p.Y)*(m1.Y - p.Y);
|
||
d22 := (m2.X - p.X)*(m2.X - p.X) + (m2.Y - p.Y)*(m2.Y - p.Y);
|
||
dist2 := Abs(4*d12*d22 - (l2 - d12 - d22)*(l2 - d12 - d22)) / (4*l2);
|
||
Result := (dist2 <= (MarginDelta + PenWidth)*(MarginDelta + PenWidth)) and
|
||
PointInRect(p,NormalizeRect(m1.X,m1.Y,m2.X,m2.Y,MarginDelta));
|
||
|
||
except
|
||
on E: Exception do
|
||
begin
|
||
Result := False;
|
||
end;
|
||
end;
|
||
|
||
end;
|
||
{
|
||
function IsPointInLine(const m1,m2 : TDoublePoint;
|
||
const p : TDoublePoint;
|
||
const PenWidth : Integer;
|
||
MarginDelta:Double = 2) : Boolean;
|
||
var l2,d12,d22 : Double;
|
||
dist2 : Double;
|
||
begin
|
||
Result := False;
|
||
l2 := (m1.X - m2.X)*(m1.X - m2.X) + (m1.Y - m2.Y)*(m1.Y - m2.Y);
|
||
if (l2 = 0) then begin
|
||
Result := ((Abs(p.X - m1.X) <= (MarginDelta + PenWidth)) and
|
||
(Abs(p.Y - m1.Y) <= (MarginDelta + PenWidth)));
|
||
Exit;
|
||
end;
|
||
d12 := (m1.X - p.X)*(m1.X - p.X) + (m1.Y - p.Y)*(m1.Y - p.Y);
|
||
d22 := (m2.X - p.X)*(m2.X - p.X) + (m2.Y - p.Y)*(m2.Y - p.Y);
|
||
dist2 := Abs(4*d12*d22 - (l2 - d12 - d22)*(l2 - d12 - d22)) / (4*l2);
|
||
Result := (dist2 <= (MarginDelta + PenWidth)*(MarginDelta + PenWidth)) and
|
||
PointInRect(p,NormalizeRect(m1.X,m1.Y,m2.X,m2.Y,MarginDelta));
|
||
|
||
//Result := false;
|
||
//dist2 := Abs((m2.x - m1.x)*(m1.y - p.y) - (m1.x - p.x)*(m2.y - m1.y)) / Sqrt(sqr(m2.x - m1.x) + sqr(m2.y-m1.y));
|
||
//Result := (dist2 <= (MarginDelta + PenWidth)*(MarginDelta + PenWidth)) and
|
||
// PointInRect(p,NormalizeRect(m1.X,m1.Y,m2.X,m2.Y,MarginDelta));
|
||
end;
|
||
}
|
||
//
|
||
|
||
|
||
Function GetVectorPenPoints(Style:Integer;var VectorPoints: TList):Integer;
|
||
var Pnt: PPoint;
|
||
begin
|
||
Result := 0;
|
||
if Style = 1 then begin
|
||
VectorPoints := TList.Create;
|
||
New(Pnt);pnt.x := 0;pnt.y := 0;VectorPoints.Add(pnt);
|
||
New(Pnt);pnt.x := 15;pnt.y := 15;VectorPoints.Add(pnt);
|
||
New(Pnt);pnt.x := 30;pnt.y := 0;VectorPoints.Add(pnt);
|
||
Result := 30;
|
||
end
|
||
else if Style = 2 then begin
|
||
VectorPoints := TList.Create;
|
||
New(Pnt);pnt.x := 0;pnt.y := -10;VectorPoints.Add(pnt);
|
||
New(Pnt);pnt.x := 0;pnt.y := 10;VectorPoints.Add(pnt);
|
||
New(Pnt);pnt.x := 10;pnt.y := 10;VectorPoints.Add(pnt);
|
||
New(Pnt);pnt.x := 10;pnt.y := -10;VectorPoints.Add(pnt);
|
||
New(Pnt);pnt.x := 0;pnt.y := -10;VectorPoints.Add(pnt);
|
||
Result := 15;
|
||
end
|
||
else if Style = 3 then begin
|
||
VectorPoints := TList.Create;
|
||
New(Pnt);pnt.x := 0;pnt.y := 0;VectorPoints.Add(pnt);
|
||
New(Pnt);pnt.x := 0;pnt.y := 5;VectorPoints.Add(pnt);
|
||
New(Pnt);pnt.x := 20;pnt.y := 5;VectorPoints.Add(pnt);
|
||
New(Pnt);pnt.x := 20;pnt.y := -15;VectorPoints.Add(pnt);
|
||
New(Pnt);pnt.x := 5;pnt.y := -15;VectorPoints.Add(pnt);
|
||
New(Pnt);pnt.x := 5;pnt.y := 0;VectorPoints.Add(pnt);
|
||
New(Pnt);pnt.x := 25;pnt.y := 0;VectorPoints.Add(pnt);
|
||
Result := 25;
|
||
end
|
||
else if Style = 4 then begin
|
||
VectorPoints := TList.Create;
|
||
New(Pnt);pnt.x := 0;pnt.y := 0;VectorPoints.Add(pnt);
|
||
New(Pnt);pnt.x := 20;pnt.y := 0;VectorPoints.Add(pnt);
|
||
New(Pnt);pnt.x := 20;pnt.y :=-10;VectorPoints.Add(pnt);
|
||
New(Pnt);pnt.x := 0;pnt.y := -10;VectorPoints.Add(pnt);
|
||
Result := 20;
|
||
end;
|
||
|
||
end;
|
||
|
||
function DelphiLoaded : boolean;
|
||
function WindowExists(ClassName, WindowName: string): boolean;
|
||
{------------------------------------------------------}
|
||
{ Checks for the existence of the specified Window, }
|
||
{ conveniently using Pascal strings instead of PChars. }
|
||
{------------------------------------------------------}
|
||
var
|
||
PClassName, PWindowName: PChar;
|
||
AClassName, AWindowName: array[0..63] of char;
|
||
h:HWND;
|
||
begin
|
||
if ClassName = ''
|
||
then PClassName := nil
|
||
else PClassName := StrPCopy(@AClassName[0], ClassName);
|
||
if WindowName = ''
|
||
then PWindowName := nil
|
||
else PWindowName := StrPCopy(@AWindowName[0], WindowName);
|
||
h := FindWindow(PClassName, PWindowName);
|
||
if h <> 0
|
||
then WindowExists := true
|
||
else WindowExists := false;
|
||
end; {WindowExists}
|
||
|
||
begin
|
||
DelphiLoaded := false;
|
||
if WindowExists('TPropertyInspector', 'Object Inspector') and
|
||
WindowExists('TMenuBuilder','Menu Designer') and
|
||
WindowExists('TAlignPalette','Align') Then DelphiLoaded := true;
|
||
end;
|
||
|
||
|
||
|
||
|
||
{ TUndoAction }
|
||
|
||
constructor TUndoAction.Create(aType: TUndoActionType);
|
||
begin
|
||
inherited create;
|
||
ActionType := aType;
|
||
List := Tlist.Create;
|
||
Params := TList.Create;
|
||
RedoList := TList.Create;
|
||
Tag := 0;
|
||
end;
|
||
|
||
Destructor TUndoAction.Destroy;
|
||
begin
|
||
List.Free;
|
||
Params.Free;
|
||
RedoList.Free;
|
||
inherited;
|
||
end;
|
||
|
||
{ TColorSpeedButton }
|
||
|
||
procedure TColorSpeedButton.Paint;
|
||
begin
|
||
inherited;
|
||
Canvas.Brush.Color := tag;
|
||
Canvas.Brush.Style := bsSolid;
|
||
Canvas.Pen.Color := clBlack;
|
||
canvas.Rectangle(2,2,13,13);
|
||
end;
|
||
|
||
Function ValidateString(str: String):String;
|
||
var i: integer;
|
||
c: string;
|
||
begin
|
||
result := '';
|
||
for i := 1 to length(str) do
|
||
begin
|
||
c := copy(str,i,1);
|
||
if ((c >= '0') and (c <= '9')) or
|
||
((c >= 'a') and (c <= 'z')) or
|
||
((c >= 'A') and (c <= 'Z')) then
|
||
result := result + c;
|
||
end;
|
||
end;
|
||
|
||
{ TEventEngine }
|
||
|
||
constructor TEventEngine.Create(Id: Integer;aNumVal: Integer; aStrval:String;
|
||
aDblVal:Double);
|
||
begin
|
||
inherited Create;
|
||
NumVal := aNumVal;
|
||
Strval := aStrval;
|
||
DblVal := aDblval;
|
||
EventId := Id;
|
||
Enabled := True;
|
||
Clients := TList.Create;
|
||
end;
|
||
|
||
destructor TEventEngine.Destroy;
|
||
begin
|
||
Clients.Free;
|
||
Inherited;
|
||
end;
|
||
|
||
procedure TEventEngine.RaiseEvent(aNumVal: Integer; aStrval:String;
|
||
aDblVal:Double);
|
||
var CallBack: TEventCallBack;
|
||
i: Integer;
|
||
eItem: TEventItem;
|
||
begin
|
||
NumVal := aNumVal;
|
||
Strval := aStrval;
|
||
DblVal := aDblval;
|
||
For i := 0 to Clients.Count - 1 do
|
||
begin
|
||
eItem := TEventItem(Clients[i]);
|
||
eItem.CallBack(eItem.Client,EventId,NumVal,StrVal,DblVal,True);
|
||
end;
|
||
end;
|
||
|
||
procedure TEventEngine.RaiseEvent(bVal: Boolean);
|
||
var CallBack: TEventCallBack;
|
||
i: Integer;
|
||
eItem: TEventItem;
|
||
begin
|
||
NumVal := 0;
|
||
if bval then numval := 1;
|
||
For i := 0 to Clients.Count - 1 do
|
||
begin
|
||
eItem := TEventItem(Clients[i]);
|
||
eItem.CallBack(eItem.Client,EventId,NumVal,StrVal,DblVal,True);
|
||
end;
|
||
end;
|
||
|
||
procedure TEventEngine.RaiseEvent(aNumVal: Integer);
|
||
var CallBack: TEventCallBack;
|
||
i: Integer;
|
||
eItem: TEventItem;
|
||
begin
|
||
Numval := aNumVal;
|
||
For i := 0 to Clients.Count - 1 do
|
||
begin
|
||
eItem := TEventItem(Clients[i]);
|
||
eItem.CallBack(eItem.Client,EventId,NumVal,StrVal,DblVal,True);
|
||
end;
|
||
end;
|
||
|
||
procedure TEventEngine.RaiseEvent(aDblVal: Double);
|
||
var CallBack: TEventCallBack;
|
||
i: Integer;
|
||
eItem: TEventItem;
|
||
begin
|
||
DblVal := aDblVal;
|
||
For i := 0 to Clients.Count - 1 do
|
||
begin
|
||
eItem := TEventItem(Clients[i]);
|
||
eItem.CallBack(eItem.Client,EventId,NumVal,StrVal,DblVal,True);
|
||
end;
|
||
end;
|
||
|
||
Procedure TEventEngine.RaiseEvent(aStrVal:String);
|
||
var CallBack: TEventCallBack;
|
||
i: Integer;
|
||
eItem: TEventItem;
|
||
begin
|
||
StrVal := aStrVal;
|
||
For i := 0 to Clients.Count - 1 do
|
||
begin
|
||
eItem := TEventItem(Clients[i]);
|
||
eItem.CallBack(eItem.Client,EventId,NumVal,StrVal,DblVal,True);
|
||
end;
|
||
end;
|
||
|
||
Procedure TEventEngine.EnableEvent(xenabled: Boolean);
|
||
var CallBack: TEventCallBack;
|
||
i: Integer;
|
||
eItem: TEventItem;
|
||
begin
|
||
Enabled := xEnabled;
|
||
For i := 0 to Clients.Count - 1 do
|
||
begin
|
||
eItem := TEventItem(Clients[i]);
|
||
eItem.CallBack(eItem.Client,EventId,NumVal,StrVal,DblVal,Enabled);
|
||
end;
|
||
end;
|
||
|
||
Function TEventEngine.RegisterClient(Client:TObject;CallBack: TEventCallBack):Pointer;
|
||
var eItem: TEventItem;
|
||
begin
|
||
result := nil;
|
||
if assigned(Callback) then
|
||
begin
|
||
eItem := TEventItem.Create(Client,CallBack);
|
||
Clients.Add(eItem);
|
||
result := eItem;
|
||
Callback(Client,EventId,Numval,Strval,Dblval,True);
|
||
end;
|
||
end;
|
||
|
||
Procedure TEventEngine.UnRegisterClient(EvHandle: Pointer);
|
||
Begin
|
||
if assigned(EvHandle) then Clients.Remove(EvHandle);
|
||
End;
|
||
|
||
procedure TEventEngine.RaiseEvent;
|
||
var CallBack: TEventCallBack;
|
||
i: Integer;
|
||
eItem: TEventItem;
|
||
begin
|
||
For i := 0 to Clients.Count - 1 do
|
||
begin
|
||
eItem := TEventItem(Clients[i]);
|
||
eItem.CallBack(eItem.Client,EventId,NumVal,StrVal,DblVal,True);
|
||
end;
|
||
end;
|
||
|
||
{ TEventItem }
|
||
|
||
constructor TEventItem.Create(aClient: TObject; aCallback: TEventCallback);
|
||
begin
|
||
inherited Create;
|
||
Client := aClient;
|
||
Callback := aCallback;
|
||
end;
|
||
|
||
{ TColorMenuItem }
|
||
|
||
constructor TColorMenuItem.Create(aOwner: TComponent);
|
||
var cItem:TMenuItem;
|
||
i,k:integer;
|
||
begin
|
||
inherited;
|
||
OnMeasureItem := SelfMeasureItem;
|
||
OnAdvancedDrawItem := SelfAdvancedDrawItem;
|
||
|
||
for i := 1 to 5 do
|
||
begin
|
||
for k := 1 to 10 do
|
||
begin
|
||
cItem := TMenuItem.Create(self);
|
||
Self.Add(cItem);
|
||
if (i = 1) and (k = 1) then
|
||
begin
|
||
CItem.Tag := -255;CItem.Hint := 'Layer Default';
|
||
end
|
||
else if (i = 5) and (k = 10) then
|
||
begin
|
||
CItem.Tag := -500;Citem.Hint := 'More Colors';
|
||
end
|
||
else
|
||
cItem.Tag := BasicColors[((k-1)*5+i)-1];
|
||
cItem.Caption := inttostr(k);
|
||
cItem.OnMeasureItem := ChildMeasureItem;
|
||
cItem.OnAdvancedDrawItem := ChildAdvancedDrawItem;
|
||
cItem.OnClick := ColorSelected;
|
||
if (i>1) and (k=1) then cItem.Break := mbBreak;
|
||
if (k = 4) and (i=3) then begin
|
||
cItem.Checked := true;
|
||
SelectedItem := cItem;
|
||
end;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
Procedure TColorMenuItem.SetColor(Value: TColor);
|
||
var i: Integer;
|
||
cItem: TmenuItem;
|
||
begin
|
||
For i := 0 to Count-1 do
|
||
begin
|
||
cItem := Items[i];
|
||
cItem.Checked := False;
|
||
if cItem.Tag = Value then begin
|
||
cItem.Checked := true;
|
||
SelectedItem := cItem;
|
||
end;
|
||
end;
|
||
FColor := Value;
|
||
end;
|
||
procedure TColorMenuItem.SelfMeasureItem(Sender: TObject; ACanvas: TCanvas;
|
||
var Width, Height: Integer);
|
||
Begin
|
||
Width := ACanvas.TextWidth(Caption)+20;
|
||
if assigned(Bitmap) then Width := Width + 20;
|
||
end;
|
||
|
||
procedure TColorMenuItem.SelfAdvancedDrawItem(Sender: TObject; ACanvas: TCanvas;
|
||
ARect: TRect; State: TOwnerDrawState);
|
||
var ctext,xCaption: String;
|
||
i: Integer;
|
||
textStart,rectStart: Integer;
|
||
Begin
|
||
xCaption := '';
|
||
for i := 0 to Length(Caption) do
|
||
begin
|
||
if copy(Caption,i,1) <> '&' then
|
||
xCaption := xCaption + copy(Caption,i,1);
|
||
end;
|
||
Acanvas.Brush.Color := clMenu;
|
||
Acanvas.Brush.Style := bsSolid;
|
||
ACanvas.FillRect(ARect);
|
||
Acanvas.Pen.Style := psSolid;
|
||
ACanvas.Pen.Color := ClBlack;
|
||
|
||
if odSelected in State then
|
||
begin
|
||
Acanvas.Brush.Color := clHighLight;
|
||
ACanvas.FillRect(ARect);
|
||
ACanvas.Pen.Color := ClWhite;
|
||
end;
|
||
|
||
if assigned(Bitmap) then
|
||
begin
|
||
if odSelected in State then
|
||
begin
|
||
Acanvas.Brush.Color := clMenu;
|
||
ACanvas.FillRect(Rect(Arect.Left+5,ARect.top+2,Arect.Left+21,ARect.top+17));
|
||
end;
|
||
Bitmap.Transparent := True;
|
||
ACanvas.Draw(Arect.Left+5,ARect.top+2,Bitmap);
|
||
end;
|
||
|
||
|
||
if fColor = -255 then
|
||
begin
|
||
Acanvas.Brush.Color := clRed;
|
||
cText:= 'L';
|
||
end else begin
|
||
Acanvas.Brush.Color := FColor;
|
||
cText:= '';
|
||
end;
|
||
|
||
if assigned(Bitmap) then
|
||
begin
|
||
RectStart := aRect.left + 25;
|
||
TextStart := aRect.left + 40;
|
||
end else begin
|
||
RectStart := aRect.left + 5;
|
||
TextStart := aRect.left + 20;
|
||
end;
|
||
|
||
|
||
if odDisabled in State then begin
|
||
Acanvas.Brush.Color := clSilver;
|
||
ACanvas.Pen.Color := clGray;
|
||
if not (odselected in State) then
|
||
Acanvas.Rectangle(RectStart, Arect.Top+5,RectStart+10,Arect.Top+15);
|
||
end else
|
||
Acanvas.Rectangle(RectStart, Arect.Top+5,RectStart+10,Arect.Top+15);
|
||
|
||
Acanvas.Brush.Style := bsClear;
|
||
|
||
if odDisabled in State then begin
|
||
if not (odselected in State) then
|
||
begin
|
||
ACanvas.Font.Color := clWhite;
|
||
Acanvas.TextOut(TextStart+1,Arect.Top+4,xCaption);
|
||
end;
|
||
ACanvas.Font.Color := clGray;
|
||
Acanvas.TextOut(TextStart,Arect.Top+3,xCaption);
|
||
end else begin
|
||
Acanvas.TextOut(TextStart,Arect.Top+3,xCaption);
|
||
end;
|
||
|
||
if Ctext <> '' then
|
||
begin
|
||
ACanvas.Font.Name := 'Tahoma';
|
||
ACanvas.Font.Style := [fsBold];
|
||
ACanvas.Font.Size := 7;
|
||
ACanvas.Font.Color := clWhite;
|
||
Acanvas.TextOut(RectStart + 2,Arect.Top+4,Ctext);
|
||
end;
|
||
|
||
end;
|
||
|
||
Procedure TColorMenuItem.ColorSelected(Sender:TObject);
|
||
var dlg: TColorDialog;
|
||
sColor:TColor;
|
||
begin
|
||
sColor := (Sender as TmenuItem).Tag;
|
||
if SColor <> - 500 then
|
||
begin
|
||
(Sender as TMenuItem).Checked := True;
|
||
FColor := SColor;
|
||
SelectedItem.Checked := False;
|
||
SelectedItem := (Sender as TMenuItem);
|
||
end
|
||
else begin
|
||
dlg := TColorDialog.Create(Self);
|
||
dlg.Color := FColor;
|
||
if dlg.Execute then
|
||
begin
|
||
SelectedItem.Checked := False;
|
||
Color := dlg.Color;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
Procedure TColorMenuItem.SetBitmap(aBitmap: Graphics.TBitmap);
|
||
begin
|
||
if not assigned(aBitmap) then
|
||
begin
|
||
if assigned(Bitmap) then Bitmap.Free;
|
||
Bitmap := nil;
|
||
end else begin
|
||
if not assigned(Bitmap) then
|
||
begin
|
||
Bitmap := Graphics.TBitmap.Create;
|
||
Bitmap.Width := 16;
|
||
Bitmap.Height :=16;
|
||
end;
|
||
Bitmap.Canvas.Draw(0,0,aBitmap);
|
||
end;
|
||
end;
|
||
|
||
|
||
procedure TColorMenuItem.ChildMeasureItem(Sender: TObject; ACanvas: TCanvas;
|
||
var Width, Height: Integer);
|
||
begin
|
||
width := 2;
|
||
Height := 16;
|
||
end;
|
||
|
||
|
||
procedure TColorMenuItem.ChildAdvancedDrawItem(Sender: TObject; ACanvas: TCanvas;
|
||
ARect: TRect; State: TOwnerDrawState);
|
||
var xRect: Trect;
|
||
xColor:Integer;
|
||
text: string;
|
||
begin
|
||
text := '';
|
||
Acanvas.Brush.Color := clMenu;
|
||
Acanvas.Brush.Style := bsSolid;
|
||
Acanvas.FillRect(aRect);
|
||
xColor := TMenuItem(Sender).Tag;
|
||
if xColor = -255 then
|
||
begin
|
||
Acanvas.Brush.Color := 255;Text := 'L';
|
||
end
|
||
else if xColor = -500 then
|
||
begin
|
||
Acanvas.Brush.Color := clNavy;Text := 'M';
|
||
end
|
||
else
|
||
Acanvas.Brush.Color := xColor;
|
||
|
||
Acanvas.Pen.Color := clBlack;
|
||
Acanvas.Pen.Style := psSolid;
|
||
Acanvas.Pen.Width := 1;
|
||
xRect := Rect(Arect.left+1,ARect.Top+2,Arect.Right-1,Arect.Bottom-2);
|
||
|
||
if odSelected in State then begin
|
||
Acanvas.Rectangle(aRect);
|
||
end else begin
|
||
Acanvas.Rectangle(xRect);
|
||
end;
|
||
|
||
if odChecked in State then begin
|
||
Acanvas.Pen.Color := clMenu;
|
||
Acanvas.Pen.Style := psSolid;
|
||
Acanvas.Pen.Width := 2;
|
||
DrawEdge(Acanvas.handle,xRect,EDGE_SUNKEN,BF_RECT);
|
||
end;
|
||
If text <> '' then begin
|
||
ACanvas.Font.Name := 'Tahoma';
|
||
ACanvas.Font.Size := 7;
|
||
ACanvas.Font.Style := [fsBold];
|
||
Acanvas.Font.Color := clWhite;
|
||
Acanvas.Brush.Style := bsClear;
|
||
Drawtext(Acanvas.handle,pChar(Text),1,xRect,DT_VCENTER or DT_CENTER);
|
||
end;
|
||
|
||
|
||
end;
|
||
|
||
|
||
|
||
{ TColorPopUp }
|
||
|
||
procedure TColorPopUp.ChildAdvancedDrawItem(Sender: TObject;
|
||
ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);
|
||
var xRect: Trect;
|
||
xColor:Integer;
|
||
text: string;
|
||
begin
|
||
text := '';
|
||
Acanvas.Brush.Color := clMenu;
|
||
Acanvas.Brush.Style := bsSolid;
|
||
Acanvas.FillRect(aRect);
|
||
xColor := TMenuItem(Sender).Tag;
|
||
if xColor = -255 then
|
||
begin
|
||
Acanvas.Brush.Color := 255;Text := 'L';
|
||
end
|
||
else if xColor = -500 then
|
||
begin
|
||
Acanvas.Brush.Color := clNavy;Text := 'M';
|
||
end
|
||
else
|
||
Acanvas.Brush.Color := xColor;
|
||
|
||
Acanvas.Pen.Color := clBlack;
|
||
Acanvas.Pen.Style := psSolid;
|
||
Acanvas.Pen.Width := 1;
|
||
xRect := Rect(Arect.left+1,ARect.Top+2,Arect.Right-1,Arect.Bottom-2);
|
||
|
||
if odSelected in State then begin
|
||
Acanvas.Rectangle(aRect);
|
||
end else begin
|
||
Acanvas.Rectangle(xRect);
|
||
end;
|
||
|
||
if odChecked in State then begin
|
||
Acanvas.Pen.Color := clMenu;
|
||
Acanvas.Pen.Style := psSolid;
|
||
Acanvas.Pen.Width := 2;
|
||
DrawEdge(Acanvas.handle,xRect,EDGE_SUNKEN,BF_RECT);
|
||
end;
|
||
If text <> '' then begin
|
||
ACanvas.Font.Name := 'Tahoma';
|
||
ACanvas.Font.Size := 7;
|
||
ACanvas.Font.Style := [fsBold];
|
||
Acanvas.Font.Color := clWhite;
|
||
Acanvas.Brush.Style := bsClear;
|
||
Drawtext(Acanvas.handle,pChar(Text),1,xRect,DT_VCENTER or DT_CENTER);
|
||
end;
|
||
|
||
end;
|
||
|
||
procedure TColorPopUp.ChildMeasureItem(Sender: TObject; ACanvas: TCanvas;
|
||
var Width, Height: Integer);
|
||
begin
|
||
width := 2;
|
||
Height := 16;
|
||
|
||
end;
|
||
|
||
procedure TColorPopUp.ColorSelected(Sender: TObject);
|
||
var dlg: TColorDialog;
|
||
sColor:TColor;
|
||
begin
|
||
sColor := (Sender as TmenuItem).Tag;
|
||
if SColor <> - 500 then
|
||
begin
|
||
(Sender as TMenuItem).Checked := True;
|
||
FColor := SColor;
|
||
SelectedItem.Checked := False;
|
||
SelectedItem := (Sender as TMenuItem);
|
||
end
|
||
else begin
|
||
dlg := TColorDialog.Create(Self);
|
||
dlg.Color := FColor;
|
||
if dlg.Execute then
|
||
begin
|
||
SelectedItem.Checked := False;
|
||
Color := dlg.Color;
|
||
end;
|
||
end;
|
||
If assigned(FColorChange) then FColorChange(sender,Color);
|
||
end;
|
||
|
||
|
||
constructor TColorPopUp.Create(aOwner: TComponent);
|
||
var cItem:TMenuItem;
|
||
i,k:integer;
|
||
begin
|
||
inherited;
|
||
ownerDraw := True;
|
||
for i := 1 to 5 do
|
||
begin
|
||
for k := 1 to 10 do
|
||
begin
|
||
cItem := TMenuItem.Create(self);
|
||
Items.Add(cItem);
|
||
if (i = 1) and (k = 1) then
|
||
begin
|
||
CItem.Tag := -255;CItem.Hint := 'Layer Default';
|
||
end
|
||
else if (i = 5) and (k = 10) then
|
||
begin
|
||
CItem.Tag := -500;Citem.Hint := 'More Colors';
|
||
end
|
||
else
|
||
cItem.Tag := BasicColors[((k-1)*5+i)-1];
|
||
cItem.Caption := inttostr(k);
|
||
cItem.OnMeasureItem := ChildMeasureItem;
|
||
cItem.OnAdvancedDrawItem := ChildAdvancedDrawItem;
|
||
cItem.OnClick := ColorSelected;
|
||
if (i>1) and (k=1) then cItem.Break := mbBreak;
|
||
if (k = 4) and (i=3) then begin
|
||
cItem.Checked := true;
|
||
SelectedItem := cItem;
|
||
end;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
|
||
procedure TColorPopUp.SetColor(Value: TColor);
|
||
var i: Integer;
|
||
cItem: TmenuItem;
|
||
begin
|
||
For i := 0 to Items.Count-1 do
|
||
begin
|
||
cItem := Items[i];
|
||
cItem.Checked := False;
|
||
if cItem.Tag = Value then begin
|
||
cItem.Checked := true;
|
||
SelectedItem := cItem;
|
||
end;
|
||
end;
|
||
FColor := Value;
|
||
end;
|
||
|
||
procedure getellipseBounds(x, y, a, b, xangle:Double;
|
||
lines: integer; var BoundRect: TDoubleRect);
|
||
var sinAngle : real;
|
||
cosAngle : real;
|
||
angle : real;
|
||
theta : real;
|
||
xp,yp : real;
|
||
xr, yr : double;
|
||
li : integer;
|
||
begin
|
||
|
||
sinAngle := sin (xangle);
|
||
cosAngle := cos (xangle);
|
||
|
||
if xangle = 0 then
|
||
begin
|
||
BoundRect.Left := x-a;
|
||
BoundRect.Right := x+a;
|
||
BoundRect.Top := y-b;
|
||
BoundRect.Bottom := y+b;
|
||
end
|
||
else
|
||
begin
|
||
BoundRect.Left := x;
|
||
BoundRect.Right := x;
|
||
BoundRect.Top := y;
|
||
BoundRect.Bottom := y;
|
||
|
||
for li := 0 to lines
|
||
do begin
|
||
theta := (li/lines) * 2*PI; // angle step
|
||
xp := a * cos(theta); // ellipse point
|
||
yp := b * sin(theta);
|
||
// rotate ellipse point around center
|
||
xr := (x - xp * cosAngle + yp * sinAngle);
|
||
yr := (y + xp * sinAngle + yp * cosAngle);
|
||
if xr > BoundRect.Right then BoundRect.Right := xr
|
||
else if xr< BoundRect.Left then BoundRect.Left := xr;
|
||
if yr > BoundRect.Bottom then BoundRect.Bottom := yr
|
||
else if yr < BoundRect.Top then BoundRect.Top := yr;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
|
||
{ TBevelEx }
|
||
|
||
procedure TBevelEx.Paint;
|
||
const
|
||
XorColor = $00FFD8CE;
|
||
var
|
||
Color1, Color2: TColor;
|
||
Temp: TColor;
|
||
|
||
procedure BevelRect(const R: TRect);
|
||
begin
|
||
with Canvas do
|
||
begin
|
||
Pen.Color := Color1;
|
||
PolyLine([Point(R.Left, R.Bottom), Point(R.Left, R.Top),
|
||
Point(R.Right, R.Top)]);
|
||
Pen.Color := Color2;
|
||
PolyLine([Point(R.Right, R.Top), Point(R.Right, R.Bottom),
|
||
Point(R.Left, R.Bottom)]);
|
||
end;
|
||
end;
|
||
|
||
procedure BevelLine(C: TColor; X1, Y1, X2, Y2: Integer);
|
||
begin
|
||
with Canvas do
|
||
begin
|
||
Pen.Color := C;
|
||
MoveTo(X1, Y1);
|
||
LineTo(X2, Y2);
|
||
end;
|
||
end;
|
||
|
||
begin
|
||
with Canvas do
|
||
begin
|
||
if (csDesigning in ComponentState) then
|
||
begin
|
||
if (FShape = bsSpacer) then
|
||
begin
|
||
Pen.Style := psDot;
|
||
Pen.Mode := pmXor;
|
||
Pen.Color := XorColor;
|
||
Brush.Style := bsClear;
|
||
Rectangle(0, 0, ClientWidth, ClientHeight);
|
||
Exit;
|
||
end
|
||
else
|
||
begin
|
||
Pen.Style := psSolid;
|
||
Pen.Mode := pmCopy;
|
||
Pen.Color := clBlack;
|
||
Brush.Style := bsSolid;
|
||
end;
|
||
end;
|
||
|
||
Pen.Width := 1;
|
||
|
||
if Style = bsLowered then
|
||
begin
|
||
Color1 := clBtnShadow;
|
||
Color2 := clBtnHighlight;
|
||
end
|
||
else
|
||
begin
|
||
Color1 := clBtnHighlight;
|
||
Color2 := clBtnShadow;
|
||
end;
|
||
|
||
case FShape of
|
||
bsBox: BevelRect(Rect(0, 0, Width - 1, Height - 1));
|
||
bsFrame:
|
||
begin
|
||
Temp := Color1;
|
||
Color1 := Color2;
|
||
BevelRect(Rect(1, 1, Width - 1, Height - 1));
|
||
Color2 := Temp;
|
||
Color1 := Temp;
|
||
BevelRect(Rect(0, 0, Width - 2, Height - 2));
|
||
end;
|
||
bsTopLine:
|
||
begin
|
||
BevelLine(Color1, 0, 0, Width, 0);
|
||
BevelLine(Color2, 0, 1, Width, 1);
|
||
end;
|
||
bsBottomLine:
|
||
begin
|
||
BevelLine(Color1, 0, Height - 2, Width, Height - 2);
|
||
BevelLine(Color2, 0, Height - 1, Width, Height - 1);
|
||
end;
|
||
bsHorzLine:
|
||
begin
|
||
BevelLine(Color1, 0, (Height div 2)-2, Width, (Height div 2)-2);
|
||
BevelLine(Color2, 0, (Height div 2)-1, Width, (Height div 2)-1);
|
||
end;
|
||
|
||
bsLeftLine:
|
||
begin
|
||
BevelLine(Color1, 0, 0, 0, Height);
|
||
BevelLine(Color2, 1, 0, 1, Height);
|
||
end;
|
||
bsRightLine:
|
||
begin
|
||
BevelLine(Color1, Width - 2, 0, Width - 2, Height);
|
||
BevelLine(Color2, Width - 1, 0, Width - 1, Height);
|
||
end;
|
||
bsVertLine:
|
||
begin
|
||
BevelLine(Color1, (Width div 2) -2, 0, (Width div 2) -2, Height);
|
||
BevelLine(Color2, (Width div 2) -1, 0, (Width div 2) -1, Height);
|
||
end;
|
||
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
procedure TBevelEx.SetShape(Value: TBevelShapeEx);
|
||
begin
|
||
if Value <> FShape then
|
||
begin
|
||
FShape := Value;
|
||
Invalidate;
|
||
end;
|
||
end;
|
||
|
||
{ TMFSOle }
|
||
|
||
procedure TMFSOle.Changed;
|
||
begin
|
||
if assigned(FonChange) then FOnChange(Self);
|
||
end;
|
||
|
||
//***
|
||
|
||
Function InputDouble(Caption,Prompt:String; var Value:Double):Boolean;
|
||
var frm: TFrmInput;
|
||
oldval: double;
|
||
begin
|
||
oldval := value;
|
||
frm := TFrmInput.Create(application);
|
||
result := frm.InputDouble(Caption,Prompt,Value);
|
||
//if Value = oldVal then result := False;
|
||
frm.free;
|
||
end;
|
||
|
||
Function InputMemo(Caption,Prompt:String; var Value:String):Boolean;
|
||
var frm: TFrmMemo;
|
||
begin
|
||
frm := TFrmMemo.Create(application);
|
||
result := frm.InPutMemo(Caption,Prompt,Value);
|
||
frm.free;
|
||
end;
|
||
|
||
Function InputInteger(Caption,Prompt:String; var Value:Integer):Boolean;
|
||
var frm: TFrmInput;
|
||
oldval: Integer;
|
||
begin
|
||
oldval := value;
|
||
frm := TFrmInput.Create(application);
|
||
result := frm.InputInteger(Caption,Prompt,Value);
|
||
//if Value = oldVal then result := False;
|
||
|
||
frm.free;
|
||
end;
|
||
|
||
Function InputString(Caption,Prompt:String; var Value:String):Boolean;
|
||
var frm: TFrmInput;
|
||
oldval: String;
|
||
begin
|
||
oldval := value;
|
||
frm := TFrmInput.Create(application);
|
||
result := frm.InputString(Caption,Prompt,Value);
|
||
//if Value = oldVal then result := False;
|
||
|
||
frm.free;
|
||
end;
|
||
|
||
Function InputDoubleEdit(Prompt:String; var Value:Double; px,py:Integer):Boolean;
|
||
var frm: TFrmInput;
|
||
oldval: double;
|
||
begin
|
||
oldval := value;
|
||
frm := TFrmInput.Create(application);
|
||
frm.SetAsEdit(px,py);
|
||
result := frm.InputDouble('',Prompt,Value);
|
||
//if Value = oldVal then result := False;
|
||
frm.free;
|
||
end;
|
||
Function InputStringEdit(Caption,Prompt:String; var Value:String; px,py:Integer):Boolean;
|
||
var frm: TFrmInput;
|
||
oldval: String;
|
||
begin
|
||
oldval := value;
|
||
frm := TFrmInput.Create(application);
|
||
frm.SetAsEdit(px,py);
|
||
result := frm.InputString('',Prompt,Value);
|
||
//if Value = oldVal then result := False;
|
||
frm.free;
|
||
end;
|
||
Function InputIntegerEdit(Prompt:String; var Value:Integer; px,py:Integer):Boolean;
|
||
var frm: TFrmInput;
|
||
oldval: Integer;
|
||
begin
|
||
oldval := value;
|
||
frm := TFrmInput.Create(application);
|
||
frm.SetAsEdit(px,py);
|
||
result := frm.InputInteger('',Prompt,Value);
|
||
//if Value = oldVal then result := False;
|
||
frm.free;
|
||
end;
|
||
|
||
|
||
Function CreateUniqueId:Integer;
|
||
var h,m,s,ms: Word;
|
||
begin
|
||
DecodeTime(now,h,m,s,ms);
|
||
result := ms*234+h*100+m+s*24+random(100);
|
||
end;
|
||
|
||
Function DelphiSetToOleShift(Shift:TShiftState):Integer;
|
||
begin
|
||
result := 0;
|
||
if ssShift in Shift then result := result or oleShift;
|
||
if ssAlt in Shift then result := result or oleAlt;
|
||
if ssCtrl in Shift then result := result or oleCtrl;
|
||
if ssLeft in Shift then result := result or oleLeft;
|
||
if ssRight in Shift then result := result or oleRight;
|
||
if ssMiddle in Shift then result := result or oleMiddle;
|
||
if ssDouble in Shift then result := result or oleDouble;
|
||
end;
|
||
|
||
Function OleShiftToDelphiSet(oleState:Integer):TShiftState;
|
||
begin
|
||
result := [];
|
||
if (oleState and oleShift) = oleShift then result := result+[ssShift];
|
||
if (oleState and oleAlt) = oleAlt then result := result+[ssAlt];
|
||
if (oleState and oleCtrl) = oleCtrl then result := result+[ssCtrl];
|
||
if (oleState and oleLeft) = oleLeft then result := result+[ssLeft];
|
||
if (oleState and oleRight) = oleRight then result := result+[ssRight];
|
||
if (oleState and oleMiddle) = oleMiddle then result := result+[ssMiddle];
|
||
if (oleState and oleDouble) = oleDouble then result := result+[ssDouble];
|
||
end;
|
||
|
||
|
||
function GetJpgdpi(filename:String):Integer;
|
||
CONST
|
||
BufferSize = 50;
|
||
DPI=1; //inch
|
||
DPC=2; //cm
|
||
VAR
|
||
Buffer : STRING;
|
||
index : INTEGER;
|
||
FileStream : TFileStream;
|
||
xResolution: WORD;
|
||
yResolution: WORD;
|
||
typ:Word;
|
||
begin
|
||
result := 0;
|
||
FileStream := TFileStream.Create(filename,
|
||
fmOpenReadWrite);
|
||
TRY
|
||
SetLength(Buffer, BufferSize);
|
||
FileStream.Read(buffer[1], BufferSize);
|
||
index := POS('JFIF'+#$00, buffer);
|
||
IF index > 0
|
||
THEN BEGIN
|
||
FileStream.Seek(index+6, soFromBeginning);
|
||
FileStream.read(typ, 2);
|
||
FileStream.read(xresolution, 2);
|
||
FileStream.read(yresolution, 2);
|
||
result := xresolution;
|
||
if typ = dpc then result := round (result*2.54)
|
||
END
|
||
FINALLY
|
||
FileStream.Free;
|
||
END;
|
||
end;
|
||
|
||
function GetBmpDPI(bmpStream:TStream): LongInt;
|
||
var
|
||
Data: Word;
|
||
A: Double;
|
||
begin
|
||
try
|
||
Result := 0;
|
||
bmpStream.Position := 38;
|
||
if bmpStream.Read(Data,2) = 2 then
|
||
begin
|
||
A := Data;
|
||
Result := Round(A / 39.370079);
|
||
end;
|
||
except
|
||
result := 0;
|
||
end;
|
||
end;
|
||
|
||
function GetBmpDPI(bmpName:String): LongInt;
|
||
var
|
||
Stream: TMemoryStream;
|
||
Data: Word;
|
||
A: Double;
|
||
begin
|
||
try
|
||
Result := 0;
|
||
Stream := TMemoryStream.Create;
|
||
Stream.LoadFromFile(bmpName);
|
||
Stream.Position := 38;
|
||
if Stream.Read(Data,2) = 2 then
|
||
begin
|
||
A := Data;
|
||
Result := Round(A / 39.370079);
|
||
end;
|
||
finally
|
||
Stream.Free;
|
||
end;
|
||
end;
|
||
|
||
|
||
//
|
||
|
||
|
||
Function GetPreviewImage(fileName:String): Graphics.TBitmap;
|
||
var xBmp : Graphics.TBitmap;
|
||
Stream: TFileStream;
|
||
xSize,a: Integer;
|
||
secName:String;
|
||
Version: Word;
|
||
SecCount: Byte;
|
||
sBytes: array [1..8] of Byte;
|
||
begin
|
||
result := nil;
|
||
|
||
Stream := TFileStream.Create(FileName,fmOpenRead or fmShareExclusive);
|
||
for a := 1 to 8 do
|
||
Stream.Read(sBytes[a],1);
|
||
for a := 1 to 8 do
|
||
if sBytes[a] <> signBytes[a] then
|
||
begin
|
||
Stream.free;
|
||
Exit;
|
||
end;
|
||
|
||
Stream.Read(Version,2);
|
||
Stream.Read(SecCount,1);
|
||
|
||
Stream.Read(xSize,4);
|
||
SecName := ReadStringFromStream(Stream);
|
||
if SecName = 'Preview' then
|
||
begin
|
||
xBmp:= Graphics.Tbitmap.Create;
|
||
xBmp.LoadFromStream(Stream);
|
||
result := xbmp;
|
||
end;
|
||
stream.free;
|
||
end;
|
||
|
||
Procedure DrawBitmap(fCanvas:TCanvas; Fbitmap:Graphics.TBitmap;x,y:Integer; Enabled:Boolean);
|
||
const
|
||
ROP_DSPDxax = $00E20746;
|
||
var monobmp:Graphics.Tbitmap;
|
||
IWidth, IHeight: Integer;
|
||
IRect: TRect;
|
||
begin
|
||
if enabled then begin
|
||
fCanvas.Draw(x,y,FBitmap);
|
||
end else begin
|
||
IWidth := Fbitmap.Width;
|
||
IHeight := Fbitmap.Height;
|
||
IRect := Rect(x, y, x+IWidth, y+IHeight);
|
||
MonoBmp := nil;
|
||
MonoBmp := Graphics.TBitmap.Create;
|
||
with MonoBmp do
|
||
begin
|
||
Assign(FBitmap);
|
||
HandleType := bmDDB;
|
||
Canvas.Brush.Color := clBlack;
|
||
Width := IWidth;
|
||
if Monochrome then
|
||
begin
|
||
Canvas.Font.Color := clWhite;
|
||
Monochrome := False;
|
||
Canvas.Brush.Color := clWhite;
|
||
end;
|
||
Monochrome := True;
|
||
end;
|
||
with FCanvas do
|
||
begin
|
||
Brush.Color := clBtnFace;
|
||
FillRect(IRect);
|
||
Brush.Color := clBtnHighlight;
|
||
SetTextColor(Handle, clBlack);
|
||
SetBkColor(Handle, clWhite);
|
||
BitBlt(Handle, x+1, y+1, IWidth, IHeight,
|
||
MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
|
||
Brush.Color := clBtnShadow;
|
||
SetTextColor(Handle, clBlack);
|
||
SetBkColor(Handle, clWhite);
|
||
BitBlt(Handle, x, y, IWidth, IHeight,
|
||
MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
|
||
end;
|
||
monobmp.free;
|
||
end;
|
||
end;
|
||
|
||
Function OleCursor(cr:TCursor):Integer;
|
||
begin
|
||
result := 0;
|
||
case cr of
|
||
crDefault: result := crOleDefault;
|
||
crArrow: result := crOleArrow;
|
||
crCross: result := crOleCross;
|
||
crIBeam: result := crOleIBeam;
|
||
crSize: result := crOleSize;
|
||
crSizeNESW: result := crOleSizeNESW;
|
||
crSizeNS: result := crOleSizeNS;
|
||
crSizeNWSE: result := crOleSizeNWSE;
|
||
crSizeWE: result := crOleSizeWE;
|
||
crUpArrow: result := crOleUpArrow;
|
||
crHourGlass: result := crOleHourGlass;
|
||
crDrag: result := crOleSizeAll;
|
||
crNoDrop: result := crOleNoDrop;
|
||
crHSplit: result := crOleSizeWE;
|
||
crVSplit: result := crOleSizeNS;
|
||
crMultiDrag: result := crOleSizeAll;
|
||
crNo: result := crOleNoDrop;
|
||
crAppStart: result := crOleAppStart;
|
||
crHelp: result := crOleHelp;
|
||
crHandPoint: result := crOleHandPoint;
|
||
end;
|
||
end;
|
||
|
||
|
||
type
|
||
FreePIDLProc = procedure (PIDL: PItemIDList); stdcall;
|
||
var
|
||
ShellHandle: THandle=0;
|
||
|
||
function FolderDialog(Caption: String) : String;
|
||
var
|
||
BrowseInfo: TBrowseInfo;
|
||
ItemIDList: PItemIDList;
|
||
ItemSelected : PItemIDList;
|
||
NameBuffer: array[0..MAX_PATH] of Char;
|
||
WindowList: Pointer;
|
||
Res: Boolean;
|
||
|
||
FreePIDL : FreePIDLProc;
|
||
begin
|
||
Result := '';
|
||
if ShellHandle = 0 then ShellHandle := Windows.LoadLibrary(PChar('shell32.dll'));
|
||
if ShellHandle <> 0 then
|
||
FreePIDL := GetProcAddress(ShellHandle, PChar(155))
|
||
else
|
||
exit;
|
||
itemIDList := nil;
|
||
FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
|
||
BrowseInfo.hwndOwner := Application.Handle;
|
||
BrowseInfo.pidlRoot := ItemIDList;
|
||
BrowseInfo.pszDisplayName := NameBuffer;
|
||
BrowseInfo.lpszTitle := PChar(Caption);
|
||
BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;
|
||
WindowList := DisableTaskWindows(0);
|
||
try
|
||
ItemSelected := SHBrowseForFolder(BrowseInfo);
|
||
Res := ItemSelected <> nil;
|
||
finally
|
||
EnableTaskWindows(WindowList);
|
||
end;
|
||
|
||
if Res then
|
||
begin
|
||
SHGetPathFromIDList(ItemSelected,NameBuffer);
|
||
Result := NameBuffer;
|
||
end;
|
||
Freepidl(BrowseInfo.pidlRoot);
|
||
|
||
end;
|
||
|
||
Procedure RegWrite(IName,IValue:String;Key:String='');overload;
|
||
var
|
||
Reg: TRegistry;
|
||
begin
|
||
try
|
||
Reg := TRegistry.Create;
|
||
Reg.RootKey := HKEY_LOCAL_MACHINE;
|
||
if key = '' then key := '\Software\Tekhnelogos\PowerCad\Settings\';
|
||
if Reg.OpenKey(key,True) then begin
|
||
Reg.WriteString(Iname,IValue);
|
||
end;
|
||
Reg.Free;
|
||
except
|
||
end;
|
||
end;
|
||
|
||
|
||
Procedure RegRead(IName:String; var IValue:String;Key:String='');overload;
|
||
var
|
||
Reg: TRegistry;
|
||
begin
|
||
try
|
||
Reg := TRegistry.Create;
|
||
Reg.RootKey := HKEY_LOCAL_MACHINE;
|
||
if key = '' then key := '\Software\Tekhnelogos\PowerCad\Settings\';
|
||
if Reg.OpenKey(key, True) then begin
|
||
IValue := Reg.readString(Iname);
|
||
end;
|
||
Reg.Free;
|
||
except
|
||
end;
|
||
end;
|
||
|
||
Procedure RegWrite(IName:String;IValue:Integer;Key:String='');overload;
|
||
var
|
||
Reg: TRegistry;
|
||
begin
|
||
try
|
||
Reg := TRegistry.Create;
|
||
Reg.RootKey := HKEY_LOCAL_MACHINE;
|
||
if key = '' then key := '\Software\Tekhnelogos\PowerCad\Settings\';
|
||
if Reg.OpenKey(key, True) then begin
|
||
Reg.WriteInteger(Iname,IValue);
|
||
end;
|
||
Reg.Free;
|
||
except
|
||
end;
|
||
end;
|
||
|
||
Procedure RegRead(IName:String; var IValue:Integer;Key:String='');overload;
|
||
var
|
||
Reg: TRegistry;
|
||
begin
|
||
try
|
||
Reg := TRegistry.Create;
|
||
Reg.RootKey := HKEY_LOCAL_MACHINE;
|
||
if key = '' then key := '\Software\Tekhnelogos\PowerCad\Settings\';
|
||
if Reg.OpenKey(key, True) then begin
|
||
if reg.ValueExists(Iname) then IValue := Reg.readInteger(Iname);
|
||
end;
|
||
Reg.Free;
|
||
except
|
||
end;
|
||
end;
|
||
|
||
Procedure RegWrite(IName:String;IValue:Boolean;Key:String='');overload;
|
||
var
|
||
Reg: TRegistry;
|
||
begin
|
||
try
|
||
Reg := TRegistry.Create;
|
||
Reg.RootKey := HKEY_LOCAL_MACHINE;
|
||
if key = '' then key := '\Software\Tekhnelogos\PowerCad\Settings\';
|
||
if Reg.OpenKey(key, True) then begin
|
||
Reg.WriteBool(Iname,IValue);
|
||
end;
|
||
Reg.Free;
|
||
except
|
||
end;
|
||
end;
|
||
|
||
Procedure RegRead(IName:String; var IValue:Boolean;Key:String='');overload;
|
||
var
|
||
Reg: TRegistry;
|
||
begin
|
||
try
|
||
Reg := TRegistry.Create;
|
||
Reg.RootKey := HKEY_LOCAL_MACHINE;
|
||
if key = '' then key := '\Software\Tekhnelogos\PowerCad\Settings\';
|
||
if Reg.OpenKey(key, True) then begin
|
||
IValue := Reg.readBool(Iname);
|
||
end;
|
||
Reg.Free;
|
||
except
|
||
end;
|
||
end;
|
||
|
||
Procedure MatrixMultiply( cCount: Integer; ml: array of Double; mr : array of Double; var m: array of Double);
|
||
var a,b,c: Integer;
|
||
begin
|
||
for a:=0 to cCount-1 do
|
||
for b:=0 to cCount-1 do
|
||
for c:=0 to cCount-1 do
|
||
begin
|
||
m[(a*4)+b] := m[(a*4)+b] + mr[(a*4)+c] * ml[(c*4)+b];
|
||
end;
|
||
end;
|
||
Procedure CloseFace(var Face:T3dFace);
|
||
begin
|
||
SetLength(Face,Length(Face)+1);
|
||
Face[Length(Face)-1] := Face[0];
|
||
end;
|
||
|
||
Function MakeFloat(str:String;def:Extended):Extended;
|
||
begin
|
||
if not TextToFloat(PChar(str), result, fvExtended) then result := def;
|
||
end;
|
||
|
||
Function BByte(Value:Boolean):Byte;
|
||
begin
|
||
result := 0;
|
||
if Value then result := 1;
|
||
end;
|
||
|
||
Function BBool(Value:Byte):Boolean;
|
||
begin
|
||
Result := (Value =1);
|
||
end;
|
||
|
||
Function DoubleRound(Val:Double; Dec:Integer):Double;
|
||
begin
|
||
result := Round(Val* Power(10,Dec))/Power(10,Dec);
|
||
end;
|
||
|
||
Function RoundUp(Val:Double):Integer;
|
||
begin
|
||
SetRoundMode(rmUp);
|
||
result := Round(Val);
|
||
SetRoundMode(rmNearest);
|
||
end;
|
||
|
||
Function AddToFileName(FName,add:String):String;
|
||
var fExt:String;
|
||
begin
|
||
fExt := ExtractFileExt(Fname);
|
||
FName := Copy(Fname,1,Length(Fname)-Length(fExt));
|
||
FName := Fname+add+fExt;
|
||
result := fName;
|
||
end;
|
||
|
||
Function RegInReg(inReg,Reg:Integer):Boolean;
|
||
var r: TRect;
|
||
p1,p2,p3,p4:TPoint;
|
||
a1,a2,a3,a4: Boolean;
|
||
begin
|
||
GetRgnBox(inReg,r);
|
||
p1 := Point(r.left+2,r.top+2);
|
||
p2 := Point(r.right-2,r.top+2);
|
||
p3 := Point(r.right-2,r.Bottom-2);
|
||
p4 := Point(r.Left+2,r.Bottom-2);
|
||
|
||
a1 := ptInRegion(reg,p1.x,p1.y);
|
||
a2 := ptInRegion(reg,p2.x,p2.y);
|
||
a3 := ptInRegion(reg,p3.x,p3.y);
|
||
a4 := ptInRegion(reg,p4.x,p4.y);
|
||
result := a1 and a2 and a3 and a4;
|
||
end;
|
||
|
||
function GetColorBetween(StartColor, EndColor: TColor; Pointvalue,
|
||
Von, Bis : Extended): TColor;
|
||
var
|
||
F: Extended; r1, r2, r3, g1, g2, g3, b1, b2, b3: Byte;
|
||
|
||
function CalcColorBytes(fb1, fb2: Byte): Byte;
|
||
begin
|
||
result := fb1;
|
||
if fb1 < fb2 then Result := FB1 + Trunc(F * (fb2 - fb1));
|
||
if fb1 > fb2 then Result := FB1 - Trunc(F * (fb1 - fb2));
|
||
end;
|
||
|
||
begin
|
||
if Pointvalue <= Von then begin
|
||
result := StartColor;
|
||
exit;
|
||
end;
|
||
if Pointvalue >= Bis then begin
|
||
result := EndColor;
|
||
exit;
|
||
end;
|
||
F := (Pointvalue - von) / (Bis - Von);
|
||
asm
|
||
mov EAX, Startcolor
|
||
cmp EAX, EndColor
|
||
je @@exit
|
||
mov r1, AL
|
||
shr EAX,8
|
||
mov g1, AL
|
||
shr Eax,8
|
||
mov b1, AL
|
||
mov Eax, Endcolor
|
||
mov r2, AL
|
||
shr EAX,8
|
||
mov g2, AL
|
||
shr EAX,8
|
||
mov b2, AL
|
||
push ebp
|
||
mov al, r1
|
||
mov dl, r2
|
||
call CalcColorBytes
|
||
pop ecx
|
||
push ebp
|
||
Mov r3, al
|
||
mov dL, g2
|
||
mov al, g1
|
||
call CalcColorBytes
|
||
pop ecx
|
||
push ebp
|
||
mov g3, Al
|
||
mov dL, B2
|
||
mov Al, B1
|
||
call CalcColorBytes
|
||
pop ecx
|
||
mov b3, al
|
||
XOR EAX,EAX
|
||
mov AL, B3
|
||
SHL EAX,8
|
||
mov AL, G3
|
||
SHL EAX,8
|
||
mov AL, R3
|
||
@@Exit:
|
||
mov @result, eax
|
||
end;
|
||
end;
|
||
|
||
Function MakeRgb(r,g,b:Double):TRGB;
|
||
begin
|
||
result.R := r;
|
||
result.G := g;
|
||
result.B := b;
|
||
end;
|
||
procedure DrawGradientBox(DC: HDC; const R: TRect; Colors: array of TRGB);
|
||
|
||
// Draws a box with a gradient for all four corners.
|
||
// The Colors parameter carries the required colors where
|
||
// index 0 contains the color for the left-upper corner and the others keep the colors for the remaining vertices
|
||
// in clock-wise direction. If there are less color than there are corners then the missing colors are derived from the
|
||
// last given color by simply copying it.
|
||
|
||
var
|
||
Vertices: array[0..3] of TTriVertex;
|
||
Triangles: array[0..1] of TGradientTriangle;
|
||
LastColor: TRGB;
|
||
|
||
//--------------- local functions
|
||
|
||
|
||
procedure FillVertex(Index: Integer; X, Y: Integer);
|
||
|
||
begin
|
||
Vertices[Index].x := X;
|
||
Vertices[Index].y := Y;
|
||
if Length(Colors) > Index then
|
||
begin
|
||
Vertices[Index].Red := Round($FF00 * Colors[Index].R);
|
||
Vertices[Index].Green := Round($FF00 * Colors[Index].G);
|
||
Vertices[Index].Blue := Round($FF00 * Colors[Index].B);
|
||
LastColor := MakeRGB(Vertices[Index].Red, Vertices[Index].Green,Vertices[Index].Blue);
|
||
end
|
||
else
|
||
begin
|
||
Vertices[Index].Red := Round(LastColor.R);
|
||
Vertices[Index].Green := Round(LastColor.R);
|
||
Vertices[Index].Blue := Round(LastColor.R);
|
||
end;
|
||
// Alpha is ignored by GradientFill.
|
||
Vertices[Index].Alpha := 0;
|
||
end;
|
||
|
||
//--------------- end local functions
|
||
|
||
|
||
begin
|
||
// Colors in GradientFill are scaled by 256 to enhance resolution.
|
||
LastColor := MakeRGB($FF00, $FF00, $FF00);
|
||
|
||
// Fill 4 vertices...
|
||
FillVertex(0, R.Left, R.Top);
|
||
FillVertex(1, R.Right, R.Top);
|
||
FillVertex(2, R.Right, R.Bottom);
|
||
FillVertex(3, R.Left, R.Bottom);
|
||
|
||
// ... and 2 triangles. Two vertices are shared between both triangles.
|
||
Triangles[0].Vertex1 := 0;
|
||
Triangles[0].Vertex2 := 1;
|
||
Triangles[0].Vertex3 := 2;
|
||
|
||
Triangles[1].Vertex1 := 2;
|
||
Triangles[1].Vertex2 := 3;
|
||
Triangles[1].Vertex3 := 0;
|
||
|
||
GradientFill(DC, Vertices[0], 4, Triangles[0], 2,GRADIENT_FILL_TRIANGLE);
|
||
|
||
end;
|
||
|
||
Type
|
||
TScanRow = array[0..1024] of TRGBTriple;
|
||
PScanRow = ^TScanRow;
|
||
|
||
|
||
Procedure MakeGradBitmap(ColorBegin,ColorEnd:TColor;GStyle:TGradStyle;var GradBmp:Graphics.TBitmap);
|
||
var rgbBegin,rgbEnd: TColor;
|
||
rgbTriple1,rgbTriple2: TRGBTriple;
|
||
i,m: Integer;
|
||
deltaRed, deltaGreen, deltaBlue: Integer;
|
||
GradColors: array[0..255] of TRGBTriple;
|
||
X, Y: Integer;
|
||
Row: PScanRow;
|
||
TempX,TempY: Integer;
|
||
TempXs: array[0..500] of Integer;
|
||
TempYs: array[0..500] of Integer;
|
||
begin
|
||
if GradBmp = nil then begin
|
||
GradBmp := Graphics.TBitmap.Create;
|
||
GradBmp.PixelFormat := pf24bit;
|
||
end;
|
||
|
||
rgbBegin := ColorToRGB(ColorBegin);
|
||
rgbEnd := ColorToRGB(ColorEnd);
|
||
rgbTriple1.rgbtRed := GetRValue(rgbBegin);
|
||
rgbTriple1.rgbtGreen := GetGValue(rgbBegin);
|
||
rgbTriple1.rgbtBlue := GetBValue(rgbBegin);
|
||
|
||
rgbTriple2.rgbtRed := GetRValue(rgbEnd);
|
||
rgbTriple2.rgbtGreen := GetGValue(rgbEnd);
|
||
rgbTriple2.rgbtBlue := GetBValue(rgbEnd);
|
||
|
||
deltaRed := rgbTriple2.rgbtRed - rgbTriple1.rgbtRed;
|
||
deltaGreen := rgbTriple2.rgbtGreen - rgbTriple1.rgbtGreen;
|
||
deltaBlue := rgbTriple2.rgbtBlue - rgbTriple1.rgbtBlue;
|
||
m := MulDiv(255, 0, 100);
|
||
if m = 0 then begin
|
||
for i := 0 to 255 do
|
||
with GradColors[i] do
|
||
begin
|
||
rgbtRed := rgbTriple1.rgbtRed + (i * deltaRed) div 255;
|
||
rgbtGreen := rgbTriple1.rgbtGreen + (i * deltaGreen) div 255;
|
||
rgbtBlue := rgbTriple1.rgbtBlue + (i * deltaBlue) div 255;
|
||
end;
|
||
end else if m > 0 then
|
||
begin
|
||
m := 255 - m;
|
||
for i := 0 to m - 1 do
|
||
with GradColors[i] do
|
||
begin
|
||
rgbtRed := rgbTriple1.rgbtRed + (i * deltaRed) div m;
|
||
rgbtGreen := rgbTriple1.rgbtGreen + (i * deltaGreen) div m;
|
||
rgbtBlue := rgbTriple1.rgbtBlue + (i * deltaBlue) div m;
|
||
end;
|
||
for i := m to 255 do
|
||
with GradColors[i] do
|
||
begin
|
||
rgbtRed := rgbTriple1.rgbtRed + ((255 - i) * deltaRed) div (255 - m);
|
||
rgbtGreen := rgbTriple1.rgbtGreen + ((255 - i) * deltaGreen) div (255 - m);
|
||
rgbtBlue := rgbTriple1.rgbtBlue + ((255 - i) * deltaBlue) div (255 - m);
|
||
end;
|
||
end
|
||
else if m < 0 then
|
||
begin
|
||
m := -m;
|
||
for i := 0 to m do
|
||
with GradColors[i] do
|
||
begin
|
||
rgbtRed := rgbTriple2.rgbtRed - (m * deltaRed) div m;
|
||
rgbtGreen := rgbTriple2.rgbtGreen - (m * deltaGreen) div m;
|
||
rgbtBlue := rgbTriple2.rgbtBlue - (m * deltaBlue) div m;
|
||
end;
|
||
for i := m + 1 to 255 do
|
||
with GradColors[i] do
|
||
begin
|
||
rgbtRed := rgbTriple2.rgbtRed - ((255 - i) * deltaRed) div (255 - m);
|
||
rgbtGreen := rgbTriple2.rgbtGreen - ((255 - i) * deltaGreen) div (255 - m);
|
||
rgbtBlue := rgbTriple2.rgbtBlue - ((255 - i) * deltaBlue) div (255 - m);
|
||
end;
|
||
end;
|
||
|
||
Case GStyle of
|
||
gsRadCenter:
|
||
begin
|
||
GradBmp.Width := 362;
|
||
GradBmp.Height := 362;
|
||
for X := 0 to 180 do
|
||
begin
|
||
TempX := 180 - X;
|
||
TempXs[X] := TempX * TempX;
|
||
end;
|
||
for X := 181 to 361 do
|
||
begin
|
||
TempX := X - 181;
|
||
TempXs[X] := TempX * TempX;
|
||
end;
|
||
for Y := 0 to 361 do
|
||
begin
|
||
TempY := 180 - Y;
|
||
TempY := TempY * TempY;
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 361 do
|
||
Row[X] := GradColors[Round(Sqrt(TempXs[X] + TempY))];
|
||
end;
|
||
end;
|
||
|
||
gsRadTop:
|
||
begin
|
||
GradBmp.Width := 362;
|
||
GradBmp.Height := 181;
|
||
for X := 0 to 180 do
|
||
begin
|
||
TempX := 180 - X;
|
||
TempXs[X] := TempX * TempX;
|
||
end;
|
||
for X := 181 to 361 do
|
||
begin
|
||
TempX := X - 181;
|
||
TempXs[X] := TempX * TempX;
|
||
end;
|
||
for Y := 0 to 180 do
|
||
begin
|
||
TempY := Y * Y;
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 361 do
|
||
Row[X] := GradColors[Round(Sqrt(TempXs[X] + TempY))];
|
||
end;
|
||
end;
|
||
gsRadBottom:
|
||
begin
|
||
GradBmp.Width := 362;
|
||
GradBmp.Height := 181;
|
||
for X := 0 to 180 do
|
||
begin
|
||
TempX := 180 - X;
|
||
TempXs[X] := TempX * TempX;
|
||
end;
|
||
for X := 181 to 361 do
|
||
begin
|
||
TempX := X - 181;
|
||
TempXs[X] := TempX * TempX;
|
||
end;
|
||
for Y := 0 to 180 do
|
||
begin
|
||
TempY := 180 - Y;
|
||
TempY := TempY * TempY;
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 361 do
|
||
Row[X] := GradColors[Round(Sqrt(TempXs[X] + TempY))];
|
||
end;
|
||
end;
|
||
gsRadLeft:
|
||
begin
|
||
GradBmp.Width := 181;
|
||
GradBmp.Height := 362;
|
||
for Y := 0 to 180 do
|
||
begin
|
||
TempY := 180 - Y;
|
||
TempYs[Y] := TempY * TempY;
|
||
end;
|
||
for Y := 181 to 361 do
|
||
begin
|
||
TempY := Y - 181;
|
||
TempYs[Y] := TempY * TempY;
|
||
end;
|
||
for Y := 0 to 361 do
|
||
begin
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 180 do
|
||
Row[X] := GradColors[Round(Sqrt(X * X + TempYs[Y]))];
|
||
end;
|
||
end;
|
||
gsRadRight:
|
||
begin
|
||
GradBmp.Width := 181;
|
||
GradBmp.Height := 362;
|
||
for X := 0 to 180 do
|
||
begin
|
||
TempX := 180 - X;
|
||
TempXs[X] := TempX * TempX;
|
||
end;
|
||
for Y := 0 to 180 do
|
||
begin
|
||
TempY := 180 - Y;
|
||
TempYs[Y] := TempY * TempY;
|
||
end;
|
||
for Y := 181 to 361 do
|
||
begin
|
||
TempY := Y - 181;
|
||
TempYs[Y] := TempY * TempY;
|
||
end;
|
||
for Y := 0 to 361 do
|
||
begin
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 180 do
|
||
Row[X] := GradColors[Round(Sqrt(TempXs[X] + TempYs[Y]))];
|
||
end;
|
||
end;
|
||
gsRadTopLeft:
|
||
begin
|
||
GradBmp.Width := 181;
|
||
GradBmp.Height := 181;
|
||
for X := 0 to 180 do
|
||
TempXs[X] := X * X;
|
||
for Y := 0 to 180 do
|
||
begin
|
||
TempY := Y * Y;
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 180 do
|
||
Row[X] := GradColors[Round(Sqrt(TempXs[X] + TempY))];
|
||
end;
|
||
end;
|
||
gsRadTopRight:
|
||
begin
|
||
GradBmp.Width := 181;
|
||
GradBmp.Height := 181;
|
||
for X := 0 to 180 do
|
||
begin
|
||
TempX := 180 - X;
|
||
TempXs[X] := TempX * TempX;
|
||
end;
|
||
for Y := 0 to 180 do
|
||
begin
|
||
TempY := Y * Y;
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 180 do
|
||
Row[X] := GradColors[Round(Sqrt(TempXs[X] + TempY))];
|
||
end;
|
||
end;
|
||
gsRadBottomLeft:
|
||
begin
|
||
GradBmp.Width := 181;
|
||
GradBmp.Height := 181;
|
||
for X := 0 to 180 do
|
||
TempXs[X] := X * X;
|
||
for Y := 0 to 180 do
|
||
begin
|
||
TempY := 180 - Y;
|
||
TempY := TempY * TempY;
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 180 do
|
||
Row[X] := GradColors[Round(Sqrt(TempXs[X] + TempY))];
|
||
end;
|
||
end;
|
||
gsRadBottomRight:
|
||
begin
|
||
GradBmp.Width := 181;
|
||
GradBmp.Height := 181;
|
||
for X := 0 to 180 do
|
||
begin
|
||
TempX := 180 - X;
|
||
TempXs[X] := TempX * TempX;
|
||
end;
|
||
for Y := 0 to 180 do
|
||
begin
|
||
TempY := 180 - Y;
|
||
TempY := TempY * TempY;
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 180 do
|
||
Row[X] := GradColors[Round(Sqrt(TempXs[X] + TempY))];
|
||
end;
|
||
end;
|
||
gsLineHorz:
|
||
begin
|
||
GradBmp.Width := 1;
|
||
GradBmp.Height := 256;
|
||
for Y := 0 to 255 do
|
||
begin
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
Row[0] := GradColors[Y];
|
||
end;
|
||
end;
|
||
gsLineVert:
|
||
begin
|
||
GradBmp.Width := 256;
|
||
GradBmp.Height := 1;
|
||
Row := PScanRow(GradBmp.ScanLine[0]);
|
||
for X := 0 to 255 do
|
||
Row[X] := GradColors[X];
|
||
end;
|
||
gsRefHorz:
|
||
begin
|
||
GradBmp.Width := 1;
|
||
GradBmp.Height := 512;
|
||
for Y := 0 to 255 do
|
||
begin
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
Row[0] := GradColors[255 - Y];
|
||
Row := PScanRow(GradBmp.ScanLine[511 - Y]);
|
||
Row[0] := GradColors[255 - Y];
|
||
end;
|
||
end;
|
||
gsRefVert:
|
||
begin
|
||
GradBmp.Width := 512;
|
||
GradBmp.Height := 1;
|
||
Row := PScanRow(GradBmp.ScanLine[0]);
|
||
for X := 0 to 255 do
|
||
begin
|
||
Row[X] := GradColors[255 - X];
|
||
Row[511 - X] := GradColors[255 - X];
|
||
end;
|
||
end;
|
||
gsDiagLineF:
|
||
begin
|
||
GradBmp.Width := 128;
|
||
GradBmp.Height := 129;
|
||
for Y := 0 to 128 do
|
||
begin
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 127 do
|
||
Row[X] := GradColors[127 + (Y - X)];
|
||
end;
|
||
end;
|
||
gsDiagLineB:
|
||
begin
|
||
GradBmp.Width := 128;
|
||
GradBmp.Height := 129;
|
||
for Y := 0 to 128 do
|
||
begin
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 127 do
|
||
Row[X] := GradColors[X + Y];
|
||
end;
|
||
end;
|
||
gsDiagRefF:
|
||
begin
|
||
GradBmp.Width := 256;
|
||
GradBmp.Height := 256;
|
||
for Y := 0 to 255 do
|
||
begin
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 255 do
|
||
if X > Y then
|
||
Row[X] := GradColors[X - Y]
|
||
else
|
||
Row[X] := GradColors[Y - X];
|
||
end;
|
||
end;
|
||
gsDiagRefB:
|
||
begin
|
||
GradBmp.Width := 256;
|
||
GradBmp.Height := 256;
|
||
for Y := 0 to 255 do
|
||
begin
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 255 do
|
||
if X + Y < 255 then
|
||
Row[X] := GradColors[255 - (X + Y)]
|
||
else
|
||
Row[X] := GradColors[(Y + X) - 255];
|
||
end;
|
||
end;
|
||
gsArrowLeft:
|
||
begin
|
||
GradBmp.Width := 129;
|
||
GradBmp.Height := 256;
|
||
for Y := 0 to 127 do
|
||
begin
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 128 do
|
||
Row[X] := GradColors[255 - (X + Y)];
|
||
end;
|
||
for Y := 128 to 255 do
|
||
begin
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 128 do
|
||
Row[X] := GradColors[Y - X];
|
||
end;
|
||
end;
|
||
gsArrowRight:
|
||
begin
|
||
GradBmp.Width := 129;
|
||
GradBmp.Height := 256;
|
||
for Y := 0 to 127 do
|
||
begin
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 128 do
|
||
Row[X] := GradColors[(X - Y) + 127];
|
||
end;
|
||
for Y := 128 to 255 do
|
||
begin
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 128 do
|
||
Row[X] := GradColors[(X + Y) - 128];
|
||
end;
|
||
end;
|
||
gsArrowUp:
|
||
begin
|
||
GradBmp.Width := 256;
|
||
GradBmp.Height := 129;
|
||
for Y := 0 to 128 do
|
||
begin
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 127 do
|
||
Row[X] := GradColors[255 - (X + Y)];
|
||
for X := 128 to 255 do
|
||
Row[X] := GradColors[X - Y];
|
||
end;
|
||
end;
|
||
gsArrowDown:
|
||
begin
|
||
GradBmp.Width := 256;
|
||
GradBmp.Height := 129;
|
||
for Y := 0 to 128 do
|
||
begin
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 127 do
|
||
Row[X] := GradColors[127 + (Y - X)];
|
||
for X := 128 to 255 do
|
||
Row[X] := GradColors[(X + Y) - 128];
|
||
end;
|
||
end;
|
||
gsQuadrant:
|
||
begin
|
||
GradBmp.Width := 256;
|
||
GradBmp.Height := 256;
|
||
for Y := 0 to 127 do
|
||
begin
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 127 do
|
||
Row[X] := GradColors[255 - (X + Y)];
|
||
for X := 128 to 255 do
|
||
Row[X] := GradColors[X - Y];
|
||
end;
|
||
for Y := 128 to 255 do
|
||
begin
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 127 do
|
||
Row[X] := GradColors[Y - X];
|
||
for X := 128 to 255 do
|
||
Row[X] := GradColors[(X + Y) - 255];
|
||
end;
|
||
end;
|
||
gsMirrored:
|
||
begin
|
||
GradBmp.Width := 256;
|
||
GradBmp.Height := 256;
|
||
for Y := 0 to 127 do
|
||
begin
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 127 do
|
||
Row[X] := GradColors[(X - Y) + 128];
|
||
for X := 128 to 255 do
|
||
Row[X] := GradColors[383 - (X + Y)];
|
||
end;
|
||
for Y := 128 to 255 do
|
||
begin
|
||
Row := PScanRow(GradBmp.ScanLine[Y]);
|
||
for X := 0 to 127 do
|
||
Row[X] := GradColors[(X + Y) - 128];
|
||
for X := 128 to 255 do
|
||
Row[X] := GradColors[128 + (Y - X)];
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
end;
|
||
|
||
|
||
Function AddFileExt(Fname,FExt:String):String;
|
||
var xExt: String;
|
||
begin
|
||
xExt:= lowercase(ExtractFileExt(fNAme));
|
||
if xExt <> lowercase(fExt) then fName := fName+fExt;
|
||
result := fName;
|
||
end;
|
||
|
||
function RegisterAssociation(const aExeName, aFileExt, aFileDesc,aFileIcon: string): Boolean;
|
||
{
|
||
This function registers a file association.
|
||
|
||
ExeName is the full path and name of the exe that will be associated
|
||
with the extension.
|
||
FileExt is the extension of the file to register i.e. ".dxf" or ".ord".
|
||
FileDesc is the description of the file. i.e. "Drawing Exchange File".
|
||
FileIcon is the location of the icon to associate with this file type.
|
||
For example "C:\MyApplicationLocation\Myapplication.exe,0"
|
||
Note the ",0" means use the icon associated with the .exe.
|
||
You can also say ",1" to use the next icon, if one exists.
|
||
Or you can pass the name of the icon itself such as:
|
||
"C:\MyApplication\Icons\MyIcon.ico".
|
||
Note: You may have to re-boot the PC before the associated icon will
|
||
change.
|
||
Note: When end user double clicks on the registered file type, your .exe
|
||
will launch, and the file name will be passed via ParamStr(1).
|
||
(If the file name contains spaces, then it may also be passed in
|
||
ParamStr(2), etc.)
|
||
}
|
||
var
|
||
sFileClass, sFileExt: string;
|
||
begin
|
||
Result := False;
|
||
|
||
sFileExt := Trim(aFileExt);
|
||
|
||
if (sFileExt = '') then
|
||
Exit;
|
||
|
||
if (sFileExt[1] <> '.') then
|
||
sFileExt := '.' + sFileExt;
|
||
|
||
sFileClass := Copy(sFileExt, 2, Length(sFileExt)) + 'file';
|
||
|
||
with TRegistry.Create do begin
|
||
try
|
||
RootKey := HKEY_CLASSES_ROOT;
|
||
|
||
if OpenKey(sFileExt, True) then begin
|
||
WriteString('', sFileClass);
|
||
CloseKey;
|
||
end;
|
||
|
||
if OpenKey(sFileClass, True) then begin
|
||
WriteString('', aFileDesc);
|
||
CloseKey;
|
||
end;
|
||
|
||
if OpenKey(sFileClass + '\Shell\Open', True) then begin
|
||
WriteString('', '&Open');
|
||
CloseKey;
|
||
end;
|
||
|
||
if OpenKey(sFileClass + '\Shell\Open\command', True) then begin
|
||
WriteString('', aExeName + ' %1');
|
||
CloseKey;
|
||
Result := True;
|
||
end;
|
||
|
||
{Register an icon file with the application.}
|
||
if OpenKey(sFileClass + '\DefaultIcon', True) then begin
|
||
WriteString('', aFileIcon);
|
||
CloseKey;
|
||
end;
|
||
|
||
finally
|
||
Free;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
|
||
{ TFaceRecord }
|
||
|
||
constructor TFaceRecord.Create(fPoints: T3DPointArray; xColor: Tcolor; xType:TFaceType; xsize:Double=0.1;oTrans:Boolean=False; aFigure: TObject = nil; aComponID: Integer = 0);
|
||
var
|
||
pCnt, i: Integer;
|
||
begin
|
||
inherited Create;
|
||
SetLength(PointsForNormal, 0);
|
||
pCnt := Length(fPoints);
|
||
SetLength(Points,pCnt);
|
||
for i := 0 to pCnt - 1 do
|
||
Points[i] := fPoints[i];
|
||
Color := xColor;
|
||
RecType := xType;
|
||
Normal := DoublePOint(0,0,1);
|
||
Size := xSize;
|
||
Trans := False;
|
||
OpTrans := oTrans;
|
||
FFigure := aFigure;
|
||
FFaceWallType := fwtNone;
|
||
FWallSideType := wstNone;
|
||
FComponID := aComponID;
|
||
FTreeNode := nil;
|
||
// 22.07.2011
|
||
F3DObject := nil;
|
||
end;
|
||
Destructor TFaceRecord.Destroy;
|
||
begin
|
||
FFigure := nil;
|
||
SetLength(Points, 0);
|
||
SetLength(PointsForNormal, 0);
|
||
inherited;
|
||
end;
|
||
|
||
procedure GetVerInfo(forModule: tHandle; var V1, V2, V3, V4: Word);
|
||
var
|
||
VerInfoSize: {$IFDEF WIN32} DWORD {$ELSE} WORD {$ENDIF};
|
||
VerInfo:Pointer;
|
||
VerValueSize: {$IFDEF WIN32} DWORD {$ELSE} WORD {$ENDIF};
|
||
VerValue:{$IFDEF WIN32} PVSFixedFileInfo {$ELSE} Pvs_FixedFileInfo
|
||
{$ENDIF};
|
||
Dummy:{$IFDEF WIN32}DWORD{$ELSE}Longint{$ENDIF};
|
||
ForFile: pChar;//array[0..max_path] of char;
|
||
fName: String;
|
||
begin
|
||
V1 := 0;
|
||
V2 := 0;
|
||
V3 := 0;
|
||
V4 := 0;
|
||
//if forModule = 0 then exit;
|
||
//if GetModuleFilename(forModule,@ForFile,max_path) = 0 then exit;
|
||
fName := application.ExeName;
|
||
ForFile := pChar(fName);
|
||
VerInfoSize := GetFileVersionInfoSize(ForFile, Dummy);
|
||
if VerInfoSize = 0 then exit;
|
||
GetMem(VerInfo, VerInfoSize);
|
||
GetFileVersionInfo(ForFile, 0, VerInfoSize, VerInfo);
|
||
VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);
|
||
with VerValue^ do
|
||
begin
|
||
V1 := dwFileVersionMS shr 16;
|
||
V2 := dwFileVersionMS and $FFFF;
|
||
V3 := dwFileVersionLS shr 16;
|
||
V4 := dwFileVersionLS and $FFFF;
|
||
end;
|
||
FreeMem(VerInfo, VerInfoSize);
|
||
end;
|
||
|
||
Function Like(s1,s2:String):Boolean;
|
||
var sarr1,sarr2:TStringArray;
|
||
begin
|
||
s1 := uppercase(Trim(s1));
|
||
s2 := uppercase(Trim(s2));
|
||
result := (s1 =s2);
|
||
|
||
if not result then begin
|
||
splitstr(s1,sarr1,' ');
|
||
splitstr(s2,sarr2,' ');
|
||
if (length(sarr1) > 0) and (length(sarr2) > 0) then
|
||
result := (sarr1[0] = sarr2[0]);
|
||
end;
|
||
end;
|
||
|
||
Function GetPointsDist(Points:TDoublePOintArr):Double;
|
||
var i,k,cnt:Integer;
|
||
len:Double;
|
||
p1,p2:TDoublePoint;
|
||
begin
|
||
result := 0;
|
||
cnt := Length(points);
|
||
for i := 0 to cnt-2 do begin
|
||
p1 := Points[i];
|
||
for k := i+1 to cnt-1 do
|
||
begin
|
||
p2 := points[k];
|
||
len := GetLineLength(p1,p2,false);
|
||
if len > result then result := len;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
Const
|
||
HexDigits:String = '0123456789ABCDEF';
|
||
|
||
|
||
Function ByteToHexStr(val:Byte):String;
|
||
var c1,c2: Byte;
|
||
begin
|
||
c2 := val div 16;
|
||
c1 := val mod 16;
|
||
result := HexDigits[c2+1]+HexDigits[c1+1];
|
||
end;
|
||
|
||
|
||
Function GetHexVal(str:String):Byte;
|
||
begin
|
||
if str = '0' then result := 0
|
||
else if str = '1' then result := 1
|
||
else if str = '2' then result := 2
|
||
else if str = '3' then result := 3
|
||
else if str = '4' then result := 4
|
||
else if str = '5' then result := 5
|
||
else if str = '6' then result := 6
|
||
else if str = '7' then result := 7
|
||
else if str = '8' then result := 8
|
||
else if str = '9' then result := 9
|
||
else if str = 'A' then result := 10
|
||
else if str = 'B' then result := 11
|
||
else if str = 'C' then result := 12
|
||
else if str = 'D' then result := 13
|
||
else if str = 'E' then result := 14
|
||
else if str = 'F' then result := 15;
|
||
|
||
end;
|
||
|
||
Function HexStrToByte(val:String):Byte;
|
||
var c1,c2: String;
|
||
begin
|
||
|
||
c2 := val[1];
|
||
c1 := val[2];
|
||
result := GetHexVal(c2)*16+GetHexVal(c1);
|
||
|
||
end;
|
||
|
||
function RefToCell(ARow, ACol: Integer): string;
|
||
var ch: AnsiChar;
|
||
begin
|
||
Ch := 'A';
|
||
//Result := Chr(Ord('A') + ACol - 1) + IntToStr(ARow);
|
||
Result := String(AnsiChar(ORD(Ch) + ACol - 1) + IntToStr(ARow));
|
||
end;
|
||
|
||
function SaveAsExcelFile(AGrid: TStringGrid; ASheetName, AFileName: string): Boolean;
|
||
const
|
||
xlWBATWorksheet = -4167;
|
||
var
|
||
Row, Col: Integer;
|
||
GridPrevFile: string;
|
||
XLApp, Sheet, Data: OLEVariant;
|
||
i, j: Integer;
|
||
cText: String;
|
||
begin
|
||
// Prepare Data
|
||
Data := VarArrayCreate([1, AGrid.RowCount, 1, AGrid.ColCount], varVariant);
|
||
for i := 0 to AGrid.ColCount - 1 do
|
||
for j := 0 to AGrid.RowCount - 1 do
|
||
begin
|
||
cText := AGrid.Cells[i, j];
|
||
cText := StringReplace(cText,'<B>','',[rfReplaceAll]);
|
||
cText := StringReplace(cText,'<C>','',[rfReplaceAll]);
|
||
cText := StringReplace(cText,'<L>','',[rfReplaceAll]);
|
||
cText := StringReplace(cText,'<I>','',[rfReplaceAll]);
|
||
cText := StringReplace(cText,'YTL','',[rfReplaceAll]);
|
||
cText := StringReplace(cText,'.','',[rfReplaceAll]);
|
||
cText := StringReplace(cText,',','.',[rfReplaceAll]);
|
||
Data[j + 1, i + 1] := cText;
|
||
end;
|
||
// Create Excel-OLE Object
|
||
Result := False;
|
||
XLApp := CreateOleObject('Excel.Application');
|
||
try
|
||
// Hide Excel
|
||
XLApp.Visible := True;
|
||
// Add new Workbook
|
||
XLApp.Workbooks.Add(xlWBatWorkSheet);
|
||
Sheet := XLApp.Workbooks[1].WorkSheets[1];
|
||
Sheet.Name := ASheetName;
|
||
// Fill up the sheet
|
||
Sheet.Range[RefToCell(1, 1), RefToCell(AGrid.RowCount,
|
||
AGrid.ColCount)].Value := Data;
|
||
// Save Excel Worksheet
|
||
try
|
||
XLApp.Workbooks[1].SaveAs(AFileName);
|
||
Result := True;
|
||
except
|
||
// Error ?
|
||
end;
|
||
finally
|
||
// Quit Excel
|
||
if not VarIsEmpty(XLApp) then
|
||
begin
|
||
XLApp.DisplayAlerts := False;
|
||
//XLApp.Quit;
|
||
XLAPP := Unassigned;
|
||
Sheet := Unassigned;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
procedure PrintGrid(sGrid: TStringGrid; sTitle: string);
|
||
var
|
||
X1, X2: Integer;
|
||
Y1, Y2: Integer;
|
||
TmpI: Integer;
|
||
F: Integer;
|
||
TR: TRect;
|
||
cText: String;
|
||
begin
|
||
Printer.Title := sTitle;
|
||
Printer.BeginDoc;
|
||
Printer.Canvas.Pen.Color := 0;
|
||
Printer.Canvas.Font.Name := 'Times New Roman';
|
||
Printer.Canvas.Font.Size := 12;
|
||
Printer.Canvas.Font.Style := [fsBold, fsUnderline];
|
||
Printer.Canvas.TextOut(0, 100, Printer.Title);
|
||
for F := 1 to sGrid.ColCount - 1 do
|
||
begin
|
||
X1 := 0;
|
||
for TmpI := 1 to (F - 1) do
|
||
X1 := X1 + 5 * (sGrid.ColWidths[TmpI]);
|
||
Y1 := 300;
|
||
X2 := 0;
|
||
for TmpI := 1 to F do
|
||
X2 := X2 + 5 * (sGrid.ColWidths[TmpI]);
|
||
Y2 := 450;
|
||
TR := Rect(X1, Y1, X2 - 30, Y2);
|
||
Printer.Canvas.Font.Style := [fsBold];
|
||
Printer.Canvas.Font.Size := 7;
|
||
Printer.Canvas.TextRect(TR, X1 + 50, 350, sGrid.Cells[F, 0]);
|
||
Printer.Canvas.Font.Style := [];
|
||
for TmpI := 1 to sGrid.RowCount - 1 do
|
||
begin
|
||
Y1 := 150 * TmpI + 300;
|
||
Y2 := 150 * (TmpI + 1) + 300;
|
||
TR := Rect(X1, Y1, X2 - 30, Y2);
|
||
cText := sGrid.Cells[F, TmpI];
|
||
cText := StringReplace(cText,'<B>','',[rfReplaceAll]);
|
||
cText := StringReplace(cText,'<C>','',[rfReplaceAll]);
|
||
cText := StringReplace(cText,'<L>','',[rfReplaceAll]);
|
||
cText := StringReplace(cText,'<I>','',[rfReplaceAll]);
|
||
cText := StringReplace(cText,'YTL','',[rfReplaceAll]);
|
||
|
||
Printer.Canvas.TextRect(TR, X1 + 50, Y1 + 50,cText );
|
||
end;
|
||
end;
|
||
Printer.EndDoc;
|
||
end;
|
||
|
||
Function InttoStrL(val:integer; sCount:Integer):String;
|
||
var l,i:Integer;
|
||
begin
|
||
result := inttostr(val);
|
||
l:= Length(result);
|
||
for i:= 1 to sCount-l do Result := '0'+Result;
|
||
end;
|
||
|
||
Function LeadStr(val:String; sCount:Integer):String;
|
||
var l,i:Integer;
|
||
begin
|
||
result := val;
|
||
l:= Length(result);
|
||
for i:= 1 to sCount-l do Result := '0'+Result;
|
||
end;
|
||
|
||
Function FormatSqlDate(xDate:Integer):Integer;
|
||
begin
|
||
result := StrToInt(FormatDateTime('yyyymmdd',xDate));
|
||
end;
|
||
|
||
Function GetGradStyle(brStyle: Byte):TGradStyle;
|
||
begin
|
||
if brStyle = ord(bsHorzGrad) then begin
|
||
result := gsLineHorz;
|
||
end else if brStyle = ord(bsVertGrad) then begin
|
||
result := gsLineVert;
|
||
end else if brStyle = ord(bsRadGrad) then begin
|
||
result := gsRadCenter;
|
||
end else if brStyle = ord(bsDiagFGrad) then begin
|
||
result := gsDiagLineF;
|
||
end else if brStyle = ord(bsDiagBGrad) then begin
|
||
result := gsDiagLineB;
|
||
end else if brStyle = ord(bsMirrorGrad) then begin
|
||
result := gsMirrored;
|
||
end else begin
|
||
result := gsNoGrad;
|
||
end;
|
||
end;
|
||
|
||
Function GetTextureStyle(brStyle: Byte):TTextureStyle;
|
||
begin
|
||
if brStyle = ord(bstxtNewsPrint) then begin
|
||
result := txtNewsPrint;
|
||
end else if brStyle = ord(bstxtStationery) then begin
|
||
result := txtStationery;
|
||
end else if brStyle = ord(bstxtWhiteMarble) then begin
|
||
result := txtWhiteMarble;
|
||
end else if brStyle = ord(bstxtWovenMat) then begin
|
||
result := txtWovenMat;
|
||
end else if brStyle = ord(bstxtPaperBag) then begin
|
||
result := txtPaperBag;
|
||
end else if brStyle = ord(bstxtMediumWood) then begin
|
||
result := txtMediumWood;
|
||
end else begin
|
||
result := txtNone;
|
||
end;
|
||
end;
|
||
|
||
Function GetHatchStyle(brStyle: Byte):THatchStyle;
|
||
begin
|
||
if brStyle = ord(bsSolid) then begin
|
||
result := hsNone;
|
||
end else if brStyle = ord(bsClear) then begin
|
||
result := hsNone;
|
||
end else if brStyle = ord(bsHorizontal) then begin
|
||
result := hsHorizontal;
|
||
end else if brStyle = ord(bsVertical) then begin
|
||
result := hsVertical;
|
||
end else if brStyle = ord(bsFDiagonal) then begin
|
||
result := hsLDiagonal;
|
||
end else if brStyle = ord(bsBDiagonal) then begin
|
||
result := hsRDiagonal;
|
||
end else if brStyle = ord(bsCross) then begin
|
||
result := hsCross;
|
||
end else if brStyle = ord(bsDiagCross) then begin
|
||
result := hsDCross;
|
||
end else begin
|
||
result := hsNone;
|
||
end;
|
||
end;
|
||
|
||
Function GetFillType(brStyle: Byte):TFillType;
|
||
begin
|
||
if brStyle = ord(bsSolid) then begin
|
||
result := fsSolid;
|
||
end else if brStyle = ord(bsClear) then begin
|
||
result := fsNone;
|
||
end else if brStyle = ord(bsExHatch) then begin
|
||
result := fsHatch;
|
||
end else if brStyle = ord(bsExGrad) then begin
|
||
result := fsGradient;
|
||
end else if brStyle = ord(bsExTexture) then begin
|
||
result := fsTexture;
|
||
end else if brStyle = ord(bsHorizontal) then begin
|
||
result := fsHatch;
|
||
end else if brStyle = ord(bsVertical) then begin
|
||
result := fsHatch;
|
||
end else if brStyle = ord(bsFDiagonal) then begin
|
||
result := fsHatch;
|
||
end else if brStyle = ord(bsBDiagonal) then begin
|
||
result := fsHatch;
|
||
end else if brStyle = ord(bsCross) then begin
|
||
result := fsHatch;
|
||
end else if brStyle = ord(bsDiagCross) then begin
|
||
result := fsHatch;
|
||
end else if brStyle = ord(bsHorzGrad) then begin
|
||
result := fsGradient;
|
||
end else if brStyle = ord(bsVertGrad) then begin
|
||
result := fsGradient;
|
||
end else if brStyle = ord(bsRadGrad) then begin
|
||
result := fsGradient;
|
||
end else if brStyle = ord(bsDiagFGrad) then begin
|
||
result := fsGradient;
|
||
end else if brStyle = ord(bsDiagBGrad) then begin
|
||
result := fsGradient;
|
||
end else if brStyle = ord(bsMirrorGrad) then begin
|
||
result := fsGradient;
|
||
end else if brStyle = ord(bstxtNewsPrint) then begin
|
||
result := fsTexture;
|
||
end else if brStyle = ord(bstxtStationery) then begin
|
||
result := fsTexture;
|
||
end else if brStyle = ord(bstxtWhiteMarble) then begin
|
||
result := fsTexture;
|
||
end else if brStyle = ord(bstxtWovenMat) then begin
|
||
result := fsTexture;
|
||
end else if brStyle = ord(bstxtPaperBag) then begin
|
||
result := fsTexture;
|
||
end else if brStyle = ord(bstxtMediumWood) then begin
|
||
result := fsTexture;
|
||
end;
|
||
end;
|
||
|
||
|
||
Function FirstWords(Str:String; cnt:Integer):String;
|
||
var s: TStringArray;
|
||
xCnt,i:Integer;
|
||
begin
|
||
result := '';
|
||
str := stringreplace(str,' ',' ',[rfReplaceAll]);
|
||
SplitStr(str,s,' ');
|
||
xCnt := 0;
|
||
for i := 0 to Length(s)-1 do
|
||
begin
|
||
if (Trim(s[i]) <> '') then begin
|
||
if xCnt < Cnt then begin
|
||
result := result+' '+s[i];
|
||
xcnt := xcnt+1;
|
||
end else begin
|
||
break;
|
||
end;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
Procedure DrawTraceText(x,y:Integer;Color:TColor;
|
||
Text,FontName:String;FontSize:Integer;Canvas:TCanvas);
|
||
var bmp: Graphics.Tbitmap;
|
||
begin
|
||
bmp := Graphics.Tbitmap.Create;
|
||
bmp.Canvas.Font.Name := FontName;
|
||
bmp.Canvas.Font.Size := FontSize;
|
||
bmp.Width := bmp.Canvas.TextWidth(text)+10;
|
||
bmp.Height := bmp.Canvas.TextHeight(text)+10;;
|
||
bmp.Canvas.Brush.Color := clBlack;
|
||
bmp.Canvas.Brush.Style := bsSolid;
|
||
bmp.Canvas.FillRect(Rect(0,0,bmp.Width,bmp.Height));
|
||
|
||
bmp.Canvas.Font.Color := Color;
|
||
bmp.Canvas.TextOut(0,0,Text);
|
||
|
||
Canvas.CopyMode := SRCINVERT;
|
||
Canvas.Draw(x,y,bmp);
|
||
bmp.Free;
|
||
Canvas.CopyMode := SRCCOPY;
|
||
end;
|
||
|
||
Function Obeb(a,b:Integer):Integer;
|
||
var x: Integer;
|
||
begin
|
||
if a < b then begin
|
||
x := a;
|
||
a := b;
|
||
b := x;
|
||
end;
|
||
x := 1;
|
||
|
||
repeat
|
||
x := a mod b;
|
||
if x > 0 then begin
|
||
a := b;
|
||
b := x;
|
||
end;
|
||
until x = 0;
|
||
result := b;
|
||
end;
|
||
|
||
procedure PrinterCustomSize(w,h: Integer);
|
||
var
|
||
Device : array[0..255] of char;
|
||
Driver : array[0..255] of char;
|
||
Port : array[0..255] of char;
|
||
hDMode : THandle;
|
||
PDMode : PDEVMODE;
|
||
begin
|
||
Printer.PrinterIndex := Printer.PrinterIndex;
|
||
Printer.GetPrinter(Device, Driver, Port, hDMode);
|
||
if hDMode <> 0 then begin
|
||
pDMode := GlobalLock(hDMode);
|
||
if pDMode <> nil then begin
|
||
|
||
|
||
// set as legal legal
|
||
//pDMode^.dmFields := pDMode^.dmFields or dm_PaperSize;
|
||
//pDMode^.dmPaperSize := DMPAPER_LEGAL;
|
||
|
||
|
||
// set to custom size
|
||
pDMode^.dmFields := pDMode^.dmFields or DM_PAPERSIZE or DM_PAPERWIDTH or DM_PAPERLENGTH;
|
||
pDMode^.dmPaperSize := DMPAPER_USER;
|
||
pDMode^.dmPaperWidth := w; // SomeValueInTenthsOfAMillimeter
|
||
pDMode^.dmPaperLength := h; // SomeValueInTenthsOfAMillimeter
|
||
|
||
|
||
//Set the bin to use
|
||
//pDMode^.dmFields := pDMode^.dmFields or BinNumber;
|
||
//pDMode^.dmDefaultSource := BinNumber;
|
||
|
||
|
||
GlobalUnlock(hDMode);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
(*************************************************************************
|
||
|
||
* FUNCTION: CCW (CounterClockWise)
|
||
*
|
||
* PURPOSE
|
||
* Determines, given three points, if when travelling from the first to
|
||
* the second to the third, we travel in a counterclockwise direction.
|
||
*
|
||
* RETURN VALUE
|
||
* (int) 1 if the movement is in a counterclockwise direction, -1 if
|
||
* not.
|
||
*************************************************************************)
|
||
|
||
Function CCW(p0,p1,p2:TDoublePoint):Integer;
|
||
|
||
var
|
||
m1,m2: Double;
|
||
dx1, dx2 :Double;
|
||
dy1, dy2 :Double;
|
||
begin
|
||
dx1 := p1.x - p0.x ; dx2 := p2.x - p0.x ;
|
||
dy1 := p1.y - p0.y ; dy2 := p2.y - p0.y ;
|
||
m1 := dx1 * dy2;
|
||
m2 := dy1 * dx2;
|
||
if m1 > m2 then result := 1 else result := -1;
|
||
end;
|
||
|
||
(*************************************************************************
|
||
* FUNCTION: Intersect
|
||
*
|
||
* PURPOSE
|
||
* Given two line segments, determine if they intersect.
|
||
*
|
||
* RETURN VALUE
|
||
* TRUE if they intersect, FALSE if not.
|
||
*************************************************************************)
|
||
|
||
Function Intersect(p1,p2,p3,p4:TDoublePoint):Boolean;
|
||
var
|
||
c1,c2,c3,c4: Integer;
|
||
begin
|
||
c1 := CCW(p1, p2, p3);
|
||
c2 := CCW(p1, p2, p4);
|
||
c3 := CCW(p3, p4, p1);
|
||
c4 := CCW(p3, p4, p2);
|
||
|
||
result := (( c1 * c2) <= 0) and (( c3 * c4) <= 0) ;
|
||
|
||
end;
|
||
|
||
|
||
|
||
(*************************************************************************
|
||
|
||
* FUNCTION: G_PtInPolygon
|
||
*
|
||
* PURPOSE
|
||
* This routine determines if the point passed is in the polygon. It uses
|
||
|
||
* the classical polygon hit-testing algorithm: a horizontal ray starting
|
||
|
||
* at the point is extended infinitely rightwards and the number of
|
||
* polygon edges that intersect the ray are counted. If the number is odd,
|
||
|
||
* the point is inside the polygon.
|
||
*
|
||
* RETURN VALUE
|
||
* (BOOL) TRUE if the point is inside the polygon, FALSE if not.
|
||
*************************************************************************)
|
||
|
||
Function PtInPolygon(POINTS:TDoublePointArr; ptTest:TDoublePoint):Boolean;
|
||
var
|
||
wnumpts,i,wnumintsct:Integer;
|
||
pt1,pt2,ppt :TDoublePoint;
|
||
r: TDoubleRect;
|
||
bx,by,sx,sy: Double;
|
||
|
||
begin
|
||
wnumintsct := 0 ;
|
||
wnumpts := Length(Points);
|
||
result := false;
|
||
if wnumpts < 3 then exit;
|
||
pt1 := ptTest;
|
||
pt2 := ptTest;
|
||
GetPolylineBounds(points,bx,by,sx,sy);
|
||
r := DoubleRect(sx,sy,bx,by);
|
||
if not PointInRect(ptTest,r) then begin
|
||
result := false;
|
||
exit;
|
||
end;
|
||
|
||
pt2.x := r.right + 50 ;
|
||
|
||
for i := 0 to wnumpts-2 do
|
||
begin
|
||
if Intersect(ptTest,pt2,points[i],points[i+1]) then inc(wnumintsct);
|
||
end;
|
||
// And the last line
|
||
if Intersect(ptTest, pt2, points[0], points[wnumpts-1]) then inc(wnumintsct);
|
||
result := odd(wnumintsct);
|
||
|
||
end;
|
||
|
||
function PosEx(const SubStr, S: string; Offset: Cardinal = 1): Integer;
|
||
var
|
||
I,X: Integer;
|
||
Len, LenSubStr: Integer;
|
||
begin
|
||
if Offset = 1 then
|
||
Result := Pos(SubStr, S)
|
||
else
|
||
begin
|
||
I := Offset;
|
||
LenSubStr := Length(SubStr);
|
||
Len := Length(S) - LenSubStr + 1;
|
||
while I <= Len do
|
||
begin
|
||
if S[I] = SubStr[1] then
|
||
begin
|
||
X := 1;
|
||
while (X < LenSubStr) and (S[I + X] = SubStr[X + 1]) do
|
||
Inc(X);
|
||
if (X = LenSubStr) then
|
||
begin
|
||
Result := I;
|
||
exit;
|
||
end;
|
||
end;
|
||
Inc(I);
|
||
end;
|
||
Result := 0;
|
||
end;
|
||
end;
|
||
|
||
Function SplitWebTable(WebText:String; var TableArr: TWebTableArr):Integer;
|
||
var p,pOld,i,k,j:Integer;
|
||
ucWebText,xText,table,row,col: String;
|
||
xList: TStringList;
|
||
sArr,sArr1,sArr2: TStringArray;
|
||
begin
|
||
result := 0;
|
||
ucWebtext := UpperCase(Webtext);
|
||
p := Pos('<TABLE',ucWebText);
|
||
if p = 0 then exit;
|
||
WebText := Copy(Webtext,p,Length(WebText));
|
||
ucWebtext := UpperCase(Webtext);
|
||
p := 0;
|
||
repeat
|
||
pOld := p;
|
||
p := PosEx('</TABLE>',ucWebText,p+8);
|
||
until p = 0;
|
||
p := pOld;
|
||
if p = 0 then exit;
|
||
WebText := Copy(Webtext,1,p+7);
|
||
//xList := TStringList.Create;
|
||
WebText := StringReplace(WebText,'|','-',[rfReplaceAll]);
|
||
WebText := StringReplace(WebText,'<TABLE','|<TABLE',[rfReplaceAll, rfIgnoreCase]);
|
||
SplitStr(WebText,sArr,'|');
|
||
if Length(sArr) = 0 then exit;
|
||
Setlength(TableArr,Length(SArr));
|
||
for i := 0 to Length(sArr)-1 do
|
||
begin
|
||
table := sArr[i];
|
||
table := StringReplace(table,'<TR','|<TR',[rfReplaceAll, rfIgnoreCase]);
|
||
SplitStr(table,sArr1,'|');
|
||
SetLength(tableArr[i],Length(sArr1));
|
||
for k := 0 to Length(sArr1)-1 do
|
||
begin
|
||
row := sArr1[k];
|
||
row := StringReplace(row,'<TD','|<TD',[rfReplaceAll, rfIgnoreCase]);
|
||
SplitStr(row,sArr2,'|');
|
||
SetLength(tableArr[i][k],Length(sArr2));
|
||
for j := 0 to Length(sArr2)-1 do
|
||
begin
|
||
TableArr[i][k][j] := RemoveTags(sArr2[j],false);
|
||
//xList.Add(inttostr(i)+','+inttostr(k)+','+inttostr(j)+' '+TableArr[i][k][j]);
|
||
end;
|
||
end;
|
||
end;
|
||
//xList.SaveToFile('c:\webtext.txt');
|
||
|
||
end;
|
||
|
||
function RemoveTags(str: String; rtf: Boolean): String;
|
||
var ok: Boolean;
|
||
p,pe: Integer;
|
||
s: String;
|
||
sx: String;
|
||
ch: Integer;
|
||
chs: string;
|
||
chars: TStringlist;
|
||
len,i: Integer;
|
||
begin
|
||
str := removeblocks(str,'<script','</script>');
|
||
str := removeblocks(str,'<style>','</style>');
|
||
str := StringReplace(str,'©','<27>',[rfReplaceAll, rfIgnoreCase]);
|
||
str := StringReplace(str,'&','&',[rfReplaceAll, rfIgnoreCase]);
|
||
str := StringReplace(str,#160,'',[rfReplaceAll, rfIgnoreCase]);
|
||
chars := TstringList.Create;
|
||
ok := false;
|
||
s := str;
|
||
repeat
|
||
p := pos('&#',s);
|
||
if p > 0 then begin
|
||
sx := copy(s,p,Length(s));
|
||
pe := pos(';',sx);
|
||
if pe > 0 then
|
||
begin
|
||
chs := copy(sx,3,pe-3);
|
||
ch := StrToIntDef(chs,0);
|
||
if ch > 0 then begin
|
||
chars.Add(chs);
|
||
end;
|
||
s := copy(sx,pe+1,length(sx));
|
||
end
|
||
else ok := true;
|
||
|
||
end else ok := true;
|
||
until ok;
|
||
|
||
for i := 0 to chars.Count-1 do
|
||
begin
|
||
chs := '&#'+chars[i]+';';
|
||
str := StringReplace(str,chs,chr(StrToIntDef(chars[i],0)),[rfReplaceAll, rfIgnoreCase]);
|
||
end;
|
||
|
||
str := StringReplace(str,'<27>','''',[rfReplaceAll, rfIgnoreCase]);
|
||
str := StringReplace(str,'<27>','"',[rfReplaceAll, rfIgnoreCase]);
|
||
str := StringReplace(str,'<27>','"',[rfReplaceAll, rfIgnoreCase]);
|
||
|
||
|
||
if rtf then begin
|
||
str := StringReplace(str,'<tr>','\par',[rfReplaceAll, rfIgnoreCase]);
|
||
str := StringReplace(str,'<table ','\par<table',[rfReplaceAll, rfIgnoreCase]);
|
||
str := StringReplace(str,'</p>','\par',[rfReplaceAll, rfIgnoreCase]);
|
||
str := StringReplace(str,'<p>','\par',[rfReplaceAll, rfIgnoreCase]);
|
||
str := StringReplace(str,'<br>','\par',[rfReplaceAll, rfIgnoreCase]);
|
||
str := StringReplace(str,'<b>','\b ' ,[rfReplaceAll, rfIgnoreCase]);
|
||
str := StringReplace(str,'</b>','\b0 ' ,[rfReplaceAll, rfIgnoreCase]);
|
||
end;
|
||
ok := false;
|
||
s := str;
|
||
repeat
|
||
p := pos('<',s);
|
||
if p > 0 then begin
|
||
sx := copy(s,p+1,Length(s)-p);
|
||
pe := pos('>',sx);
|
||
if pe > 0 then
|
||
s := copy(s,1,p-1)+''+copy(s,p+pe+1,length(s))
|
||
else ok := true;
|
||
end else ok := true;
|
||
until ok;
|
||
s := StringReplace(s,' ',' ',[rfReplaceAll, rfIgnoreCase]);
|
||
s := StringReplace(s,' ',' ',[rfReplaceAll, rfIgnoreCase]);
|
||
s := Trim(s);
|
||
result := s;
|
||
chars.Free; // Tolik 21/05/2018 --
|
||
end;
|
||
|
||
Function RemoveBlocks(str:String; s1,s2: String):String;
|
||
var p,pe: Integer;
|
||
s: string;
|
||
ok: boolean;
|
||
sx: string;
|
||
begin
|
||
s1 := trim(s1);
|
||
s2 := trim(s2);
|
||
if (s1 = '') and (s2 = '') then
|
||
begin
|
||
result := str;
|
||
end else if (s1 = '') then begin
|
||
result := StringReplace(str,s2,'',[rfReplaceAll, rfIgnoreCase]);
|
||
end else if (s2 = '') then begin
|
||
result := StringReplace(str,s1,'',[rfReplaceAll, rfIgnoreCase]);
|
||
end else if (s1=s2) then begin
|
||
result := StringReplace(str,s1,'',[rfReplaceAll, rfIgnoreCase]);
|
||
end else begin
|
||
ok := false;
|
||
s := str;
|
||
repeat
|
||
p := Pos(lowercase(s1),lowercase(s));
|
||
if p > 0 then begin
|
||
sx := Copy(s,p+Length(s1),Length(s));
|
||
pe := pos(lowercase(s2),lowercase(sx));
|
||
if pe > 0 then begin
|
||
pe := pe+p+length(s1)-1;
|
||
s := copy(s,1,p-1)+' '+copy(s,pe+length(s2),length(s));
|
||
end else ok := true;
|
||
end else ok := true;
|
||
until ok;
|
||
result := s;
|
||
end;
|
||
end;
|
||
|
||
function GetAreaFromPolygon(APolygon: TDoublePointArr): Double;
|
||
var
|
||
i, j: Integer;
|
||
HighP: Integer;
|
||
begin
|
||
Result := 0;
|
||
HighP := High(APolygon);
|
||
for i := Low(APolygon) to HighP do
|
||
begin
|
||
if i = HighP then
|
||
j := 0
|
||
else
|
||
j := i+1;
|
||
|
||
Result := Result + ((APolygon[i].x * APolygon[j].y) - (APolygon[j].x * APolygon[i].y));
|
||
end;
|
||
Result := abs(Result) / 2;
|
||
end;
|
||
|
||
function GetLineLength3D(p1, p2: T3DPoint): Double;
|
||
begin
|
||
Result := sqrt(sqr(p2.x - p1.x)+sqr(p2.y - p1.y)+sqr(p2.z - p1.z));
|
||
end;
|
||
|
||
|
||
|
||
function GetTriangleArea3D(p1, p2, p3: T3DPoint): Double;
|
||
var
|
||
len1, len2, len3: Double;
|
||
p: Double;
|
||
begin
|
||
Result := 0;
|
||
len1 := GetLineLength3D(p1, p2);
|
||
len2 := GetLineLength3D(p2, p3);
|
||
len3 := GetLineLength3D(p3, p1);
|
||
p := (len1 + len2 + len3) / 2;
|
||
Result := SQRT(p*(p-len1) * (p-len2) * (p-len3));
|
||
end;
|
||
|
||
function IsPointNear(APointX, ApointY, ANearX, ANearY: Double): Boolean;
|
||
var
|
||
pdim : Double;
|
||
begin
|
||
|
||
end;
|
||
|
||
procedure DeletePointFromArray(var Arr: TDoublePointArr; Index: Integer);
|
||
begin
|
||
if Index < Length(Arr) then
|
||
begin
|
||
System.Move(Arr[Index + 1], Arr[Index],
|
||
(Length(Arr) - Index) * SizeOf(TDoublePoint));
|
||
SetLength(Arr, Length(Arr)-1);
|
||
end;
|
||
end;
|
||
|
||
initialization
|
||
{$ifdef demo}
|
||
if not delphiloaded then application.terminate;
|
||
{$endif demo}
|
||
figureclasses := TList.create;
|
||
FigureClassesSL := TStringList.Create; //01.11.2011
|
||
FigureClassesSL.Sorted := true;
|
||
OsVersion.dwOSVersionInfoSize := SizeOf(OSVersion);
|
||
getVersionEx(OSVersion);
|
||
TextureBmp := Graphics.TBitmap.Create;
|
||
TextureBmp.LoadFromResourceName(hInstance, 'textures');
|
||
Randomize;
|
||
finalization
|
||
figureclasses.free;
|
||
FigureClassesSL.Free; //01.11.2011
|
||
TextureBmp.Free;
|
||
end.
|
||
|