unit U3d;

interface

uses Windows, OpenGL;

//        ================================================================
//                   * * *              КОНСТАНТЫ            * * *
//        ================================================================
const
  M_PI  = 3.14159265359;
  M_2PI = 6.28318530718;
  M_PI2 = 1.570796326795;
  M_PI3 = 1.047197551197;
  M_PI4 = 0.7853981633975;
  M_PI6 = 0.5235987755983;
  ANGLE_0 = 0.0;
  ANGLE_1 = 0.017453292;
  ANGLE_5 = 0.087266462;
  ANGLE_10 = 0.174532925;
  ANGLE_15 = 0.261799387;
  ANGLE_20 = 0.392699081;
  ANGLE_30 = 0.523598775;
  ANGLE_45 = 0.785398163;
  ANGLE_60 = 1.047197551;
  ANGLE_72 = 1.256637061;
  ANGLE_90 = 1.570796327;
  ANGLE_120 = 2.094395102;
  ANGLE_135 = 2.35619449;
  ANGLE_144 = 2.513274123;
  ANGLE_180 = 3.141592653;
  ANGLE_225 = 3.926990817;
  ANGLE_270 = 4.71238898;
  ANGLE_315 = 5.497787144;
  ANGLE_360 = 6.283185307;
  RAD_IN_ANGLE = 0.01745329251994;
  ANGLE_IN_RAD = 57.29577951618;
//  Максимальное количество вершин в сетке
  MAXVERTEX = 64 * 1024;
//  Ссылки на компоненты вектора нак на углы
  PITCH  = 0;
  YAW    = 1;
  ROLL   = 2;
//        ================================================================
//                   * * *      ОПРЕДЕЛЕНИЯ ТИПОВ ДАННЫХ     * * *
//        ================================================================
type
  u3dval_p= ^u3dval;
  u3dval  = single;

type
  vector_p = ^vector_t;
  vector_t = record
    case integer of
    1 : (x,y,z : u3dval);
    2 : (pitch,yaw,roll : u3dval);
    3 : (elements : array[0..2] of u3dval);
  end;
  vector_array_p = ^vector_array_t;
  vector_array_t = array[0..MAXVERTEX] of vector_t;
// =======================================================================
  hvector_p = ^hvector_t;
  hvector_t = record
    case integer of
    1 : (x,y,z,w : u3dval);
    2 : (elements : array[0..3] of u3dval);
  end;
  hvector_array_p = ^hvector_array_t;
  hvector_array_t = array[0..MAXVERTEX] of hvector_t;
// =======================================================================
  matrix_p = ^matrix_t;
  matrix_t = array[0..2,0..2] of u3dval;
// =======================================================================
  hmatrix_p = ^hmatrix_t;
  hmatrix_t = array[0..3,0..3] of u3dval;
// =======================================================================
  transform_p = ^transform_t;
  transform_t = array[0..2,0..3] of u3dval;
// =======================================================================
  texcoord_p = ^texcoord_t;
  texcoord_t = record
    u,v : u3dval;
  end;
  texcoord_array_p = ^texcoord_array_t;
  texcoord_array_t = array[0..MAXVERTEX] of texcoord_t;
// =======================================================================
  rgb_p = ^rgb_t;
  rgb_t = record
    r,g,b : u3dval;
  end;
  rgb_array_p = ^rgb_array_t;
  rgb_array_t = array[0..MAXVERTEX] of rgb_t;
// =======================================================================
  rgba_p = ^rgba_t;
  rgba_t = record
    r,g,b,a : u3dval;
  end;
  rgba_array_p = ^rgba_array_t;
  rgba_array_t = array[0..MAXVERTEX] of rgba_t;
// =======================================================================
  bytergb_p = ^bytergb_t;
  bytergb_t = record
    r,g,b : byte;
  end;
  bytergb_array_p = ^bytergb_array_t;
  bytergb_array_t = array[0..MAXVERTEX] of bytergb_t;
// =======================================================================
  bytergba_p = ^bytergba_t;
  bytergba_t = record
    case integer of
      1 : (r,g,b,a : byte);
      2 : (color : dword);
  end;
  bytergba_array_p = ^bytergba_array_t;
  bytergba_array_t = array[0..MAXVERTEX] of bytergba_t;
