model3d.pas

很小的迷你３D引擎

        if (VisibleFaces[LFace].Curved) and // vertex luminance doesn't need to be calculated for flat faces
           (not Vertices[VisibleFaces[LFace].Corners[LVertex]].Visible) then begin
          Vertices[VisibleFaces[LFace].Corners[LVertex]].Visible := True;
          SetLength(LVisibleVertices, length(LVisibleVertices) + 1);
          LVisibleVertices[length(LVisibleVertices) - 1] := VisibleFaces[LFace].Corners[LVertex];
        end;
      end;
    end;
    // calculate the luminance of the visible vertices
    for LVertex := 0 to length(LVisibleVertices) - 1 do begin
      LIntensityRatio := DotProduct( Vertices[LVisibleVertices[LVertex]].Normal, SourceDirection );
      Vertices[LVisibleVertices[LVertex]].Lum := 60 + trunc( 130 * max(0,LIntensityRatio) );
    end;

    // draw faces in order of Z so that nearer faces are drawn last
    for LFace := 0 to length(VisibleFaces) - 1 do begin
      if VisibleFaces[LFace].Curved then GouraudFace(LFace)
                                    else FlatFace(LFace);
    end;

  except
    ShowMessage('Exception in RenderObject Method');
  end;
end;

// sort faces by Z for Z-buffering
procedure T3DModel.QuickSortFaces(var A: array of TFace; iLo, iHi: Integer);
Var
  Lo, Hi : Integer;
  Mid : Extended;
  T : TFace;
begin
  try

    Lo := iLo;
    Hi := iHi;
    Mid := A[(Lo + Hi) div 2].CenterZ;
    repeat
      while A[Lo].CenterZ < Mid do Inc(Lo);
      while A[Hi].CenterZ > 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 QuickSortFaces(A, iLo, Hi);
    if Lo < iHi then QuickSortFaces(A, Lo, iHi);

  except
    ShowMessage('Exception in QuickSortFaces Method');
  end;
end;

// render a face of an object with a given colour
procedure T3DModel.FlatFace(AFace : integer);
Var
  LPolygon : array of TPoint;
  LColor : TColor;
  LIntensityRatio : Extended;
  LVertex : byte;
begin
  try

    SetLength(LPolygon, length(VisibleFaces[AFace].Corners));

    LIntensityRatio := DotProduct(VisibleFaces[AFace].Normal, SourceDirection);

    VisibleFaces[AFace].HLS.L := 60 + trunc( 130 * max(0,LIntensityRatio) );
    //if HLS.L > 255 then HLS.L := 255;

    //LColor := (IHS.I shl 16) + (IHS.I shl 8) + IHS.I; // greyscale
    LColor := RGBToCol( HLStoRGB(VisibleFaces[AFace].HLS) );

    // create polygon array
    for LVertex := 0 to length(LPolygon) - 1 do begin
      LPolygon[LVertex].X := round( Vertices[ VisibleFaces[AFace].Corners[LVertex] ].Point.X );
      LPolygon[LVertex].Y := round( Vertices[ VisibleFaces[AFace].Corners[LVertex] ].Point.Y );
    end;

    // set face color
    OffScrBmp.Canvas.Pen.Color := LColor;
    OffScrBmp.Canvas.Brush.Color := LColor;

    // draw face
    OffScrBmp.Canvas.Polygon(LPolygon);

  except
    ShowMessage('Exception in FlatFace Method');
  end;
end;

// render the face of an object using Gouraud shading
procedure T3DModel.GouraudFace(AFace : integer);
Var
  LPolygon : TPointColorTriangle;
  LVertex : byte;
  LRGB : TRGBTriple;
