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

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

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// Plot utilites. Virtual drawing utilites. Plot 3D surface functions.        //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20011216 - Creation                                                        //
// 20011222 - Cga and RGB color utils                                         //
// 20230506 - Modified for FPC (A.K.)                                         //
////////////////////////////////////////////////////////////////////////////////

unit _crw_plut; // Virtual Plot Utilites.

{$I _crw_sysdef}

{$IFDEF FPC}{$mode Delphi}{$ENDIF}{$H+}

interface

uses
 _crw_sharemem, // NB: THIS UNIT MUST BE FIRST !!!
 {$IFDEF UNIX} cthreads, dl, {$ENDIF}
 {$IFDEF WINDOWS} windows, {$ENDIF}
 sysutils, graphics, math, types,
 _crw_alloc, _crw_fpu, _crw_ef, _crw_str{, _crw_fio};

 {
 ******************************
 Point and rectangular routines
 ******************************
 }
type
 TPoint2I      = packed record x,y : Integer; end;
 TPoint2D      = packed record x,y : Double;  end;
 TPoint3D      = packed record x,y,z : Double; end;
 TRect2I       = packed record a,b : TPoint2I; end;
 TRect2D       = packed record a,b : TPoint2D; end;
 PPoint2IArray = ^TPoint2IArray;
 TPoint2IArray = packed array[0..MaxInt div sizeof(TPoint2I)-1] of TPoint2I;
 PPoint2DArray = ^TPoint2DArray;
 TPoint2DArray = packed array[0..MaxInt div sizeof(TPoint2D)-1] of TPoint2D;
 PPoint3DArray = ^TPoint3DArray;
 TPoint3DArray = packed array[0..MaxInt div sizeof(TPoint3D)-1] of TPoint3D;
 PRect2IArray  = ^TRect2IArray;
 TRect2IArray  = packed array[0..MaxInt div sizeof(TRect2I)-1] of TRect2I;
 PRect2DArray  = ^TRect2DArray;
 TRect2DArray  = packed array[0..MaxInt div sizeof(TRect2D)-1] of TRect2D;

const
 PointAbsEps = 0;
 PointRelEps = 1e-14;
 RectAbsEps  = 0;
 RectRelEps  = 1e-14;

function  Point2I(x,y:Integer):TPoint2I; overload;
function  Point2I(const p:TPoint):TPoint2I; overload;
function  Point2D(x,y:Double):TPoint2D;
function  Point3D(x,y,z:Double):TPoint3D;
function  Rect2I(x1,y1,x2,y2:Integer):TRect2I; overload;
function  Rect2D(x1,y1,x2,y2:Double):TRect2D; overload;
function  Rect2I(const a,b:TPoint2I):TRect2I; overload;
function  Rect2I(const r:TRect):TRect2I; overload;
function  Rect2D(const a,b:TPoint2D):TRect2D; overload;
function  PointIsEqual(const p1,p2:TPoint2I):Boolean; overload;
function  PointIsEqual(const p1,p2:TPoint2D; AbsEps:Double=PointAbsEps; RelEps:Double=PointRelEps):Boolean; overload;
function  RectIsEqual(const r1,r2:TRect2I):Boolean; overload;
function  RectIsEqual(const r1,r2:TRect2D; AbsEps:Double=RectAbsEps; RelEps:Double=RectRelEps):Boolean; overload;
function  RectIsEmpty(const r:TRect2I):Boolean; overload;
function  RectIsEmpty(const r:TRect2D; AbsEps:Double=RectAbsEps; RelEps:Double=RectRelEps):Boolean; overload;
function  RectContainsPoint(const r:TRect2I; const p:TPoint2I):Boolean; overload;
function  RectContainsPoint(const r:TRect2D; const p:TPoint2D):Boolean; overload;
function  RectIntersection(const R1,R2:TRect2I):TRect2I; overload;
function  RectIntersection(const R1,R2:TRect2D):TRect2D; overload;
function  RectUnion(const R1,R2:TRect2I):TRect2I; overload;
function  RectUnion(const R1,R2:TRect2D):TRect2D; overload;
function  RectValidate(const r:TRect2I):TRect2I; overload;
function  RectValidate(const r:TRect2D):TRect2D; overload;
procedure PointMove(var p:TPoint2I; dx,dy:Integer); overload;
procedure PointMove(var p:TPoint2D; dx,dy:Double); overload;
procedure RectMove(var r:TRect2I; dx,dy:Integer); overload;
procedure RectMove(var r:TRect2D; dx,dy:Double); overload;
procedure PointMult(var p:TPoint2I; mx,my:Integer); overload;
procedure PointMult(var p:TPoint2D; mx,my:Double); overload;
procedure RectMult(var r:TRect2I; mx,my:Integer); overload;
procedure RectMult(var r:TRect2D; mx,my:Double); overload;
procedure RectGrow(var r:TRect2I; dx,dy:Integer); overload;
procedure RectGrow(var r:TRect2D; dx,dy:double); overload;
function  RectSizeX(const r:TRect2I):Integer; overload;
function  RectSizeX(const r:TRect2D):double; overload;
function  RectSizeY(const r:TRect2I):Integer; overload;
function  RectSizeY(const r:TRect2D):double; overload;
function  RectSize(const r:TRect):TPoint; overload;
function  RectSize(const r:TRect2I):TPoint2I; overload;
function  RectSize(const r:TRect2D):TPoint2D; overload;
function  RectCenterX(const r:TRect2I):Integer; overload;
function  RectCenterX(const r:TRect2D):double; overload;
function  RectCenterY(const r:TRect2I):Integer; overload;
function  RectCenterY(const r:TRect2D):double; overload;
function  RectCenter(const r:TRect2I):TPoint2I; overload;
function  RectCenter(const r:TRect2D):TPoint2D; overload;
function  isNan(const p:TPoint2D):Boolean; overload;
function  isNan(const r:TRect2D):Boolean; overload;
function  isInf(const p:TPoint2D):Boolean; overload;
function  isInf(const r:TRect2D):Boolean; overload;
function  isNanOrInf(const p:TPoint2D):Boolean; overload;
function  isNanOrInf(const r:TRect2D):Boolean; overload;

 {
 **********************************
 Utilites for axis grid calcultions
 **********************************
 }