// =======================================================================
  bytebgr_p = ^bytebgr_t;
  bytebgr_t = record
    b,g,r : byte;
  end;
  bytebgr_array_p = ^bytebgr_array_t;
  bytebgr_array_t = array[0..MAXVERTEX] of bytebgr_t;
// =======================================================================
  byteabgr_p = ^byteabgr_t;
  byteabgr_t = record
    case integer of
      1 : (a,b,g,r : byte);
      2 : (color : dword);
  end;
  byteabgr_array_p = ^byteabgr_array_t;
  byteabgr_array_t = array[0..MAXVERTEX] of byteabgr_t;
// =======================================================================
  tlvertex_p = ^tlvertex_t;
  tlvertex_t  = record
    sc        : vector_t;
    rw        : u3dval;
    cl, sp    : byteabgr_t;
    tx        : texcoord_t;
  end;
  tlvertex_array_p  = ^tlvertex_array_t;
  tlvertex_array_t  = array[0..MAXVERTEX] of tlvertex_t;
// =======================================================================
  generic_mesh_p = ^generic_mesh_t;
  generic_mesh_t  = record
    nvertices     : integer;
    vertices      : vector_array_p;
    normals       : vector_array_p;
    colors        : rgb_array_p;
    texcoords     : texcoord_array_p;
  end;
// =======================================================================
  PSurfaceRec = ^TSurfaceRec;
  TSurfaceRec = record
    nVertices   : integer;
    pVertices   : vector_array_p;
    pNormals    : vector_array_p;
    pColors     : rgb_array_p;
    pTexCoords  : texcoord_array_p;
    Reserved1   : array[1..3] of integer;
    K,L         : integer;
    pFaceNormals: vector_array_p;
    Reserved2   : integer;
  end;
  PGLSurface = ^TGLSurface;
  TGLSurface = object
  public
    Surf     : TSurfaceRec;
    constructor  Create(K,L:integer);
    destructor   Destroy;
    procedure    Vertex(Vert,Norm:vector_p;Color:rgb_p);
    procedure    GenerateNormals;
    procedure    SetBoundingBox(var Min,Max:vector_t);
    procedure    Draw(NeedBlend,NeedLines:Boolean;LineColor:dword);
  end;