begin
  try
    // first half of rectangle
    for LVertex := 0 to 2 do begin
      LPolygon[LVertex].X := round( Vertices[ VisibleFaces[AFace].Corners[LVertex] ].Point.X );
      LPolygon[LVertex].Y := round( Vertices[ VisibleFaces[AFace].Corners[LVertex] ].Point.Y );

      // set luminosity to the precalculated value for this corner vertex
      VisibleFaces[AFace].HLS.L := Vertices[VisibleFaces[AFace].Corners[LVertex]].Lum;

      LRGB := HLStoRGB( VisibleFaces[AFace].HLS );
      LPolygon[LVertex].RGB.R := LRGB.rgbtRed;
      LPolygon[LVertex].RGB.G := LRGB.rgbtGreen;
      LPolygon[LVertex].RGB.B := LRGB.rgbtBlue;
    end;

    GouraudPoly( OffScrBmp, LPolygon );

    // second half of rectangle - just replace the middle corner
    LPolygon[1].X := round( Vertices[ VisibleFaces[AFace].Corners[3] ].Point.X );
    LPolygon[1].Y := round( Vertices[ VisibleFaces[AFace].Corners[3] ].Point.Y );

    VisibleFaces[AFace].HLS.L := Vertices[VisibleFaces[AFace].Corners[3]].Lum;

    LRGB := HLStoRGB( VisibleFaces[AFace].HLS );
    LPolygon[1].RGB.R := LRGB.rgbtRed;
    LPolygon[1].RGB.G := LRGB.rgbtGreen;
    LPolygon[1].RGB.B := LRGB.rgbtBlue;

    GouraudPoly( OffScrBmp, LPolygon );

//    for LVertex := 0 to 3 do begin // debugging
//      OffScrBmp.Canvas.Pixels[round(Vertices[VisibleFaces[AFace].Corners[LVertex]].Point.X), round(Vertices[ VisibleFaces[AFace].Corners[LVertex] ].Point.Y)] := clyellow;
//    end;

  except
    ShowMessage('Exception in GouraudFace Method');
  end;
end;

// fill a traingular polygon using Gouraud shading
procedure T3DModel.GouraudPoly(var ABitmap : TBitmap ; V : TPointColorTriangle);
Var
  LX, RX, Ldx, Rdx : Single;
  Dif1, Dif2 : Single;
  LRGB, RRGB, RGB, RGBdx, LRGBdy, RRGBdy : TRGBFloat;
  RGBT : RGBTriple;                      
  Scan : PRGBTripleArray;
  y, x, Vmax : integer;
  Right : boolean;
  Temp : TPointColor;