type
 TAxisGrid = record
  Num   : Integer; {number of grid lines}
  Pow   : Integer; {common decimal power}
  Start : Double;  {coordinate of first grid}
  Step  : Double;  {step of next grid}
  Scale : Double;  {scale to convert gridtext=grid/scale}
 end;

function AxisGrid(xmin,xmax:Double):TAxisGrid;

 {
 ****************************************************************************
 Find intersection of two segments of line (Start1,Stop1) and (Start2,Stop2).
 Return false, if this line segments has no intersection.
 ****************************************************************************
 }
function SegmentsHasIntersection(const Start1       : TPoint2D;
                                 const Stop1        : TPoint2D;
                                 const Start2       : TPoint2D;
                                 const Stop2        : TPoint2D;
                                  var  Intersection : TPoint2D
                                   ) : Boolean;

 {
 ********************
 Virtual line drawing
 ********************
 }
type
 TVirtualDrawPixel = procedure(x,y,color:Integer; CustomData:Pointer);

procedure VirtualDrawLine(X1,Y1,X2,Y2,Color : Integer;
                          VirtualPixel      : TVirtualDrawPixel;
                          CustomData        : Pointer);

 {
 *********************
 Surface plot routines
 *********************
 }
type
 TSurfFunc     = function (x,y:double; Custom:Pointer):double;    {surface z=f(x,y)}
 TSurfMatrix   = function (ix,iy:integer; Custom:Pointer):double; {surface matrix z[i,j]=f(x[i],y[j]), 0<=i<Nx, 0<=j<Ny}
 TPlot3DParams = record                                           {internally uses by plotsurface}
  Origin : TPoint2I;                                              {surface screen location}
  Size   : TPoint2I;                                              {surface screen size}
  Lim    : TRect2D;                                               {limits of axises}
  h      : TPoint2D;                                              {step of axis}
  N      : TPoint2I;                                              {number of points of x, of y}
  e      : array[1..3,1..3] of Double;                            {projection matrix}
  a      : TPoint2D;                                              {scaling coefficients}
  b      : TPoint2D;                                              {scaling coefficients}
  xmin   : Double;                                                {low limit of x}
  xmax   : Double;                                                {high limit of x}
  ymin   : Double;                                                {low limit of y}
  ymax   : Double;                                                {high limit of y}
  zmin   : Double;                                                {low limit of z}
  zmax   : Double;                                                {high limit of z}
  sinphi : Double;                                                {axial triganometry}
  cosphi : Double;                                                {axial triganometry}
  sinpsi : Double;                                                {tangential triganometry}
  cospsi : Double;                                                {tangential triganometry}
 end;

const                {plot surface mode constants}
 smSliceX  = $0001;  {to draw X=const lines}
 smSliceY  = $0002;  {to draw Y=const lines}

 {
 Plot a surface z=f(x,y) using given procedure of pixel drawing - PutPixel.
 Procedure PutPixel must draw a pixel; Y axis direction from bottom to top
 (screen coordinates direction is usually from top to bottom).
 Finction f(i,j) must calculate surface z(x,y) in vertex x[i],y[j]:
  x[i]=x1+i*(x2-x1)/(Nx-1) , 0 <= i < Nx ,
  y[j]=y1+j*(y2-y1)/(Ny-1) , 0 <= j < Ny ,
  z(x[i],y[j])=f(i,j)
 }
function PlotSurface(x1             : Double;            {low x limit}
                     y1             : Double;            {low y limit}
                     x2             : Double;            {high x limit}
                     y2             : Double;            {high y limit}
                     f              : TSurfMatrix;       {surface z=f(x,y)}
                     nx             : Integer;           {num points along x}
                     ny             : Integer;           {num points along y}
                     phi            : Double;            {axial angle of view}
                     psi            : Double;            {tangential angle of view}
                     OrgX           : Integer;           {screen low x limit}
                     OrgY           : Integer;           {screen low y limit}
                     SizeX          : Integer;           {screen size along x}
                     SizeY          : Integer;           {screen size along y}
                     PutPixel       : TVirtualDrawPixel; {virtual pixel drawer}
                     UpColor        : Integer;           {color of surface upper side}
                     DownColor      : Integer;           {color of surface lower side}
               const Scale          : TPoint3D;          {scaling factors along x,y}
                 var Params         : TPlot3DParams;     {internally use}
                     Mode           : word;              {how to plot flags, see smXXX const}
                     Custom         : Pointer;           {any user data}
                     AxisCorrection : Boolean = true     {need axis correction}
                     ) : Boolean;                        {fals on out of memory}

 {
 ******************
 Cga color utilites
 ******************
 }
const
 Black         = 0;   // clBlack
 Blue          = 1;   // clNavy
 Green         = 2;   // clGreen
 Cyan          = 3;   // clTeal
 Red           = 4;   // clMaroon
 Magenta       = 5;   // clPurple
 Brown         = 6;   // clOlive
 LightGray     = 7;   // clSilver
 DarkGray      = 8;   // clGray
 LightBlue     = 9;   // clBlue
 LightGreen    = 10;  // clLime
 LightCyan     = 11;  // clAqua
 LightRed      = 12;  // clRed
 LightMagenta  = 13;  // clFuchsia
 Yellow        = 14;  // clYellow
 White         = 15;  // clWhite

function RGB(r,g,b:Integer):TColor;
function CgaColorNameEng(Color:Integer):LongString;
function CgaColorNameRus(CgaColor:Integer):LongString;
function CgaColorByName(const S:LongString):Integer;
function CgaToRGBColor(Color:Integer):TColor;

implementation

 {
 ******************************
 Point and rectangular routines
 ******************************
 }
function Point2I(x,y:Integer):TPoint2I; overload;
begin
 Result.x:=x;
 Result.y:=y;