// =======================================================================
//        Работа с памятью
//        ================================================================
procedure memFill(blk:pointer;value,length:integer);pascal;external '3dcore.dll' name 'MEMFILL';
procedure memZero(blk:pointer;length:integer);pascal;external '3dcore.dll' name 'MEMZERO';
procedure memCopy(dst,src:pointer;length:integer);pascal;external '3dcore.dll' name 'MEMCOPY';
function  memIdent(blk1,blk2:pointer;length:integer):Boolean;pascal;external '3dcore.dll' name 'MEMIDENT';
//        ================================================================
//        Векторные операции
//        ================================================================
procedure  vtSet(var v:vector_t;x,y,z:u3dval);register;
procedure  vthSet(var v:hvector_t;x,y,z,w:u3dval);register;
procedure  vtZero(var v:vector_t);pascal;external '3dcore.dll' name 'VTZERO';
procedure  vthZero(var v:hvector_t);pascal;external '3dcore.dll' name 'VTHZERO';
procedure  vtCopy(var dst,src:vector_t);pascal;external '3dcore.dll' name 'VTCOPY';
procedure  vthCopy(var dst,src:hvector_t);pascal;external '3dcore.dll' name 'VTHCOPY';
procedure  vtAdd(var dst,v1,v2:vector_t);pascal;external '3dcore.dll' name 'VTADD';
procedure  vthAdd(var dst,v1,v2:hvector_t);pascal;external '3dcore.dll' name 'VTHADD';
procedure  vtSub(var dst,v1,v2:vector_t);pascal;external '3dcore.dll' name 'VTSUB';
procedure  vthSub(var dst,v1,v2:hvector_t);pascal;external '3dcore.dll' name 'VTHSUB';
procedure  vtNegate(var dst,src:vector_t);pascal;external '3dcore.dll' name 'VTNEGATE';
procedure  vthNegate(var dst,src:hvector_t);pascal;external '3dcore.dll' name 'VTHNEGATE';
procedure  vtMul(var dst,v:vector_t;ml:u3dval);register;
procedure  vthMul(var dst,v:hvector_t;ml:u3dval);register;
procedure  _vtMul(var dst,v:vector_t;ml:u3dval);pascal;external '3dcore.dll' name 'VTHMUL';
procedure  _vthMul(var dst,v:hvector_t;ml:u3dval);pascal;external '3dcore.dll' name 'VTHMUL';
procedure  _vtDot(var v1,v2:vector_t;var res:u3dval);pascal;external '3dcore.dll' name 'VTDOT';
procedure  vthDot(var v1,v2:hvector_t;var res:u3dval);pascal;external '3dcore.dll' name 'VTHDOT';
function   vtDot(var v1,v2:vector_t):u3dval;register;
procedure  _vtAbs(var v:vector_t;var res:u3dval);pascal;external '3dcore.dll' name 'VTABS';
function   vtAbs(var v:vector_t):u3dval;register;
procedure  vtNormalize(var v:vector_t);pascal;external '3dcore.dll' name 'VTNORMALIZE';
procedure  vthNormalize(var v:vector_t);pascal;external '3dcore.dll' name 'VTHNORMALIZE';
procedure  vtHomogenize(var v:hvector_t);pascal;external '3dcore.dll' name 'VTHHOMOGENIZE';
procedure  vtCross(var dst,v1,v2:vector_t);pascal;external '3dcore.dll' name 'VTCROSS';
procedure  vtMin(var v:vector_t;var res:u3dval;var ind:integer);pascal;external '3dcore.dll' name 'VTMIN';
procedure  vtMax(var v:vector_t;var res:u3dval;var ind:integer);pascal;external '3dcore.dll' name 'VTMAX';
function   vtIsZero(var v:vector_t):integer;pascal;external '3dcore.dll' name 'VTISZERO';
function   vthIsZero(var v:hvector_t):integer;pascal;external '3dcore.dll' name 'VTHISZERO';
function   vtIsEqual(var v1,v2:vector_t):integer;pascal;external '3dcore.dll' name 'VTISEQUAL';
function   vthIsEqual(var v1,v2:hvector_t):integer;pascal;external '3dcore.dll' name 'VTHISEQUAL';
procedure  vtScaleBy(var dst,v1,v2:vector_t);pascal;external '3dcore.dll' name 'VTSCALEBY';
procedure  vthScaleBy(var dst,v1,v2:hvector_t);pascal;external '3dcore.dll' name 'VTHSCALEBY';
procedure  vtZoomIF(var zoom,initial,final:vector_t);pascal;external '3dcore.dll' name 'VTZOOMIF';
procedure  vthZoomIF(var zoom,initial,final:hvector_t);pascal;external '3dcore.dll' name 'VTHZOOMIF';
procedure  vtRadToDeg(var dst,src:vector_t);pascal;external '3dcore.dll' name 'VTRADTODEG';
procedure  vtDegToRad(var dst,src:vector_t);pascal;external '3dcore.dll' name 'VTDEGTORAD';
procedure  vtProjectOnPlane(var dst,p,normal);pascal;external '3dcore.dll' name 'VTPROJECTONPLANE';
procedure  vtPerpendicular(var dst,src:vector_t);pascal;external '3dcore.dll' name 'VTPERPENDICULAR';
procedure  vtRotateAroundVector(var dst,dir,point:vector_t;radians:u3dval);pascal;external '3dcore.dll' name 'VTROTATEAROUNDVECTOR';
//        ================================================================
//        Матричные операции
//        ================================================================
procedure mtZero(var mat:matrix_t);pascal;external '3dcore.dll' name 'MTZERO';
procedure mthZero(var mat:hmatrix_t);pascal;external '3dcore.dll' name 'MTHZERO';
procedure mttZero(var mat:transform_t);pascal;external '3dcore.dll' name 'MTTZERO';
procedure mtCopy(var dst,src:matrix_t);pascal;external '3dcore.dll' name 'MTCOPY';
procedure mthCopy(var dst,src:hmatrix_t);pascal;external '3dcore.dll' name 'MTHCOPY';
procedure mttCopy(var dst,src:transform_t);pascal;external '3dcore.dll' name 'MTTCOPY';
procedure mtIdentity(var mat:matrix_t);pascal;external '3dcore.dll' name 'MTIDENTITY';
procedure mthIdentity(var mat:hmatrix_t);pascal;external '3dcore.dll' name 'MTHIDENTITY';
procedure mttIdentity(var mat:transform_t);pascal;external '3dcore.dll' name 'MTTIDENTITY';
//        В качетве dst для Set/GetLU можно передавать hmatrix/transform
procedure mtSetLU(var mat;var src:matrix_t);pascal;external '3dcore.dll' name 'MTSETLU';
procedure mtGetLU(var dst:matrix_t;var src);pascal;external '3dcore.dll' name 'MTGETLU';
procedure mtVectorows(var mat:matrix_t;var r1,r2,r3:vector_t);pascal;external '3dcore.dll' name 'MTVECTOROWS';
procedure mtVectorowsv(var mat:matrix_t;var r123:vector_array_t);pascal;external '3dcore.dll' name 'MTVECTOROWSW';
procedure mthVectorows(var mat:hmatrix_t;var r1,r2,r3:hvector_t);pascal;external '3dcore.dll' name 'MTHVECTOROWS';
procedure mthVectorowsv(var mat:hmatrix_t;var r123:hvector_array_t);pascal;external '3dcore.dll' name 'MTHVECTOROWSV';
procedure mtVectocols(var mat:matrix_t;var c1,c2,c3:vector_t);pascal;external '3dcore.dll' name 'MTVECTOCOLS';
//        Аналогично транспонированию матрицы
procedure mtVectocolsv(var mat:matrix_t;var c123:vector_array_t);pascal;external '3dcore.dll' name 'MTVECTOCOLSV';
procedure mthVectocols(var mat:hmatrix_t;var c1,c2,c3:hvector_t);pascal;external '3dcore.dll' name 'MTHVECTOCOLS';
//        Аналогично транспонированию матрицы
procedure mthVectocolsv(var mat:hmatrix_t;var c123:hvector_array_t);pascal;external '3dcore.dll' name 'MTHVECTOCOLSV';
procedure mtTranspose(var dst,src:matrix_t);pascal;external '3dcore.dll' name 'MTTRANSPOSE';
procedure mthTranspose(var dst,src:hmatrix_t);pascal;external '3dcore.dll' name 'MTHTRANSPOSE';
procedure mtSelftranspose(var mat:matrix_t);pascal;external '3dcore.dll' name 'MTSELFTRANSPOSE';
procedure mthSelftranspose(var mat:hmatrix_t);pascal;external '3dcore.dll' name 'MTHSELFTRANSPOSE';
procedure mtVecmul(var dst:vector_t;var mat:matrix_t;var v:vector_t);pascal;external '3dcore.dll' name 'MTVECMUL';
procedure mthVecmul(var dst:hvector_t;var mat:hmatrix_t;var v:hvector_t);pascal;external '3dcore.dll' name 'MTHVECMUL';
procedure mthVectransform(var dst:vector_t;var mat:transform_t;var v:vector_t);pascal;external '3dcore.dll' name 'MTHVECTRANSFORM';
procedure mtMul(var dst,m1,m2:matrix_t);pascal;external '3dcore.dll' name 'MTMUL';
procedure mthMul(var dst,m1,m2:hmatrix_t);pascal;external '3dcore.dll' name 'MTHMUL';
procedure mthMulTransforms(var dst,m1,m2:transform_t);pascal;external '3dcore.dll' name 'MTHMULTRANSFORMS';
procedure mthConcatTransform(var dst,tr:transform_t);pascal;external '3dcore.dll' name 'MTHCONCATTRANSFORM';
procedure mtXRotation(var mat:matrix_t;around_x:u3dval);pascal;external '3dcore.dll' name 'MTXROTATION';
procedure mtYRotation(var mat:matrix_t;around_y:u3dval);pascal;external '3dcore.dll' name 'MTYROTATION';
procedure mtZRotation(var mat:matrix_t;around_z:u3dval);pascal;external '3dcore.dll' name 'MTZROTATION';
//        ================================================================
//        Действия с цветами
//        ================================================================
procedure rgbByteToU3D(var rgb:rgb_t;var brgb:bytergb_t);pascal;external '3dcore.dll' name 'RGBBYTETOU3D';
procedure rgbaByteToU3D(var rgba:rgba_t;var brgba:bytergba_t);pascal;external '3dcore.dll' name 'RGBABYTETOU3D';
procedure rgbU3DToByte(var brgb:bytergb_t;var rgb:rgb_t);pascal;external '3dcore.dll' name 'RGBU3DTOBYTE';
procedure rgbaU3DToByte(var brgba:bytergba_t;var rgba:rgba_t);pascal;external '3dcore.dll' name 'RGBAU3DTOBYTE';
procedure rgbSet(var rgb:rgb_t;r,g,b:u3dval);register;
procedure rgbaSet(var rgb:rgba_t;r,g,b,a:u3dval);register;
procedure brgbSet(var rgb:bytergb_t;r,g,b:byte);register;
procedure brgbaSet(var rgb:bytergba_t;r,g,b,a:byte);register;
procedure Color2RGB(Color:integer;var rgb:rgb_t);
//        ================================================================
//        Действия с текстурами
//        ================================================================
procedure texEnvironMap(var mat:transform_t;var normal:vector_t;var uv:texcoord_t);pascal;external '3dcore.dll' name 'TEXENVIRONMAP';
//        ================================================================
//        Действия с поверхностями
//        ================================================================
procedure surfNew(surf:PSurfaceRec;k,l:integer);pascal;external '3DCORE.DLL' name 'SURFNEW';
procedure surfDelete(surf:PSurfaceRec);pascal;external '3DCORE.DLL' name 'SURFDELETE';
procedure surfAddVtx(surf:PSurfaceRec;vtx,nrm:vector_p;clr:rgb_p;txc:texcoord_p);pascal;external '3DCORE.DLL' name 'SURFADDVTX';
procedure surfGenerateFaceNorms(surf:PSurfaceRec);pascal;external '3DCORE.DLL' name 'SURFGENERATEFACENORMS';
procedure surfGenerateNorms(surf:PSurfaceRec);pascal;external '3DCORE.DLL' name 'SURFGENERATENORMS';
procedure surfNormalizeFNorms(surf:PSurfaceRec);pascal;external '3DCORE.DLL' name 'SURFNORMALIZEFNORMS';
procedure surfNormalizeNorms(surf:PSurfaceRec);pascal;external '3DCORE.DLL' name 'SURFNORMALIZENORMS';
procedure surfCalculateNormals(surf:PSurfaceRec);pascal;external '3DCORE.DLL' name 'SURFCALCULATENORMALS';
procedure surfGetBBox(surf:PSurfaceRec;var min,max:vector_t);pascal;external '3DCORE.DLL' name 'SURFGETBBOX';
procedure surfSetBBox(surf:PSurfaceRec;var min,max:vector_t);pascal;external '3DCORE.DLL' name 'SURFSETBBOX';
procedure surfTranslate(surf:PSurfaceRec;var tr:vector_t);pascal;external '3DCORE.DLL' name 'SURFTRANSLATE';
procedure surfScale(surf:PSurfaceRec;var sc:vector_t);pascal;external '3DCORE.DLL' name 'SURFSCALE';