begin
try

  // sort vertices by Y
  Vmax := 0;
  if V[1].Y > V[0].Y then Vmax := 1;
  if V[2].Y > V[Vmax].Y then Vmax := 2;
  if Vmax <> 2 then begin
    Temp := V[2];
    V[2] := V[Vmax];                     //           /\
    V[Vmax] := Temp;                     //          /  \ region 1
  end;                                   //         /____\
  if V[1].Y > V[0].Y then Vmax := 1      //        /    /
                     else Vmax := 0;     //       /   / region 2
  if Vmax = 0 then begin                 //      /  /
    Temp := V[1];                        //     / /
    V[1] := V[0];                        //    /
    V[0] := Temp;
  end;

  Dif1 := V[2].Y - V[0].Y;
  if Dif1 = 0 then Dif1 := 0.001; // prevent EZeroDivide
  Dif2 := V[1].Y - V[0].Y;
  if Dif2 = 0 then Dif2 := 0.001;

  { work out if middle point is to the left or right of the line
    connecting upper and lower points }
  if V[1].X > (V[2].X - V[0].X) * Dif2 / Dif1 + V[0].X then Right := True
                                                       else Right := False;

  // calculate increments in x and colour for stepping through the lines
  if Right then begin
    Ldx := (V[2].X - V[0].X) / Dif1;
    Rdx := (V[1].X - V[0].X) / Dif2;
    LRGBdy.B := (V[2].RGB.B - V[0].RGB.B) / Dif1;
    LRGBdy.G := (V[2].RGB.G - V[0].RGB.G) / Dif1;
    LRGBdy.R := (V[2].RGB.R - V[0].RGB.R) / Dif1;
    RRGBdy.B := (V[1].RGB.B - V[0].RGB.B) / Dif2;
    RRGBdy.G := (V[1].RGB.G - V[0].RGB.G) / Dif2;
    RRGBdy.R := (V[1].RGB.R - V[0].RGB.R) / Dif2;
  end else begin
    Ldx := (V[1].X - V[0].X) / Dif2;
    Rdx := (V[2].X - V[0].X) / Dif1;
    RRGBdy.B := (V[2].RGB.B - V[0].RGB.B) / Dif1;
    RRGBdy.G := (V[2].RGB.G - V[0].RGB.G) / Dif1;
    RRGBdy.R := (V[2].RGB.R - V[0].RGB.R) / Dif1;
    LRGBdy.B := (V[1].RGB.B - V[0].RGB.B) / Dif2;
    LRGBdy.G := (V[1].RGB.G - V[0].RGB.G) / Dif2;
    LRGBdy.R := (V[1].RGB.R - V[0].RGB.R) / Dif2;
  end;

  LRGB := V[0].RGB;
  RRGB := LRGB;

  LX := V[0].X;
  RX := V[0].X;

  // fill region 1
  for y := V[0].Y to V[1].Y do begin

    // y clipping
    if y > ABitmap.Height - 1 then Break;
    if y < 0 then begin
      LX := LX + Ldx;
      RX := RX + Rdx;
      LRGB.B := LRGB.B + LRGBdy.B;
      LRGB.G := LRGB.G + LRGBdy.G;
      LRGB.R := LRGB.R + LRGBdy.R;
      RRGB.B := RRGB.B + RRGBdy.B;
      RRGB.G := RRGB.G + RRGBdy.G;
      RRGB.R := RRGB.R + RRGBdy.R;
      Continue;
    end;

    Scan := ABitmap.ScanLine[y];

    // calculate increments in color for stepping through pixels
    Dif1 := RX - LX + 1;
    if Dif1 = 0 then Dif1 := 0.001;
    RGBdx.B := (RRGB.B - LRGB.B) / Dif1;
    RGBdx.G := (RRGB.G - LRGB.G) / Dif1;
    RGBdx.R := (RRGB.R - LRGB.R) / Dif1;

    // x clipping
    if LX < 0 then begin
      RGB.B := LRGB.B + (RGBdx.B * abs(LX));
      RGB.G := LRGB.G + (RGBdx.G * abs(LX));
      RGB.R := LRGB.R + (RGBdx.R * abs(LX));
    end else RGB := LRGB;

    // scan the line
    for x := max(round(LX), 0) to min(round(RX), ABitmap.Width - 1) do begin
      RGBT.rgbtBlue := trunc(RGB.B);
      RGBT.rgbtGreen := trunc(RGB.G);
      RGBT.rgbtRed := trunc(RGB.R);
      Scan[x] := RGBT;
      RGB.B := RGB.B + RGBdx.B;
      RGB.G := RGB.G + RGBdx.G;
      RGB.R := RGB.R + RGBdx.R;
    end;
    // increment edge x positions
    LX := LX + Ldx;
    RX := RX + Rdx;

    // increment edge colours by the y colour increments
    LRGB.B := LRGB.B + LRGBdy.B;
    LRGB.G := LRGB.G + LRGBdy.G;
    LRGB.R := LRGB.R + LRGBdy.R;
    RRGB.B := RRGB.B + RRGBdy.B;
    RRGB.G := RRGB.G + RRGBdy.G;
    RRGB.R := RRGB.R + RRGBdy.R;
  end;

  Dif1 := V[2].Y - V[1].Y;
  if Dif1 = 0 then Dif1 := 0.001;
  // calculate new increments for region 2
  if Right then begin
    Rdx := (V[2].X - V[1].X) / Dif1;
    RX := V[1].X;
    RRGBdy.B := (V[2].RGB.B - V[1].RGB.B) / Dif1;
    RRGBdy.G := (V[2].RGB.G - V[1].RGB.G) / Dif1;
    RRGBdy.R := (V[2].RGB.R - V[1].RGB.R) / Dif1;
    RRGB := V[1].RGB;
  end else begin
    Ldx := (V[2].X - V[1].X) / Dif1;
    LX := V[1].X;
    LRGBdy.B := (V[2].RGB.B - V[1].RGB.B) / Dif1;
    LRGBdy.G := (V[2].RGB.G - V[1].RGB.G) / Dif1;
    LRGBdy.R := (V[2].RGB.R - V[1].RGB.R) / Dif1;
    LRGB := V[1].RGB;
  end;

  // fill region 2
  for y := V[1].Y + 1 to V[2].Y do begin

    // y clipping
    if y > ABitmap.Height - 1 then Break;
    if y < 0 then begin
      LX := LX + Ldx;
      RX := RX + Rdx;
      LRGB.B := LRGB.B + LRGBdy.B;
      LRGB.G := LRGB.G + LRGBdy.G;
      LRGB.R := LRGB.R + LRGBdy.R;
      RRGB.B := RRGB.B + RRGBdy.B;
      RRGB.G := RRGB.G + RRGBdy.G;
      RRGB.R := RRGB.R + RRGBdy.R;
      Continue;
    end;

    Scan := ABitmap.ScanLine[y];

    Dif1 := RX - LX + 1;
    if Dif1 = 0 then Dif1 := 0.001;
    RGBdx.B := (RRGB.B - LRGB.B) / Dif1;
    RGBdx.G := (RRGB.G - LRGB.G) / Dif1;
    RGBdx.R := (RRGB.R - LRGB.R) / Dif1;

    // x clipping
    if LX < 0 then begin
      // calculate starting colour from x=0
      RGB.B := LRGB.B + (RGBdx.B * abs(LX));
      RGB.G := LRGB.G + (RGBdx.G * abs(LX));
      RGB.R := LRGB.R + (RGBdx.R * abs(LX));
    end else RGB := LRGB;

    // scan the line
    for x := max(round(LX), 0) to min(round(RX), ABitmap.Width - 1) do begin
      RGBT.rgbtBlue := trunc(RGB.B);
      RGBT.rgbtGreen := trunc(RGB.G);
      RGBT.rgbtRed := trunc(RGB.R);
      Scan[x] := RGBT;
      RGB.B := RGB.B + RGBdx.B;
      RGB.G := RGB.G + RGBdx.G;
      RGB.R := RGB.R + RGBdx.R;
    end;

    LX := LX + Ldx;
    RX := RX + Rdx;

    LRGB.B := LRGB.B + LRGBdy.B;
    LRGB.G := LRGB.G + LRGBdy.G;
    LRGB.R := LRGB.R + LRGBdy.R;
    RRGB.B := RRGB.B + RRGBdy.B;
    RRGB.G := RRGB.G + RRGBdy.G;
    RRGB.R := RRGB.R + RRGBdy.R;
  end;