end;

function  Point2I(const p:TPoint):TPoint2I; overload;
begin
 Result.x:=p.x;
 Result.y:=p.y;
end;

function Point2D(x,y:Double):TPoint2D;
begin
 Result.x:=x;
 Result.y:=y;
end;

function Point3D(x,y,z:Double):TPoint3D;
begin
 Result.x:=x;
 Result.y:=y;
 Result.z:=z;
end;

function Rect2I(x1,y1,x2,y2:Integer):TRect2I; overload;
begin
 Result.a.x:=x1;
 Result.a.y:=y1;
 Result.b.x:=x2;
 Result.b.y:=y2;
end;

function Rect2D(x1,y1,x2,y2:Double):TRect2D; overload;
begin
 Result.a.x:=x1;
 Result.a.y:=y1;
 Result.b.x:=x2;
 Result.b.y:=y2;
end;

function Rect2I(const a,b:TPoint2I):TRect2I; overload;
begin
 Result.a:=a;
 Result.b:=b;
end;

function  Rect2I(const r:TRect):TRect2I; overload;
begin
 Result:=TRect2I(r);
end;

function Rect2D(const a,b:TPoint2D):TRect2D; overload;
begin
 Result.a:=a;
 Result.b:=b;
end;

function PointIsEqual(const p1,p2:TPoint2I):Boolean; overload;
begin
 Result:=(p1.x=p2.x) and (p1.y=p2.y);
end;

function PointIsEqual(const p1,p2:TPoint2D; AbsEps:Double=PointAbsEps; RelEps:Double=PointRelEps):Boolean; overload;
begin
 Result:=(abs(p1.x-p2.x)<=Precision(AbsEps,RelEps,abs(p1.x)+abs(p2.x))) and
         (abs(p1.y-p2.y)<=Precision(AbsEps,RelEps,abs(p1.y)+abs(p2.y)));
end;

function RectIsEqual(const r1,r2:TRect2I):Boolean; overload;
begin
 Result:=PointIsEqual(r1.a,r2.a) and PointIsEqual(r1.b,r2.b);
end;

function RectIsEqual(const r1,r2:TRect2D; AbsEps:Double=RectAbsEps; RelEps:Double=RectRelEps):Boolean; overload;
begin
 Result:=PointIsEqual(r1.a,r2.a,AbsEps,RelEps) and PointIsEqual(r1.b,r2.b,AbsEps,RelEps);
end;

function RectIsEmpty(const r:TRect2I):Boolean; overload;
begin
 with r do Result:=(a.x>=b.x) or (a.y>=b.y);
end;

function RectIsEmpty(const r:TRect2D; AbsEps:Double=RectAbsEps; RelEps:Double=RectRelEps):Boolean; overload;
begin
 with r do
 Result:=(a.x>=b.x) or (a.y>=b.y) or
         (abs(b.x-a.x)<=Precision(AbsEps,RelEps,abs(a.x)+abs(b.x))) or
         (abs(b.y-a.y)<=Precision(AbsEps,RelEps,abs(a.y)+abs(b.y)));
end;

function RectContainsPoint(const r:TRect2I; const p:TPoint2I):Boolean; overload;
begin
 with r do Result:=(p.x>=a.x) and (p.x<=b.x) and (p.y>=a.y) and (p.y<=b.y);
end;

function RectContainsPoint(const r:TRect2D; const p:TPoint2D):Boolean; overload;
begin
 with r do Result:=(p.x>=a.x) and (p.x<=b.x) and (p.y>=a.y) and (p.y<=b.y);
end;

function RectIntersection(const R1,R2:TRect2I):TRect2I; overload;
begin
 if R1.a.x>R2.a.x then Result.a.x:=R1.a.x else Result.a.x:=R2.a.x;
 if R1.a.y>R2.a.y then Result.a.y:=R1.a.y else Result.a.y:=R2.a.y;
 if R1.b.x<R2.b.x then Result.b.x:=R1.b.x else Result.b.x:=R2.b.x;
 if R1.b.y<R2.b.y then Result.b.y:=R1.b.y else Result.b.y:=R2.b.y;
end;

function RectIntersection(const R1,R2:TRect2D):TRect2D; overload;
begin
 if R1.a.x>R2.a.x then Result.a.x:=R1.a.x else Result.a.x:=R2.a.x;
 if R1.a.y>R2.a.y then Result.a.y:=R1.a.y else Result.a.y:=R2.a.y;
 if R1.b.x<R2.b.x then Result.b.x:=R1.b.x else Result.b.x:=R2.b.x;
 if R1.b.y<R2.b.y then Result.b.y:=R1.b.y else Result.b.y:=R2.b.y;
end;

function RectUnion(const R1,R2:TRect2I):TRect2I; overload;
begin
 if R1.a.x<R2.a.x then Result.a.x:=R1.a.x else Result.a.x:=R2.a.x;
 if R1.a.y<R2.a.y then Result.a.y:=R1.a.y else Result.a.y:=R2.a.y;
 if R1.b.x>R2.b.x then Result.b.x:=R1.b.x else Result.b.x:=R2.b.x;
 if R1.b.y>R2.b.y then Result.b.y:=R1.b.y else Result.b.y:=R2.b.y;
end;

function RectUnion(const R1,R2:TRect2D):TRect2D; overload;
begin
 if R1.a.x<R2.a.x then Result.a.x:=R1.a.x else Result.a.x:=R2.a.x;
 if R1.a.y<R2.a.y then Result.a.y:=R1.a.y else Result.a.y:=R2.a.y;
 if R1.b.x>R2.b.x then Result.b.x:=R1.b.x else Result.b.x:=R2.b.x;
 if R1.b.y>R2.b.y then Result.b.y:=R1.b.y else Result.b.y:=R2.b.y;
end;

function RectValidate(const r:TRect2I):TRect2I; overload;
var d:Integer;
begin
 Result:=r;
 with Result do begin
  if b.x<a.x then begin d:=a.x; a.x:=b.x; b.x:=d; end;
  if b.y<a.y then begin d:=a.y; a.y:=b.y; b.y:=d; end;
 end;
