gr32_polygons.pas

skin components for design of your applicastions

      // integrate the buffer
      N := 0;
      C := Color and $00FFFFFF;
      for I := 0 to BufferSize - 1 do
      begin
        Inc(N, Buffer[I]);
        ColorBuffer[I] := TColor32(N * AAMultiplier and $FF00) shl 16 or C;
      end;

      // draw it to the screen
      BlendLineEx(@ColorBuffer[0], Pointer(Bitmap.PixelPtr[MinX, Y]), BufferSize, A);
      EMMS;
    end;

    Inc(Y);
  end;
end;

procedure CustomFillLines(Bitmap: TBitmap32; BaseY: Integer;
  const ScanLines: TScanLines; FillLineCallback: TFillLineEvent; Mode: TPolyFillMode);
var
  I, J, L: Integer;
  Top, Left, Right, OldRight, LP, RP, Cx: Integer;
  Winding, NextWinding: Integer;
begin
  Top := BaseY - 1;
  Cx := Bitmap.ClipRect.Right - 1;

  if Mode = pfAlternate then
    for J := 0 to High(ScanLines) do
    begin
      Inc(Top);
      L := Length(ScanLines[J]); // assuming length is even
      if L = 0 then Continue;
      I := 0;
      OldRight := -1;

      while I < L do
      begin
        Left := ScanLines[J][I] and $7FFFFFFF;
        Inc(I);
        Right := ScanLines[J][I] and $7FFFFFFF - 1;
        if Right > Left then
        begin
          if (Left and $FF) < $80 then Left := Left shr 8
          else Left := Left shr 8 + 1;
          if (Right and $FF) < $80 then Right := Right shr 8
          else Right := Right shr 8 + 1;

          if Right >= Cx then Right := Cx;

          if Left <= OldRight then Left := OldRight + 1;
          OldRight := Right;
          if Right >= Left then
            FillLineCallback(Bitmap.PixelPtr[Left, Top], Left, Top, Right - Left, nil);
        end;
        Inc(I);
      end
    end
  else // Mode = pfWinding
    for J := 0 to High(ScanLines) do
    begin
      Inc(Top);
      L := Length(ScanLines[J]); // assuming length is even
      if L = 0 then Continue;
      I := 0;

      Winding := 0;
      Left := ScanLines[J][0];
      if (Left and $80000000) <> 0 then Inc(Winding) else Dec(Winding);
      Left := Left and $7FFFFFFF;
      Inc(I);
      while I < L do
      begin
        Right := ScanLines[J][I];
        if (Right and $80000000) <> 0 then NextWinding := 1 else NextWinding := -1;
        Right := Right and $7FFFFFFF;
        Inc(I);

        if Winding <> 0 then
        begin
          if (Left and $FF) < $80 then LP := Left shr 8
          else LP := Left shr 8 + 1;
          if (Right and $FF) < $80 then RP := Right shr 8
          else RP := Right shr 8 + 1;

          if RP >= Cx then RP := Cx;

          if RP >= LP then
            FillLineCallback(Bitmap.PixelPtr[LP, Top], LP, Top, RP - LP, nil);
        end;

        Inc(Winding, NextWinding);
        Left := Right;
      end;
    end;
  EMMS;
end;

procedure CustomFillLines2(Bitmap: TBitmap32; BaseY: Integer;
  const ScanLines: TScanLines; FillLineCallback: TFillLineEvent; Mode: TPolyFillMode;
  const AAMode: TAntialiasMode = DefaultAAMode);
var
  I, J, L, N: Integer;
  MinY, MaxY, Y, Top, Bottom: Integer;
  MinX, MaxX, X, Dx: Integer;
  Left, Right: Integer;
  Buffer: array of Integer;
  AlphaBuffer: array of TColor32;
  BufferSize: Integer;
  ScanLine: PIntegerArray;
  Winding, NextWinding: Integer;
  AAShift, AALines, AAMultiplier: Integer;