implementation

procedure  vtSet;
begin
  v.x:=x;
  v.y:=y;
  v.z:=z;
end;

procedure  vthSet;
begin
  v.x:=x;
  v.y:=y;
  v.z:=z;
  v.w:=w;
end;

function   vtDot;
begin
  Result:=v1.x*v2.x+v1.y*v2.y+v1.z*v2.z;
end;

procedure  vtMul;
begin
  dst.x:=v.x*ml;
  dst.y:=v.y*ml;
  dst.z:=v.z*ml;
end;

procedure  vthMul;
begin
  dst.x:=v.x*ml;
  dst.y:=v.y*ml;
  dst.z:=v.z*ml;
  dst.w:=v.w*ml;
end;

function   vtAbs;
begin
  Result:=sqrt(vtDot(v,v));
end;

procedure rgbSet;
begin
  rgb.r:=r;
  rgb.g:=g;
  rgb.b:=b;
end;

procedure rgbaSet;
begin
  rgb.r:=r;
  rgb.g:=g;
  rgb.b:=b;
  rgb.a:=a;
end;

procedure brgbSet;
begin
  rgb.r:=r;
  rgb.g:=g;
  rgb.b:=b;
end;

procedure brgbaSet;
begin
  rgb.r:=r;
  rgb.g:=g;
  rgb.b:=b;
  rgb.a:=a;