end;

function RectValidate(const r:TRect2D):TRect2D; overload;
var d:Double;
begin
 Result:=r;
 with Result do begin
  if b.x<a.x then begin d:=a.x; a.x:=b.x; b.x:=d; end;
  if b.y<a.y then begin d:=a.y; a.y:=b.y; b.y:=d; end;
 end;
end;

procedure PointMove(var p:TPoint2I; dx,dy:Integer); overload;
begin
 p.x:=p.x+dx;
 p.y:=p.y+dy;
end;

procedure PointMove(var p:TPoint2D; dx,dy:Double); overload;
begin
 p.x:=p.x+dx;
 p.y:=p.y+dy;
end;

procedure RectMove(var r:TRect2I; dx,dy:Integer); overload;
begin
 PointMove(r.a,dx,dy);
 PointMove(r.b,dx,dy);
end;

procedure RectMove(var r:TRect2D; dx,dy:Double); overload;
begin
 PointMove(r.a,dx,dy);
 PointMove(r.b,dx,dy);
end;

procedure PointMult(var p:TPoint2I; mx,my:Integer); overload;
begin
 p.x:=p.x*mx;
 p.y:=p.y*my;
end;

procedure PointMult(var p:TPoint2D; mx,my:Double); overload;
begin
 p.x:=p.x*mx;
 p.y:=p.y*my;
end;

procedure RectMult(var r:TRect2I; mx,my:Integer); overload;
begin
 PointMult(r.a,mx,my);
 PointMult(r.b,mx,my);
end;

procedure RectMult(var r:TRect2D; mx,my:Double); overload;
begin
 PointMult(r.a,mx,my);
 PointMult(r.b,mx,my);
end;

procedure RectGrow(var r:TRect2I; dx,dy:Integer); overload;
begin
 PointMove(r.a,-dx,-dy);
 PointMove(r.b,+dx,+dy);
end;

procedure RectGrow(var r:TRect2D; dx,dy:Double); overload;
begin
 PointMove(r.a,-dx,-dy);
 PointMove(r.b,+dx,+dy);
end;

function RectSizeX(const r:TRect2I):Integer; overload;
begin
 Result:=r.b.x-r.a.x;
end;

function RectSizeX(const r:TRect2D):double; overload;
begin
 Result:=r.b.x-r.a.x;
end;

function RectSizeY(const r:TRect2I):Integer; overload;
begin
 Result:=r.b.y-r.a.y;
end;

function RectSizeY(const r:TRect2D):double; overload;
begin
 Result:=r.b.y-r.a.y;
end;

function RectSize(const r:TRect):TPoint; overload;
begin
 Result.x:=r.Width;
 Result.y:=r.Height;
end;

function RectSize(const r:TRect2I):TPoint2I; overload;
begin
 Result.x:=r.b.x-r.a.x;
 Result.y:=r.b.y-r.a.y;
end;

function RectSize(const r:TRect2D):TPoint2D; overload;
begin
 Result.x:=r.b.x-r.a.x;
 Result.y:=r.b.y-r.a.y;
end;

function RectCenterX(const r:TRect2I):Integer; overload;
begin
 Result:=(r.b.x+r.a.x) shr 1;
end;

function RectCenterX(const r:TRect2D):double; overload;
begin
 Result:=(r.b.x+r.a.x)*0.5;
end;

function RectCenterY(const r:TRect2I):Integer; overload;
begin
 Result:=(r.b.y+r.a.y) shr 1;
end;

function RectCenterY(const r:TRect2D):double; overload;
begin
 Result:=(r.b.y+r.a.y)*0.5;
end;

function RectCenter(const r:TRect2I):TPoint2I; overload;
begin
 Result.x:=(r.b.x+r.a.x) shr 1;
 Result.y:=(r.b.y+r.a.y) shr 1;
end;

function RectCenter(const r:TRect2D):TPoint2D; overload;
begin
 Result.x:=(r.b.x+r.a.x)*0.5;
 Result.y:=(r.b.y+r.a.y)*0.5;
end;

function  isNan(const p:TPoint2D):Boolean; overload;
begin
 Result:=isNan(p.x) or isNan(p.y);
end;

function  isNan(const r:TRect2D):Boolean; overload;
begin
 Result:=isNan(r.a) or isNan(r.b);
end;

function  isInf(const p:TPoint2D):Boolean; overload;
begin
 Result:=isInf(p.x) or isInf(p.y);
end;

function  isInf(const r:TRect2D):Boolean; overload;
begin
 Result:=isInf(r.a) or isInf(r.b);
end;

function  isNanOrInf(const p:TPoint2D):Boolean; overload;
begin
 Result:= isNan(p) or isInf(p);
end;

function  isNanOrInf(const r:TRect2D):Boolean; overload;
begin
 Result:=isNan(r) or isInf(r);
end;

 {
 **********************************
 Utilites for axis grid calcultions
 **********************************
 }
function AxisGrid(xmin,xmax:Double):TAxisGrid;
var aPow,aStep,aNum,aDelta:Double;
 procedure CorrectStep(factor:Double);
 begin
  with Result do begin
   Step:=aStep*factor;
   aNum:=aDelta/Step;
  end;
 end;
begin
 with Result do begin
  Pow:=Trunc(logN(10,max(abs(xmin),abs(xmax))));
  Scale:=power(10,Pow);
  case Pow of
   -1,0..3:begin Scale:=1; Pow:=0; end;
  end;
  aDelta:=(xmax-xmin)/Scale;
  aPow:=Trunc(logN(10,abs(aDelta)))-1;
  aStep:=power(10,aPow);
  Step:=aStep;
  aNum:=aDelta/Step;
  if aNum>100 then CorrectStep(20);
  if aNum>50  then CorrectStep(10);
  if aNum>25  then CorrectStep(5);
  if aNum>10  then CorrectStep(2);
  if aNum<1   then CorrectStep(0.1);
  if aNum<2   then CorrectStep(0.2);
  if aNum<5   then CorrectStep(0.5);
  Step:=Step*Scale;
  Num:=round(aNum);
  Start:=round(xmin/Step)*Step;
 end;
