old/PAS/RayTracing/GTYPES.PAS

Unit GTypes;
Interface
Uses UVector,Matrices;
CONST
  vecsize   = sizeof(tVec);

type
  float  = double;

  OBJId = (F_OBJ_SPHERE,F_LIGHT_OMNI,F_VIEWPORT,F_AMBIENT,F_OBJ_SURF_PLANE,
           F_NULL,F_CAMERA,F_TRI_PLANE,F_TRI,F_QUAD,F_TRANSLATE,F_ROTATE,
           F_SCALE,F_SPOTLIGHT,F_TEXTURE,F_INTER_SPHERE,F_CONE);

  RGB  = record
   R, G, B : float;
  end;

  BRGB = record
   B,G,R : byte;
  end;

  PPlane = ^TPlane;
  TPlane = record
    N : tVec;
    D : float;
  end;

  PSurfDesc = ^TSurfDesc;
  TSurfDesc = record
    Kd, Ks, Ns : float;
    {
      Kd - Коэффициент рассеяния
      Ks - Коэффициент отражения
      Ns - Коэффициент вида отражения
    }
  end;

  PBitPlane = ^TBitPlane;
  TBitPlane = array [0..16384] of BRGB;

  PTexture = ^TTexture;
  TTexture = object
    SizeX       : word;
    SizeY       : word;
    Bits        : PBitPlane;
    Name        : string[13];
    Constructor Init(sx,sy:word);
    Procedure   LoadTGA(fname:string);
    Destructor  Done;virtual;
  end;


  PRay = ^TRay;
  TRay = object
    Org  : TVec;
    Dir  : TVec;
    Constructor Init(aOrg, aDir : tVec);
    Procedure GetPoint(var aP : tVec; aT : float);
  end;

   Procedure SetColor(var aCol : RGB;aR,aG,aB:float);
   Procedure SetPlane(var P : TPLane; aV1, aV2, aV3:tVec);
   Function  Pack24(aCol : RGB):LongInt;
   Procedure LoadRGB(var F:FILE;var aCol:RGB);
   Procedure SaveRGB(var F:FILE;aCol:RGB);
   Procedure CalcTransform(var aT:TTRANSFORM;aV1,aV2,aV3:tVec;r,len:real);
   Procedure CAddMul(var aC:RGB;aM:RGB; mul : float);
Implementation
{TRay}
  Constructor TRay.Init;
  begin
   Org := aOrg;
   Dir := aDir;
  end; {TRay.Init}
  {-----------------------------}
  Procedure TRay.GetPoint;
  begin
    VLinear(aP,Org,Dir,1,aT);
  end;{TRay.GetPoint}
{TTexture}
  Constructor TTexture.Init;
  begin
   SizeX := sx;
   SizeY := sy;
   if (Sx*SY > 16384) then
    begin
      WriteLn('Too large texture');
      Halt(206);
    end;
   GetMem(Bits,SizeX*SizeY*3);
   FillChar(Bits^,SizeX*SizeY*3,0)
  end;
  Destructor  TTexture.Done;
  begin
    FreeMem(Bits,SizeX*SizeY*3);
  end;
  Procedure   TTexture.LoadTGA;
  var
   F  : FILE;
   CC : BRGB;
   nc : boolean;
   i,x,y  : word;
   tmp : longint;
  begin
   Name := FNAme;
   nc := false;
   Assign(F,Fname);
   {$I-}
     Reset(f,1);
   {$I+}
   if IOResult <> 0 then
    begin
     WriteLn('Texture file ',fname,' not found');
     Halt(201);
    end;
   BlockRead(F,TMP,4);
   if tmp <> $20000 then
    begin
     WriteLn('Texture file not TGA: ',fname);
     Close(F);
     Halt(202);
    end;
   for i := 1 to 2 do
    begin
     BlockRead(F,TMP,4);
     if (tmp <> 0) and (tmp<>$18000000) then
      begin
       WriteLn('Texture file not TGA: ',fname);
       Close(F);
       Halt(202);
      end;
    end;
   blockread(f,i,2); if i <> SizeX then nc := true; x := i;
   blockread(f,i,2); if i <> SizeY then nc := true; y := i;
   blockread(f,i,2);
   if i <> 24 then
    begin
     WriteLn('Texture file error bitplane: ',fname);
     Close(F);
     Halt(204);
    end;
   if NC then
    begin
     if (X*Y > 16384) then
      begin
        WriteLn('Too large texture: ',fname);
        Halt(206);
      end;
      FreeMem(Bits,SizeX*SizeY*3);
      GetMem(Bits,X*Y*3);
      FillChar(Bits^,SizeX*SizeY*3,0);
      SizeX:=X;
      SizeY:=Y;
    end;

   for y := SizeY-1 downto 0 do
     for x := 0 to SizeX-1 do
      begin
        BlockRead(F,CC,3);
        Bits^[y*SizeX+X] := CC;
      end;
   Close(F);
  end;
{RGB}
  Procedure SetColor;
  begin
   with aCol do begin R:=aR;G:=aG;B:=aB;end;
  end;{RGB.Init}
  Function Pack24;
  var
    rr,gg,bb : longint;
  begin
    if aCol.R > 1.0 then rr := 255 else rr:=round(aCol.R*255);
    if aCol.G > 1.0 then gg := 255 else gg:=round(aCol.G*255);
    if aCol.B > 1.0 then bb := 255 else bb:=round(aCol.B*255);
    Pack24:=(rr shl 16) + (gg shl 8) + bb;
  end;{RGB.Pack24}
Procedure LoadRGB(var F:FILE;var aCol:RGB);
begin
  BlockRead(F,aCol,sizeof(float)*3);
end;
Procedure SaveRGB(var F:FILE;aCol:RGB);
begin
  BlockWrite(F,aCol,sizeof(float)*3);
end;
Procedure CAddMul(var aC:RGB;aM:RGB; mul : float);
begin
  aC.R := aC.R + aM.R * mul;
  aC.G := aC.G + aM.G * mul;
  aC.B := aC.B + aM.B * mul;
end;

Procedure SetPlane(var P : TPLane; aV1, aV2, aV3:tVec);
var
   u,v : tVec;
begin
 VLinear(u,aV1,aV2,1,-1);
 VLinear(v,aV3,aV2,1,-1);
 VCross(P.N,u,v);
 VNorm(P.N,1);
 P.D := -VDot(P.N,aV1);
end;

Procedure CalcTransform;
var
 zed 	: TPLane;
 v2,v3  : tVec;
 tr2    : TTRANSFORM;
begin
 SetPlane(Zed,aV1,aV2,aV3);
 Compute_Coordinate_Transform(aT,aV1,Zed.N,r,len);
 MInvTransPoint(av1,av1,aT);
 MInvTransPoint(av2,av2,aT);
 VLinear(v2,aV2,aV1,1,-1);
 VNorm(v2,1);
 VSet(v3,0,0,1);
 Compute_Axis_Rotation_Transform(tr2,v3,-ArcCos(v2.X));
 Compose_Transforms(aT,tr2);
end; {CalcTransform}
{-----------------------}
end.