except
  ShowMessage('Exception in GouraudPoly Method');
end;
end;

// vector handling routines

// calculates the unit vector normal to 2 vectors
function T3DModel.CrossProduct(AVector1, AVector2 : TPoint3D) : TPoint3D;
begin
  try

    Result.X := ((AVector1.Y * AVector2.Z) - (AVector1.Z * AVector2.Y));
    Result.Y := ((AVector1.Z * AVector2.X) - (AVector1.X * AVector2.Z));
    Result.Z := ((AVector1.X * AVector2.Y) - (AVector1.Y * AVector2.X));

  except
    ShowMessage('Exception in CrossProduct Method');
  end;
end;

// calculates the dot product of 2 vectors
function T3DModel.DotProduct(AVector1, AVector2 : TPoint3D) : Extended;
begin
  Result := (AVector1.X * AVector2.X) +
            (AVector1.Y * AVector2.Y) +
            (AVector1.Z * AVector2.Z);
end;

// reduces a vector to a unit vector
function T3DModel.UnitVector(AVector : TPoint3D) : TPoint3D;
Var
  Modulus : Extended;
begin
  try

    Modulus := Sqrt(Sqr(AVector.X)+Sqr(AVector.Y)+Sqr(AVector.Z));
    Result := Point3D(AVector.X/Modulus, AVector.Y/Modulus, AVector.Z/Modulus);

  except
    ShowMessage('Exception in UnitVector Method');
  end;
end;

// add two vectors together
function T3DModel.Add(AVec1, AVec2 : TPoint3D) : TPoint3D;
begin
  try

    Result := Point3D(AVec1.X + AVec2.X, AVec1.Y + AVec2.Y, AVec1.Z + AVec2.Z);

  except
    ShowMessage('Exception in Add Method');
  end;
end;

// subtract one vector from another
function T3DModel.Subtract(AVec1, AVec2 : TPoint3D) : TPoint3D;
begin
  try

    Result := Point3D(AVec1.X - AVec2.X, AVec1.Y - AVec2.Y, AVec1.Z - AVec2.Z);

  except
    ShowMessage('Exception in Subtract Method');
  end;
end;

// TPoint3D type-cast
function Point3D(AX, AY, AZ : Extended) : TPoint3D;
begin
  try

    Result.X := AX;
    Result.Y := AY;
    Result.Z := AZ;

  except
    ShowMessage('Exception in Point3D Method');
  end;
end;

end.