end;

 {
 ****************************************************************************
 Find intersection of two segments of line (Start1,Stop1) and (Start2,Stop2).
 Return false, if this line segments has no intersection.
 ****************************************************************************
 }
function SegmentsHasIntersection(const Start1       : TPoint2D;
                                 const Stop1        : TPoint2D;
                                 const Start2       : TPoint2D;
                                 const Stop2        : TPoint2D;
                                  var  Intersection : TPoint2D
                                   ) : Boolean;
var d1,d2,d:TPoint2D; k1,k2,det,invdet,norm:double;
const
 ParallelThreshold=1E-12; {relative threshold: is parallel vectors or not}
begin
 d.x:=Start2.x-Start1.x;
 d.y:=Start2.y-Start1.y;
 d1.x:=Stop1.x-Start1.x;
 d1.y:=Stop1.y-Start1.y;
 d2.x:=Stop2.x-Start2.x;
 d2.y:=Stop2.y-Start2.y;
 det:=d1.y*d2.x-d1.x*d2.y;
 norm:=Hypot(d1.x,d1.y)*Hypot(d2.x,d2.y);
 {check: is vectors parallel or not (then determinant 0 or too small)}
 if abs(det)>norm*ParallelThreshold then begin
  invdet:=1/det;
  k1:=(-d2.y*d.x+d2.x*d.y)*invdet;
  k2:=(-d1.y*d.x+d1.x*d.y)*invdet;
  Intersection.x:=Start1.x+k1*d1.x; {=Start2.x+k2*d2.x}
  Intersection.y:=Start1.y+k1*d1.y; {=Start2.y+k2*d2.y}
  Result:=(k1>=0) and (k1<=1) and (k2>=0) and (k2<=1);
 end else begin
  Intersection.x:=0;
  Intersection.y:=0;
  Result:=false;
 end;
end;

 {
 ********************
 Virtual line drawing
 ********************
 }
procedure VirtualDrawLine(X1,Y1,X2,Y2,Color : Integer;
                          VirtualPixel      : TVirtualDrawPixel;
                          CustomData        : Pointer);
var X, Y, dx, dy, d, Incr1, Incr2, XStep, YStep : Integer;
begin
 if Assigned(VirtualPixel) then begin
  dx:= abs(X2-X1);
  dy:= abs(Y2-Y1);
  if X1 > X2 then XStep:= -1 else XStep:= 1;
  if Y1 > Y2 then YStep:= -1 else YStep:= 1;
  X := X1;
  Y := Y1;
  if dy <= dx then begin
   incr1:= dy shl 1;
   d:= incr1 - dx;
   incr2:= d - dx;
   while X <> X2 do begin
    VirtualPixel(x,y,Color,CustomData);
    inc(X, XStep);
    if d < 0 then inc(d, Incr1) else begin inc(d, Incr2); inc(Y, YStep); end;
   end;
  end else begin
   incr1:= dx shl 1;
   d:= incr1 - dy;
   incr2:= d - dy;
   while Y <> Y2 do begin
    VirtualPixel(x,y,Color,CustomData);
    inc(Y, YStep);
    if d < 0 then inc(d, Incr1) else begin inc(d, Incr2); inc(X, XStep); end;
   end;
  end;
  VirtualPixel(x,y,Color,CustomData);
 end;
end;

 {
 ******************************
 Surface plot internal routines
 ******************************
 }
const
 NO_VALUE  = MaxInt;
 BigDouble = 1E307;

type
 TEye           = packed record Eye:TPoint2D; Screen:TPoint2I; end;
 TEyeArray      = packed array[0..MaxInt div sizeof(TEye)-1] of TEye;
 TEyeMatrix     = packed array[0..MaxInt div sizeof(Pointer)-1] of ^TEyeArray;
 THorizontRec   = packed record YMin,YMax:integer; end;
 THorizontArray = packed array[0..MaxInt div sizeof(THorizontRec) - 1 ] of THorizontRec;
 TSurfBuf       = packed record
  Npx           : Integer;
  Npy           : Integer;
  Nmax          : Integer;
  PutPixel      : TVirtualDrawPixel;
  UpColor       : Integer;
  DownColor     : Integer;
  Custom        : Pointer;
  Horizont      : ^THorizontArray;
  Eyes          : ^TEyeMatrix;
 end;

procedure FreeBuffers(var SurfBuf:TSurfBuf);
var i:Integer;
begin
 with SurfBuf do begin
  Deallocate(Pointer(Horizont));
  for i:=0 to (AllocSize(Eyes) div sizeof(Eyes[0]))-1 do Deallocate(Pointer(Eyes[i]));
  Deallocate(Pointer(Eyes));
  Npx:=0;
  Npy:=0;
  Nmax:=0;
  PutPixel:=nil;
  UpColor:=0;
  DownColor:=0;
  Custom:=nil;
  Horizont:=nil;
  Eyes:=nil;
 end;
end;

function InitBuffers(out SurfBuf    : TSurfBuf;
                         aNmax      : Integer;
                         aNpx       : Integer;
                         aNpy       : Integer;
                         aPutPixel  : TVirtualDrawPixel;
                         aUpColor   : Integer;
                         aDownColor : Integer;
                         aCustom    : Pointer):Boolean;
