Board index » delphi » Delphi4: Textured Polygons for Delphi Source needs a fixing

Delphi4: Textured Polygons for Delphi Source needs a fixing

//
//  If anyone thinks they could fix this source so that is works and make a
small
//  demo, I would be very appreciative.  I've been messing with it for a
while.
//
//  I have been trying to convert some old DOS texture mappers into DELPHI
and
//  this is what I have done thus far.
//
//  Thanks in advance...
//  rottweiler

unit TexturePoly;

interface

Uses
  Windows, SysUtils, Graphics;

Type
  TPoly4 = Record
    case Integer of
      0 : (x1,y1,x2,y2,x3,y3,x4,y4: Integer);
      1 : (TopLeft, TopRight, BottomRight, BottomLeft: TPoint);
      2 : (Points : Array[0..3] of TPoint);
    end;

Procedure SwapIntegers(var A,B : Integer);
Procedure TexturePoly4(Poly4 : TPoly4; Source, Dest : TBitmap);

implementation

Function GetMaxInteger4(var A,B,C,D : Integer) : Integer;
var
  T : Integer;
Begin
  T := A;
  If B > T then T := B;  If C > T then T := C;  If D > T then T := D;
  Result := T;
End;

Function GetMinInteger4(var A,B,C,D : Integer) : Integer;
var
  T : Integer;
Begin
  T := A;
  If B < T then T := B;  If C < T then T := C;  If D < T then T := D;
  Result := T;
End;

Procedure SwapIntegers(var A,B : Integer);
var
  T : Integer;
Begin
  T := A;  A := B;  B := T;
End;

Type
  TE = Record X : Integer; px, py : Byte; End;
  Table = Array[0..512] of TE;
  PTable = ^Table;

Var
  Left, Right : Table;

Procedure TexturePoly4(Poly4 : TPoly4; Source, Dest : TBitmap);
//Procedure Texture4Poly(X1, Y1, X2, Y2, X3, Y3, X4, Y4 : Integer; Dim :
Byte);

Var
  yMin, yMax, xStart, xEnd, yStart, yEnd, pxStart, pxEnd : Integer;
  pyStart,pyEnd, pxVal, pxStep, pyVal, pyStep, Count : Integer;
  XVal, XStep : Longint;
  Side : PTable;

  Procedure DoSide(X1,Y1,X2,Y2, PX1,PY1,PX2,PY2 : Integer);
  var
    Count : Integer;
  Begin
    If Y1 = Y2 then Exit;    // --> Nothing worth drawing.
    If Y2 < Y1 then          // --> It is upside down.
      Begin
        SwapIntegers(Y1,Y2);
        SwapIntegers(X1,X2);
        SwapIntegers(PX1,PX2);
        SwapIntegers(PY1,PY2);
        Side := @Left
      End else Side := @Right;

    xStart := X1;  xEnd := X2;
    yStart := Y1;  yEnd := Y2;

    xStep  := (( X2- X1) shl 7) div (Y2-Y1);
    pxStep := ((PX2-PX1) shl 7) div (Y2-Y1);

    xVal   := X1 shl 7;      // all shl 7 is used to avoid using...
    pxVal  := PX1;           // real number division for speed.

    For Count := Y1 to Y2 do
      Begin
        Side^[Count].x  := xVal  shr 7;
        Side^[Count].px := pxVal shr 7;
        Side^[Count].py := pyVal shr 7;
        pxVal := pxVal + pxStep;
      End;
  End; { DoSide }

  Procedure HLine(X1,X2,PX1,PY1,PX2,PY2,Y : Integer);
  var
    Count : Word;
    P     : PByteArray;
  Begin
    pxStep := ((px2-px1) Shl 8) Div (x2-x1+1);
    // (px2-px1) is Source.bmWidth
    pyStep := ((py2-py1) Shl 8) Div (x2-x1+1);
    // (py2-py1) is Source.bmHeight
    pxVal := px1 Shl 8;
    pyVal := py1 Shl 8;
    // reason for all shl 8 is for rounding purposes using hi()
    P := Dest.Scanline[Y];
    // scanline[] is quicker then pixels[]
    for Count := X1 to X2 do
      Begin
        P[Count] := Source.Canvas.Pixels[hi(pxVal),hi(pyVal)];
        // using hi() instead of round(real) for speed
        pxVal := pxVal + pxStep;
        pyVal := pyVal + pyStep;
      End;
  End; { HLine }

Begin

  with Poly4 do yMin := GetMinInteger4(Y1,Y2,Y3,Y4);
  with Poly4 do yMax := GetMaxInteger4(Y1,Y2,Y3,Y4);

  If (yMin > Dest.Width) or (yMax < 0) then Exit;

  With poly4 do DoSide(X1,Y1,X2,Y2, 0,0,Source.Width,0);
  With poly4 do DoSide(X2,Y2,X3,Y3, Source.Width,0,
Source.Width,Source.Height);
  With poly4 do DoSide(X3,Y3,X4,Y4,
Source.Width,Source.Height,0,Source.Height);
  With poly4 do DoSide(X4,Y4,X1,Y1, 0,Source.Height,0,0);

  For Count := yMin to yMax do If Left[Count].x < Right[Count].x Then
    HLine(Left[Count].x, Right[Count].x, Left[Count].px, Left[Count].py,
      Right[Count].px, Right[Count].py, Count) Else
    HLine(Right[Count].x, Left[Count].x, Right[Count].px, Right[Count].py,
      Left[Count].px, Left[Count].py, Count);

End;

end.

 

Re:Delphi4: Textured Polygons for Delphi Source needs a fixing


Quote
>Procedure TexturePoly4(Poly4 : TPoly4; Source, Dest : TBitmap);

I kept getting errors about not being able to write to bitmaps that were not
initialized.  My short term goal is to have two images on the screen of any
size, then click on a button and have image2 being drawn into image1's box a
little crooked.  Image1 should conform to fit into the 4 points given by
Poly4 which doesn't have to be a rectangle.

Re:Delphi4: Textured Polygons for Delphi Source needs a fixing


Hy Steven.

You have to add a 'var' to the procedure declaration
 --> VAR dest:TBitmap!

patrick.

p.s.: if you can make it work properly, please send me a copy.

Steven J. Morales schrieb:

Quote

> >Procedure TexturePoly4(Poly4 : TPoly4; Source, Dest : TBitmap);

> I kept getting errors about not being able to write to bitmaps that were not
> initialized.  My short term goal is to have two images on the screen of any
> size, then click on a button and have image2 being drawn into image1's box a
> little crooked.  Image1 should conform to fit into the 4 points given by
> Poly4 which doesn't have to be a rectangle.

Re:Delphi4: Textured Polygons for Delphi Source needs a fixing


Hy Steven.

You have to add a 'var' to the procedure declaration
 --> VAR dest:TBitmap!

patrick.

p.s.: if you can make it work properly, please send me a copy.

Steven J. Morales schrieb:

Quote

> >Procedure TexturePoly4(Poly4 : TPoly4; Source, Dest : TBitmap);

> I kept getting errors about not being able to write to bitmaps that were not
> initialized.  My short term goal is to have two images on the screen of any
> size, then click on a button and have image2 being drawn into image1's box a
> little crooked.  Image1 should conform to fit into the 4 points given by
> Poly4 which doesn't have to be a rectangle.

Other Threads