end;

constructor TGLSurface.Create;
begin
  surfNew(@Surf,K,L);
end;

destructor TGLSurface.Destroy;
begin
  surfDelete(@Surf);
end;

procedure TGLSurface.Vertex;
begin
  surfAddVtx(@Surf,Vert,Norm,Color,nil);
end;

procedure TGLSurface.GenerateNormals;
begin
  surfCalculateNormals(@Surf);
end;

procedure TGLSurface.SetBoundingBox;
begin
  surfSetBBox(@Surf,Min,Max);
end;

procedure Color2RGB(Color:integer;var rgb:rgb_t);
begin
  rgb.r:=(Color and $FF)/256;
  rgb.g:=((Color shr 8) and $FF)/256;
  rgb.b:=((Color shr 16) and $FF)/256;
end;

procedure TGLSurface.Draw;
var
  i,j,uls,ul : integer;
  rgb : rgb_t;
begin
  glDisable(GL_CULL_FACE);
  if NeedBlend then
  begin
    glEnable(GL_BLEND);
    // Примитивы не отсортированы. Единсвенный способ реализации
    // прозрачности - суммирование.
    // glBlendFunc(GL_ONE,GL_ONE);
    // 14 may 2012
    glBlendFunc(GL_ONE_MINUS_DST_ALPHA, GL_DST_ALPHA);
    glDisable(GL_DEPTH_TEST);
  end
  else
  begin
    glDisable(GL_BLEND);
    glEnable(GL_DEPTH_TEST);
  end;
  // Рисуем поверхность ==================================================
  for i:=1 to Surf.L-1 do
  begin
    glBegin(GL_TRIANGLE_STRIP);
      glColor3fv(@Surf.pColors^[(i-1)*Surf.K]);
      glVertex3fv(@Surf.pVertices^[(i-1)*Surf.K]);
      for j:=0 to Surf.K-2 do
      begin
        glColor3fv(@Surf.pColors^[j+i*Surf.K]);
        glVertex3fv(@Surf.pVertices^[j+i*Surf.K]);
        glColor3fv(@Surf.pColors^[j+1+(i-1)*Surf.K]);
        glVertex3fv(@Surf.pVertices^[j+1+(i-1)*Surf.K]);
      end;
      glColor3fv(@Surf.pColors^[(i+1)*Surf.K - 1]);
      glVertex3fv(@Surf.pVertices^[(i+1)*Surf.K - 1]);
    glEnd;
  end;
  // =====================================================================
  if(NeedLines) then
  begin
    // Рисуем линии
    glDisable(GL_BLEND);
    glEnable(GL_DEPTH_TEST);
    Color2RGB(LineColor,rgb);
    glColor3fv(PGLfloat(@rgb));
    glPushMatrix;
    glTranslatef(0,0.01,0);
    // Вдоль
    uls:=0;
    for j:=0 to Surf.L-1 do
    begin
      ul:=uls;
      glBegin(GL_LINE_STRIP);
        for i:=0 to Surf.K-1 do
        begin
          glVertex3fv(@Surf.pVertices^[ul]);
          ul:=ul+1;
        end;
      glEnd;
      uls:=uls+Surf.K;
    end;
    // И поперек
    uls:=0;
    for j:=0 to Surf.K-1 do
    begin
      ul:=uls;
      glBegin(GL_LINE_STRIP);
        for i:=0 to Surf.L-1 do
        begin
          glVertex3fv(@Surf.pVertices^[ul]);
          ul:=ul+Surf.K;
        end;
      glEnd;
      uls:=uls+1;
    end;
    glPopMatrix;
  end;
  // =====================================================================
end;

end.