var i:Integer;
begin
 Result:=true;
 with SurfBuf do begin
  Nmax:=aNmax;
  Npx:=aNpx;
  Npy:=aNpy;
  PutPixel:=aPutPixel;
  UpColor:=aUpColor;
  DownColor:=aDownColor;
  Custom:=aCustom;
  Horizont:=Allocate(Nmax*sizeof(Horizont[0]));
  Eyes:=Allocate(Npx*sizeof(Eyes[0]));
  if Assigned(Eyes) then for i:=0 to Npx-1 do Eyes[i]:=Allocate(Npy*sizeof(Eyes[0][0]));
  if not (Assigned(Horizont) and Assigned(Eyes) and Assigned(PutPixel)) then begin
   Result:=false;
   FreeBuffers(SurfBuf);
   exit;
  end;
  for i:=0 to Npx-1 do if not Assigned(Eyes[i]) then begin
   Result:=false;
   FreeBuffers(SurfBuf);
   exit;
  end;
  {mark first line}
  for i:=0 to Nmax-1 do  with Horizont[i] do begin
   Ymax:=NO_VALUE;
   Ymin:=NO_VALUE;
  end;
 end;
end;

 {
 Raster algoritm based on Bresenhem, adapted for floating horizont (FH)
 }
procedure DrawLineFH(const p1,p2:TPoint2I; const SurfBuf:TSurfBuf; First:boolean);
var
 i,d,d1,d2,m1,m2,dx,dy,sx,sy:Integer;
 p:TPoint2I;
begin
 with SurfBuf do
 if (p1.x>=0) and (p2.x>=0) and (p1.x<Nmax) and (p2.x<Nmax) then begin
  dx:=abs(p2.x-p1.x);
  dy:=abs(p2.y-p1.y);
  if p2.x >= p1.x then sx:= 1 else sx:= -1;
  if p2.y >= p1.y then sy:= 1 else sy:= -1;
  p:=p1;
  if dy <= dx then begin
   d1:=dy shl 1;
   d2:=(dy-dx) shl 1;
   d:=d1-dx;
   for i:=0 to dx do begin
    with Horizont[p.x] do
    if (Ymin=NO_VALUE) or First then begin {that is first line}
     putpixel(p.x,p.y,UpColor,Custom);
     Ymin:=p.y;
     Ymax:=p.y;
    end else
    if p.y < Ymin then begin        {point lower then horizont}
     putpixel(p.x,p.y,DownColor,Custom);
     Ymin:=p.y;
    end else
    if p.y > Ymax then begin        {point upper then horizont}
     putpixel(p.x,p.y,UpColor,Custom);
     Ymax:=p.y;
    end;
    if d > 0 then begin             {Bresenhem step}
     inc(d,d2);
     inc(p.y,sy);
    end else inc(d,d1);
    inc(p.x,sx);
   end;
  end else begin
   d1:=dx shl 1;
   d2:=(dx-dy) shl 1;
   d:=d1-dy;
   with Horizont[p1.x] do begin
    m1:=Ymin;
    m2:=Ymax;
   end;
   for i:=0 to dy do begin
    with Horizont[p.x] do
    if (Ymin=NO_VALUE) or First then begin {that is first line}
     putpixel(p.x,p.y,UpColor,Custom);
     Ymin:=p.y;
     Ymax:=p.y;
     m1:=Ymin;
     m2:=Ymax;
    end else
    if p.y < m1 then begin          {point lower then horizont}
     putpixel(p.x,p.y,DownColor,Custom);
     if p.y < Ymin then Ymin:=p.y;
    end else
    if p.y > m2 then begin          {point upper then horizont}
     putpixel(p.x,p.y,UpColor,Custom);
     if p.y > Ymax then Ymax:=p.y;
    end;
    if d > 0 then begin             {Bresenhem step}
     inc(d,d2);
     inc(p.x,sx);
     with Horizont[p.x] do begin
      m1:=Ymin;
      m2:=Ymax;
     end;
    end else inc(d,d1);
    inc(p.y,sy);
   end;
  end;
 end;
end;

 {
 *****************************
 Plot a surface implementation
 *****************************
 }
function PlotSurface(x1             : Double;            {low x limit}
                     y1             : Double;            {low y limit}
                     x2             : Double;            {high x limit}
                     y2             : Double;            {high y limit}
                     f              : TSurfMatrix;       {surface z=f(x,y)}
                     nx             : Integer;           {num points along x}
                     ny             : Integer;           {num points along y}
                     phi            : Double;            {axial angle of view}
                     psi            : Double;            {tangential angle of view}
                     OrgX           : Integer;           {screen low x limit}
                     OrgY           : Integer;           {screen low y limit}
                     SizeX          : Integer;           {screen size along x}
                     SizeY          : Integer;           {screen size along y}
                     PutPixel       : TVirtualDrawPixel; {virtual pixel drawer}
                     UpColor        : Integer;           {color of surface upper side}
                     DownColor      : Integer;           {color of surface lower side}
               const Scale          : TPoint3D;          {scaling factors along x,y}
                 var Params         : TPlot3DParams;     {internally use}
                     Mode           : word;              {how to plot flags, see smXXX const}
                     Custom         : Pointer;           {any user data}
                     AxisCorrection : Boolean = true     {need axis correction}
                     ) : Boolean;                        {fals on out of memory}
var
 x       : Double;
 y       : Double;
 z       : Double;
 i       : Integer;
 j       : Integer;
 ix      : Integer;
 iy      : Integer;
 ix0     : Integer;
 iy0     : Integer;
 dx      : Integer;
 dy      : Integer;
 Ep      : TPoint2d;
 SurfBuf : TSurfBuf;