begin
  AAShift := AA_SHIFT[AAMode];
  AALines := AA_LINES[AAMode] - 1; // we do the -1 here for optimization.
  AAMultiplier := AA_MULTI[AAMode];

  // find the range of Y screen coordinates
  MinY := BaseY shr AAShift;
  MaxY := (BaseY + Length(ScanLines) + AALines) shr AAShift;

  Y := MinY;
  while Y < MaxY do
  begin
    Top := Y shl AAShift - BaseY;
    Bottom := Top + AALines;
    if Top < 0 then Top := 0;
    if Bottom >= Length(ScanLines) then Bottom := High(ScanLines);

    // find left and right edges of the screen scanline
    MinX := $7F000000; MaxX := -$7F000000;
    for J := Top to Bottom do
    begin
      L := Length(ScanLines[J]) - 1;
      if L > 0 then
      begin
        Left := (ScanLines[J][0] and $7FFFFFFF);
        Right := (ScanLines[J][L] and $7FFFFFFF + AALines);
        if Left < MinX then MinX := Left;
        if Right > MaxX then MaxX := Right;
      end
    end;

    if MaxX >= MinX then
    begin
      MinX := MinX shr AAShift;
      MaxX := MaxX shr AAShift;
      // allocate buffer for a single scanline
      BufferSize := MaxX - MinX + 2;
      if Length(Buffer) < BufferSize then
      begin
        SetLength(Buffer, BufferSize + 64);
        SetLength(AlphaBuffer, BufferSize + 64);
      end;
      FillLongword(Buffer[0], BufferSize, 0);

      // ...and fill it
      if Mode = pfAlternate then
        for J := Top to Bottom do
        begin
          I := 0;
          L := Length(ScanLines[J]);
          ScanLine := @ScanLines[J][0];
          while I < L do
          begin
            // Left edge
            X := ScanLine[I] and $7FFFFFFF;
            Dx := X and AALines;
            X := X shr AAShift - MinX;
            Inc(Buffer[X], Dx xor AALines);
            Inc(Buffer[X + 1], Dx);
            Inc(I);

            // Right edge
            X := ScanLine[I] and $7FFFFFFF;
            Dx := X and AALines;
            X := X shr AAShift - MinX;
            Dec(Buffer[X], Dx xor AALines);
            Dec(Buffer[X + 1], Dx);
            Inc(I);
          end
        end
      else // mode = pfWinding
        for J := Top to Bottom do
        begin
          I := 0;
          L := Length(ScanLines[J]);
          ScanLine := @ScanLines[J][0];
          Winding := 0;
          while I < L do
          begin
            X := ScanLine[I];
            Inc(I);
            if (X and $80000000) <> 0 then NextWinding := 1 else NextWinding := -1;
            X := X and $7FFFFFFF;
            if Winding = 0 then
            begin
              Dx := X and AALines;
              X := X shr AAShift - MinX;
              Inc(Buffer[X], Dx xor AALines);
              Inc(Buffer[X + 1], Dx);
            end;
            Inc(Winding, NextWinding);
            if Winding = 0 then
            begin
              Dx := X and AALines;
              X := X shr AAShift - MinX;
              Dec(Buffer[X], Dx xor AALines);
              Dec(Buffer[X + 1], Dx);
            end;
          end;
        end;

      // integrate the buffer
      N := 0;
      for I := 0 to BufferSize - 1 do
      begin
        Inc(N, Buffer[I]);
        AlphaBuffer[I] := (N * AAMultiplier) shr 8;
      end;

      // draw it to the screen
      FillLineCallback(Pointer(Bitmap.PixelPtr[MinX, Y]), MinX, Y, BufferSize, @AlphaBuffer[0]);
      EMMS;
    end;

    Inc(Y);
  end;
end;

{ Polygons }

// only used internally to share code:
procedure RenderPolygonTS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint;
  Color: TColor32; FillLineCallback: TFillLineEvent; Mode: TPolyFillMode;
  Transformation: TTransformation);
var
  L, I, MinY, MaxY: Integer;
  ScanLines: TScanLines;
  PP: TArrayOfPoint;
begin
  if not Bitmap.MeasuringMode then
  begin
    L := Length(Points);
    if (L < 3) or not Assigned(FillLineCallback) and (Color and $FF000000 = 0) then Exit;
    SetLength(PP, L);

    MinY := $7F000000;
    MaxY := -$7F000000;

    If Assigned(Transformation) then
    begin
      for I := 0 to L - 1 do
        with Transformation.Transform(Points[I]) do
        begin
          PP[I].X := SAR_16(X + $00007FFF);
          PP[I].Y := SAR_16(Y + $00007FFF);
          if PP[I].Y < MinY then MinY := PP[I].Y;
          if PP[I].Y > MaxY then MaxY := PP[I].Y;
        end;
    end
    else
    begin
      for I := 0 to L - 1 do
        with Points[I] do
        begin
          PP[I].X := SAR_16(X + $00007FFF);
          PP[I].Y := SAR_16(Y + $00007FFF);
          if PP[I].Y < MinY then MinY := PP[I].Y;
          if PP[I].Y > MaxY then MaxY := PP[I].Y;
        end;
    end;

    MinY := Constrain(MinY, Bitmap.ClipRect.Top, Bitmap.ClipRect.Bottom);
    MaxY := Constrain(MaxY, Bitmap.ClipRect.Top, Bitmap.ClipRect.Bottom);
    if MinY >= MaxY then Exit;

    SetLength(ScanLines, MaxY - MinY + 1);
    AddPolygon(PP, Bitmap.ClipRect.Left shl 8, MinY, Bitmap.ClipRect.Right shl 8 - 1,
      Bitmap.ClipRect.Bottom - 1, ScanLines, True);

    SortLines(ScanLines);
    Bitmap.BeginUpdate;
    try
      If Assigned(FillLineCallback) then
        CustomFillLines(Bitmap, MinY, ScanLines, FillLineCallback, Mode)
      else
        ColorFillLines(Bitmap, MinY, ScanLines, Color, Mode);
    finally
      Bitmap.EndUpdate;
    end;
  end;
  Bitmap.Changed(MakeRect(PolygonBounds(Points), rrOutside));
