Transparente Polygone zeichnen

[Namenloser]

Hier mal eine alte Routine von mir:

Delphi-Quellcode:

procedure FillPolygonAlpha(Vertices: TVertexList; Dest: TBitmap;
  Color: TColor);
type
  TIntegerArray = array of integer;
var
  x,y: integer;
  i,j: integer;
  PixelPtr: PColor;
  BasePixelPtr: PColor;
  ColorPartR, ColorPartG, ColorPartB, ColorA: Byte;
  Breakpoints: TIntegerArray;

  function GetBreakpoints(Row: integer; XOffset: integer): TIntegerArray;
  var
    Pt1, Pt2: TPoint;
    PtOld, PtNew: TPoint;
    Count: integer;
    i: integer;

    procedure QuickSort(var SortList: TIntegerArray; L, R: Integer);
    var
      I, J: Integer;
      P, T: Integer;
    begin
      repeat
        I := L;
        J := R;
        P := Sortlist[(L + R) div 2];
        repeat
          while SortList[i] < P do
            Inc(I);
          while SortList[j] > P do
            Dec(J);
          if I <= J then
          begin
            T := SortList[I];
            SortList[I] := SortList[J];
            SortList[J] := T;
            Inc(I);
            Dec(J);
          end;
        until I > J;
        if L < J then
          QuickSort(SortList, L, J);
        L := I;
      until I >= R;
    end;

  begin
    PtOld := Vertices.Last;
    Count := 0;
    SetLength(Result, Vertices.Count);
    for i := 0 to Vertices.Count - 1 do
    begin
      PtNew := Vertices[i];
      if PtNew.Y > PtOld.Y then
      begin
        Pt1 := PtOld;
        Pt2 := PtNew;
      end
      else
      begin
        Pt1 := PtNew;
        Pt2 := PtOld;
      end;
      if ((PtNew.Y < Row) = (Row <= PtOld.Y)) and
         ((XOffset-Pt1.X)*(Pt2.Y-Pt1.Y) < (Pt2.X-Pt1.X)*(Row-Pt1.Y)) then
      begin
        Result[Count] :=   trunc(Pt2.X * (Row-Pt1.y) / (Pt2.Y-Pt1.Y)
                             +   Pt1.X * (Pt2.Y-Row) / (Pt2.Y-Pt1.Y));
        inc(Count);
      end;
      PtOld := PtNew;
    end;
    SetLength(Result,Count);
    if length(Result)>=1 then
      Quicksort(Result,0,high(Result));
  end;
begin

  if Vertices.Count < 3 then exit;

  Dest.PixelFormat := pf32Bit;

  ColorA := Color shr 24;
  ColorPartR := Muldiv(GetRValue(Color), ColorA,255);
  ColorPartG := Muldiv(GetGValue(Color), ColorA,255);
  ColorPartB := Muldiv(GetBValue(Color), ColorA,255);
  
  for y := EnsureRange(Vertices.BoundingBox.Top, 0, Dest.Height-1) to
           EnsureRange(Vertices.BoundingBox.Bottom, 0, Dest.Height-1) do
  begin
    BasePixelPtr := Dest.ScanLine[y];
    x := Vertices.BoundingBox.Left;
    BreakPoints := GetBreakpoints(y,x-1);
    i := 0;
    while i <= high(Breakpoints) do
    begin
      PixelPtr := BasePixelPtr;
      inc(PixelPtr, EnsureRange(Breakpoints[i], 0, Dest.Width-1));
      for j := EnsureRange(Breakpoints[i], 0, Dest.Width) to
               EnsureRange(Breakpoints[i+1], 0, Dest.Width-1) do
      begin
        PixelPtr^ :=
          ColorPartR +
          Muldiv(PixelPtr^ and $00FF0000 shr 16,255-ColorA,255) shl 16 or

          ColorPartG +
          Muldiv(PixelPtr^ and $0000FF00 shr 8,255-ColorA,255) shl 8 or

          ColorPartB +
          Muldiv(PixelPtr^ and $000000FF,255-ColorA,255);
        inc(PixelPtr);
      end;
      inc(i,2);
    end;
  end;
end;

Wahrscheinlich nicht das allerschnellste (Polygone rendern ist sowieso eine Wissenschaft für sich), aber tut seinen Job.

TVertexList ist so deklariert:

Delphi-Quellcode:

  TVertexList = class
  public
    property Items[Index: integer]: TPoint read GetItem write SetItem; default;
    { ... }

    property BoundingBox: TRect read FBoundingBox;
  end;

Die Implementierung kann man sich denken. Wenn man keine Klasse dafür verwenden will, kann man die Routine natürlich auch leicht auf array of TPoint oder so anpassen, aber dazu bin ich jetzt zu faul. Man müsste aber nur drei, vier Stellen ändern.