begin
 Result:=false;
 {
 try to allocate local buffers before plot
 }
 if Assigned(f) then
 if InitBuffers(SurfBuf,SizeX+OrgX*2+4,nx,ny,PutPixel,UpColor,DownColor,Custom) then
 with Params,SurfBuf do
 try
  {
  save params
  }
  with Lim    do begin A.X:=x1;  B.X:=x2; A.Y:=y1; B.Y:=y2; end;
  with Origin do begin X:=OrgX;  Y:=OrgY;  end;
  with Size   do begin X:=SizeX; Y:=SizeY; end;
  with N      do begin X:=Nx;    Y:=Ny;    end;
  {
  eval triganometry
  }
  sinphi:=sin(phi);
  cosphi:=cos(phi);
  sinpsi:=sin(psi);
  cospsi:=cos(psi);
  {
  eval projection vectors
  projection (x',y') of point (x,y,z) are
   x' = (e[1][1]*x+e[1][2]*y+e[1][3]*z)
   y' = (e[2][1]*x+e[1][2]*y+e[1][3]*z)
  or (x',y') = Rx(phi) * Rz(psi) * Pxy * (x,y,z), where:
   Rz,Rx- rotation matrixed round z,x,
   Pxy-matrix of projection to xy
  }
  e[1][1]:= cosphi;         e[1][2]:=-sinphi;         e[1][3]:= 0;
  e[2][1]:= sinphi*cospsi;  e[2][2]:= cosphi*cospsi;  e[2][3]:= sinpsi;
  e[3][1]:=-sinphi*sinpsi;  e[3][2]:=-cosphi*sinpsi;  e[3][3]:= cospsi;
  {
  eval step on x,y
  }
  h.x:=(x2-x1)/(nx-1);
  h.y:=(y2-y1)/(ny-1);
  {
  fill buffer with function values and find limits
  }
  xmin:= BigDouble;
  xmax:=-BigDouble;
  ymin:= BigDouble;
  ymax:=-BigDouble;
  zmin:= BigDouble;
  zmax:=-BigDouble;
  for i:=0 to nx-1 do
  for j:=0 to ny-1 do
  with Eyes[i][j] do begin
   {x,y,z-vertex of surface z=f(x,y) in node i,j}
   x:=x1+i*h.x;
   y:=y1+j*h.y;
   z:=f(i,j,Custom);
   {eval limits on z}
   if zmin>z then zmin:=z;
   if zmax<z then zmax:=z;
   {scaling}
   x:=x*Scale.X;
   y:=y*Scale.Y;
   z:=z*Scale.Z;
   {projection to picture sheet}
   Eye.X:=x*e[1][1]+y*e[1][2];
   Eye.Y:=x*e[2][1]+y*e[2][2]+z*e[2][3];
   {limits of projection}
   if xmax<Eye.X then xmax:=Eye.X;
   if xmin>Eye.X then xmin:=Eye.X;
   if ymax<Eye.Y then ymax:=Eye.Y;
   if ymin>Eye.Y then ymin:=Eye.Y;
  end;
  {limits for axis}
  if AxisCorrection then begin
   {x1,y1,zmin}
   x:=x1*Scale.X; y:=y1*Scale.Y;  z:=zmin*Scale.Z;
   Ep.X:=x*e[1][1]+y*e[1][2];     Ep.Y:=x*e[2][1]+y*e[2][2]+z*e[2][3];
   if xmax<Ep.X then xmax:=Ep.X;  if xmin>Ep.X then xmin:=Ep.X;
   if ymax<Ep.Y then ymax:=Ep.Y;  if ymin>Ep.Y then ymin:=Ep.Y;
   {x2,y1,zmin}
   x:=x2*Scale.X; y:=y1*Scale.Y;  z:=zmin*Scale.Z;
   Ep.X:=x*e[1][1]+y*e[1][2];     Ep.Y:=x*e[2][1]+y*e[2][2]+z*e[2][3];
   if xmax<Ep.X then xmax:=Ep.X;  if xmin>Ep.X then xmin:=Ep.X;
   if ymax<Ep.Y then ymax:=Ep.Y;  if ymin>Ep.Y then ymin:=Ep.Y;
   {x1,y2,zmin}
   x:=x1*Scale.X; y:=y2*Scale.Y;  z:=zmin*Scale.Z;
   Ep.X:=x*e[1][1]+y*e[1][2];     Ep.Y:=x*e[2][1]+y*e[2][2]+z*e[2][3];
   if xmax<Ep.X then xmax:=Ep.X;  if xmin>Ep.X then xmin:=Ep.X;
   if ymax<Ep.Y then ymax:=Ep.Y;  if ymin>Ep.Y then ymin:=Ep.Y;
   {x1,y1,zmax}
   x:=x1*Scale.X; y:=y1*Scale.Y;  z:=zmax*Scale.Z;
   Ep.X:=x*e[1][1]+y*e[1][2];     Ep.Y:=x*e[2][1]+y*e[2][2]+z*e[2][3];
   if xmax<Ep.X then xmax:=Ep.X;  if xmin>Ep.X then xmin:=Ep.X;
   if ymax<Ep.Y then ymax:=Ep.Y;  if ymin>Ep.Y then ymin:=Ep.Y;
  end;
  {
  Find scale coefficients from rectangle (xmin,ymin,xmax,ymax) to
  (OrgX,OrgY,OrgX+SizeX,OrgY+SizeY)
  }
  b.x:=SizeX/(xmax-xmin);
  b.y:=SizeY/(ymax-ymin);
  a.x:=OrgX-xmin*b.x;
  a.y:=OrgY-ymin*b.y;
  {
  Find screen coordinates Eyes.Screen using known picture coordinates Eyes.Eye
  }
  for i:=0 to nx-1 do
  for j:=0 to ny-1 do
  with Eyes[i][j] do begin
   Screen.X:=round(a.x+b.x*Eye.X);
   Screen.Y:=round(a.y+b.y*Eye.Y);
  end;
  {
  we must go from front to back in any axial angles
  }
  if sinphi>=0 then dx:=1 else dx:=-1;
  if cosphi>=0 then dy:=1 else dy:=-1;
  if dx>0 then ix0:=0 else ix0:=nx-1;
  if dy>0 then iy0:=0 else iy0:=ny-1;
  {
  Now draw with correct order x and y-lines
  }
  if Assigned(PutPixel) then
  case Mode and (smSliceX+smSliceY) of
   {
   draw only vertexes
   }
   0:
    for i:=0 to nx-1 do
    for j:=0 to ny-1 do with Eyes[i][j].Screen do PutPixel(x,y,UpColor,Custom);
   {
   draw only x-lines
   }
   smSliceX:
    for i:=0 to nx-1 do begin
     ix:=ix0+i*dx;
     for j:=0 to ny-2 do begin   {draw lines x=const}
      iy:=iy0+j*dy;
      DrawLineFH(Eyes[ix][iy].Screen, Eyes[ix][iy+dy].Screen, SurfBuf, i=0);
     end;
    end;
   {
    draw only y-lines
   }
   smSliceY:
    for i:=0 to ny-1 do begin
     iy:=iy0+i*dy;
     for j:=0 to nx-2 do begin {draw lines y=const}
      ix:=ix0+j*dx;
      DrawLineFH(Eyes[ix][iy].Screen, Eyes[ix+dx][iy].Screen, SurfBuf, i=0);
     end;
    end;
   {
   draw both lines X=const,Y=const with order selection
   }
   smSliceX+smSliceY:
   if abs(cosphi)>=abs(sinphi) then begin
    {
    must draw y-lines first
    }
    for i:=0 to ny-1 do begin
     iy:=iy0+i*dy;
     for j:=0 to nx-2 do begin {draw lines y=const}
      ix:=ix0+j*dx;
      DrawLineFH(Eyes[ix][iy].Screen, Eyes[ix+dx][iy].Screen, SurfBuf, i=0);
     end;
     if i < ny-1 then
     for j:=0 to nx-1 do begin {draw lines x=const}
      ix:=ix0+j*dx;
      DrawLineFH(Eyes[ix][iy].Screen, Eyes[ix][iy+dy].Screen, SurfBuf, j=0);
     end;
    end;
   end else begin
    {
    must draw x-lines first
    }
    for i:=0 to nx-1 do begin
     ix:=ix0+i*dx;
     for j:=0 to ny-2 do begin   {draw lines x=const}
      iy:=iy0+j*dy;
      DrawLineFH(Eyes[ix][iy].Screen, Eyes[ix][iy+dy].Screen, SurfBuf, i=0);
     end;
     if i < nx-1 then
     for j:=0 to ny-1 do begin {draw lines y=const}
      iy:=iy0+j*dy;
      DrawLineFH(Eyes[ix][iy].Screen, Eyes[ix+dx][iy].Screen, SurfBuf, j=0);
     end;
    end;
   end;
  end;
  Result:=true;
 finally
  FreeBuffers(SurfBuf);
 end;{with Params}