end;

procedure PolygonTS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint;
  Color: TColor32; Mode: TPolyFillMode; Transformation: TTransformation);
begin
  RenderPolygonTS(Bitmap, Points, Color, nil, Mode, Transformation);
end;

procedure PolygonTS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint;
  FillLineCallback: TFillLineEvent; Mode: TPolyFillMode;
  Transformation: TTransformation);
begin
  RenderPolygonTS(Bitmap, Points, 0, FillLineCallback, Mode, Transformation);
end;

procedure PolygonTS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint;
  Filler: TCustomPolygonFiller; Mode: TPolyFillMode;
  Transformation: TTransformation);
begin
  RenderPolygonTS(Bitmap, Points, 0, Filler.FillLine, Mode, Transformation);
end;

// only used internally to share code:
procedure RenderPolygonXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint;
  Color: TColor32; FillLineCallback: TFillLineEvent; Mode: TPolyFillMode;
  const AAMode: TAntialiasMode; Transformation: TTransformation);
var
  L, I, MinY, MaxY: Integer;
  ScanLines: TScanLines;
  PP: TArrayOfPoint;
  AAShift, AAClipTop, AAClipBottom: Integer;
  AASAR: TShiftFunc;
begin
  if not Bitmap.MeasuringMode then
  begin
    L := Length(Points);
    if (L < 3) or not Assigned(FillLineCallback) and (Color and $FF000000 = 0) then Exit;
    SetLength(PP, L);

    AASAR := AA_SAR[AAMode];

    MinY := $7F000000;
    MaxY := -$7F000000;

    If Assigned(Transformation) then
    begin
      for I := 0 to L - 1 do
        with Transformation.Transform(Points[I]) do
        begin
          PP[I].X := AASAR(X + $00007FF);
          PP[I].Y := AASAR(Y + $00007FF);
          if PP[I].Y < MinY then MinY := PP[I].Y;
          if PP[I].Y > MaxY then MaxY := PP[I].Y;
        end;
    end
    else
    begin
      for I := 0 to L - 1 do
        with Points[I] do
        begin
          PP[I].X := AASAR(X + $00007FF);
          PP[I].Y := AASAR(Y + $00007FF);
          if PP[I].Y < MinY then MinY := PP[I].Y;
          if PP[I].Y > MaxY then MaxY := PP[I].Y;
        end;
    end;

    AAShift := AA_SHIFT[AAMode];
    AAClipTop := Bitmap.ClipRect.Top shl AAShift;
    AAClipBottom := Bitmap.ClipRect.Bottom shl AAShift - 1;

    MinY := Constrain(MinY, AAClipTop, AAClipBottom);
    MaxY := Constrain(MaxY, AAClipTop, AAClipBottom);
    if MinY >= MaxY then Exit;

    SetLength(ScanLines, MaxY - MinY + 1);
    AddPolygon(PP, Bitmap.ClipRect.Left shl AAShift, MinY,
      Bitmap.ClipRect.Right shl AAShift - 1, AAClipBottom, ScanLines, False);

    SortLines(ScanLines);
    Bitmap.BeginUpdate;
    try
      If Assigned(FillLineCallback) then
        CustomFillLines2(Bitmap, MinY, ScanLines, FillLineCallback, Mode, AAMode)
      else
        ColorFillLines2(Bitmap, MinY, ScanLines, Color, Mode, AAMode);
    finally
      Bitmap.EndUpdate;
    end;
  end;
  Bitmap.Changed(MakeRect(PolygonBounds(Points), rrOutside));
end;

procedure PolygonXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint;
  Color: TColor32; Mode: TPolyFillMode;
  const AAMode: TAntialiasMode; Transformation: TTransformation);
begin
  RenderPolygonXS(Bitmap, Points, Color, nil, Mode, AAMode, Transformation);
end;

procedure PolygonXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint;
  FillLineCallback: TFillLineEvent; Mode: TPolyFillMode;
  const AAMode: TAntialiasMode; Transformation: TTransformation);
begin
  RenderPolygonXS(Bitmap, Points, 0, FillLineCallback, Mode, AAMode, Transformation);
end;

procedure PolygonXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint;
  Filler: TCustomPolygonFiller; Mode: TPolyFillMode;
  const AAMode: TAntialiasMode; Transformation: TTransformation);
begin
  RenderPolygonXS(Bitmap, Points, 0, Filler.FillLine, Mode, AAMode, Transformation);
end;

{ PolyPolygons }

// only used internally to share code:
procedure RenderPolyPolygonTS(Bitmap: TBitmap32;
  const Points: TArrayOfArrayOfFixedPoint; Color: TColor32;
  FillLineCallback: TFillLineEvent; Mode: TPolyFillMode;
  Transformation: TTransformation);
var
  L, I, J, MinY, MaxY, ShiftedLeft, ShiftedRight, ClipBottom: Integer;
  ScanLines: TScanLines;
  PP: TArrayOfArrayOfPoint;
begin
  if not Bitmap.MeasuringMode then
  begin
    SetLength(PP, Length(Points));