end;

 {
 ******************
 Cga color utilites
 ******************
 }
type
 TRGB = packed record
  r : Byte;
  g : Byte;
  b : Byte;
  z : Byte;
 end;

function RGB(r,g,b:Integer):TColor;
begin
 TRGB(Result).r:=r;
 TRGB(Result).g:=g;
 TRGB(Result).b:=b;
 TRGB(Result).z:=0;
end;

function CgaToRGBColor(Color:Integer):TColor;
 function CgaToRgb(Color:Integer):TColor;
 const
  BlueMask   = 1;
  GreenMask  = 2;
  RedMask    = 4;
  BrightMask = 8;
  L1         = 255 div 3;
  L2         = 255 - L1;
 var
  C:TRGB;
 begin
  TColor(C):=0;
  if Color and RedMask    <> 0 then inc(C.R, L2);
  if Color and GreenMask  <> 0 then inc(C.G, L2);
  if Color and BlueMask   <> 0 then inc(C.B, L2);
  if Color and BrightMask <> 0 then begin
   inc(C.R, L1);
   inc(C.G, L1);
   inc(C.B, L1);
  end;
  Result:=TColor(C);
 end;
const
 CgaTable:array[0..15] of TColor=(clBlack,   clNavy,    clGreen,  clTeal,
                                  clMaroon,  clPurple,  clOlive,  clSilver,
                                  clGray,    clBlue,    clLime,   clAqua,
                                  clRed,     clFuchsia, clYellow, clWhite);
var
 i:Integer;
begin
 if CgaTable[15]=0 then for i:=0 to 15 do CgaTable[i]:=CgaToRgb(i);
 Result:=CgaTable[Color and 15];
end;

function CgaColorNameEng(Color:Integer):LongString;
begin
 case Color and 15 of
  Black        : Result:='Black';
  Blue         : Result:='Blue';
  Green        : Result:='Green';
  Cyan         : Result:='Cyan';
  Red          : Result:='Red';
  Magenta      : Result:='Magenta';
  Brown        : Result:='Brown';
  LightGray    : Result:='LightGray';
  DarkGray     : Result:='DarkGray';
  LightBlue    : Result:='LightBlue';
  LightGreen   : Result:='LightGreen';
  LightCyan    : Result:='LightCyan';
  LightRed     : Result:='LightRed';
  LightMagenta : Result:='LightMagenta';
  Yellow       : Result:='Yellow';
  White        : Result:='White';
  else           Result:='';
 end;
end;

function CgaColorNameRus(CgaColor:Integer):LongString;
begin
 case CgaColor and 15 of
  Black        : Result:='Черный';
  Blue         : Result:='Синий';
  Green        : Result:='Зеленый';
  Cyan         : Result:='Циановый';
  Red          : Result:='Красный';
  Magenta      : Result:='Фиолетовый';
  Brown        : Result:='Коричневый';
  LightGray    : Result:='СветлоСерый';
  DarkGray     : Result:='ТемноСерый';
  LightBlue    : Result:='СветлоСиний';
  LightGreen   : Result:='СветлоЗеленый';
  LightCyan    : Result:='СветлоЦиановый';
  LightRed     : Result:='СветлоКрасный';
  LightMagenta : Result:='СветлоФиолетовый';
  Yellow       : Result:='Желтый';
  White        : Result:='Белый';
  else           Result:='';
 end;
end;

function  CgaColorByName(const S:LongString):Integer;
var CgaColor:integer;
begin
 Result:=0;
 for CgaColor:=0 to 15 do begin
  if SameText(S,CgaColorNameEng(CgaColor)) or
     SameText(S,CgaColorNameRus(CgaColor))
  then begin
   Result:=CgaColor;
   break;
  end;
 end;
end;

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

procedure Init_crw_plut;
begin
end;

procedure Free_crw_plut;
begin
end;

initialization

 Init_crw_plut;

finalization

 Free_crw_plut;

end.

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

