{ /*************************************************************************** RGBRoutines.pas ***************************************************************************/ ***************************************************************************** * * * See the file COPYING.modifiedLGPL, included in this distribution, * * for details about the copyright. * * * * This program is distributed in the hope that it will be useful, * * but WITHOUT ANY WARRANTY; without even the implied warranty of * * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * * * ***************************************************************************** Author: Tom Gregorovic (_tom_@centrum.cz) Abstract: This unit contains routines for manipulating rgb bitmaps (stretching, drawing on canvas...) and for drawing primitives (lines, ellipses...). } unit RGBRoutines; {$ifdef fpc} {$mode objfpc}{$H+} {$endif} interface uses SysUtils, Math, Forms, LCLIntf, LCLType, LCLProc, FPImage, IntfGraphics, Classes, {$IFDEF LCLwin32} RGBWinRoutines, {$ENDIF} {$IFDEF LCLqt} RGBQtRoutines, {$ENDIF} {$IFDEF LCLgtk} {$DEFINE StretchRGB32} RGBGTKRoutines, {$ENDIF} {$IFDEF LCLgtk2} {$DEFINE StretchRGB32} RGBGTKRoutines, {$ENDIF} {$IFDEF LCLcarbon} {$DEFINE StretchRGB32} RGBCarbonRoutines, {$ENDIF} RGBTypes, RGBUtils; procedure DrawRGB32Bitmap(Dst: TRGB32BitmapCore; X, Y: Integer; Src: TRGB32BitmapCore); overload; procedure DrawRGB8Bitmap(Dst: TRGB8BitmapCore; X, Y: Integer; Src: TRGB8BitmapCore); overload; procedure StretchRGB32BitmapTrunc(Dst, Src: TRGB32BitmapCore); procedure StretchRGB8BitmapTrunc(Dst, Src: TRGB8BitmapCore); procedure DrawRGB32Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth, SrcHeight: Integer; Bitmap: TRGB32BitmapCore); overload; procedure StretchDrawRGB32Bitmap(Dest: HDC; DstX, DstY, DstWidth, DstHeight: Integer; SrcX, SrcY, SrcWidth, SrcHeight: Integer; Bitmap: TRGB32BitmapCore); overload; procedure StretchDrawRGBMaskShapePortion(Dest: HDC; DstX, DstY, DstWidth, DstHeight: Integer; Bitmap: TRGB8BitmapCore; DX, DY, DW, DH: Integer; BgPen: HPEN; FgPen: HPEN); procedure DrawRGB8Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth, SrcHeight: Integer; Bitmap: TRGB8BitmapCore); overload; type TDrawPixelProcedure = procedure (X, Y: Integer) of Object; TGetPixelFunction = function (X, Y: Integer): TRGB32Pixel of Object; TSamePixelFunction = function (X, Y: Integer; Value: TRGB32Pixel): Boolean of Object; procedure LineBresenham(X1, Y1, X2, Y2: Integer; DrawPixel: TDrawPixelProcedure); procedure FillPixelRect(X1, Y1, X2, Y2: Integer; DrawPixel: TDrawPixelProcedure); procedure NormalRectangle(X1, Y1, X2, Y2: Integer; DrawOutlinePixel, DrawFillPixel: TDrawPixelProcedure); procedure EllipticRectangle(X1, Y1, X2, Y2: Integer; LX, LY: Integer; DrawOutlinePixel, DrawFillPixel: TDrawPixelProcedure); procedure FloodFillScanLine(X, Y, W, H: Integer; GetPixel: TGetPixelFunction; SamePixel: TSamePixelFunction; DrawPixel: TDrawPixelProcedure); implementation function GetDCClipRect(Dest: HDC): TRect; begin if GetClipBox(Dest, @Result) = ERROR then begin Result.TopLeft := Point(0, 0); if not GetDeviceSize(Dest, Result.BottomRight) then Result.BottomRight := Point(8000, 8000); end; end; procedure DrawRGB32Bitmap(Dst: TRGB32BitmapCore; X, Y: Integer; Src: TRGB32BitmapCore); var SrcX, SrcWidth, SrcY, SrcHeight: Integer; I: Integer; PS, PD: PRGB32Pixel; begin if (Dst = nil) or (Src = nil) then Exit; if (Dst.Width <= 0) or (Dst.Height <= 0) or (Src.Width <= 0) or (Src.Height <= 0) then Exit; if (X >= Dst.Width) or (Y >= Dst.Height) then Exit; if (X + Src.Width <= 0) or (Y + Src.Height <= 0) then Exit; SrcX := 0; SrcY := 0; SrcWidth := Src.Width; SrcHeight := Src.Height; if X < 0 then begin SrcX := -X; Inc(SrcWidth, X); X := 0; end; if Y < 0 then begin SrcY := -Y; Inc(SrcHeight, Y); Y := 0; end; if X + SrcWidth > Dst.Width then Dec(SrcWidth, X + SrcWidth - Dst.Width); if Y + SrcHeight > Dst.Height then Dec(SrcHeight, Y + SrcHeight - Dst.Height); for I := 0 to Pred(SrcHeight) do begin PS := Src.Get32PixelPtrUnsafe(SrcX, SrcY + I); PD := Dst.Get32PixelPtrUnsafe(X, Y + I); Move(PS^, PD^, SrcWidth shl 2); end; end; procedure DrawRGB8Bitmap(Dst: TRGB8BitmapCore; X, Y: Integer; Src: TRGB8BitmapCore); var SrcX, SrcWidth, SrcY, SrcHeight: Integer; I: Integer; PS, PD: PRGB8Pixel; begin if (Dst = nil) or (Src = nil) then Exit; if (Dst.Width <= 0) or (Dst.Height <= 0) or (Src.Width <= 0) or (Src.Height <= 0) then Exit; if (X >= Dst.Width) or (Y >= Dst.Height) then Exit; if (X + Src.Width <= 0) or (Y + Src.Height <= 0) then Exit; SrcX := 0; SrcY := 0; SrcWidth := Src.Width; SrcHeight := Src.Height; if X < 0 then begin SrcX := -X; Inc(SrcWidth, X); X := 0; end; if Y < 0 then begin SrcY := -Y; Inc(SrcHeight, Y); Y := 0; end; if X + SrcWidth > Dst.Width then Dec(SrcWidth, X + SrcWidth - Dst.Width); if Y + SrcHeight > Dst.Height then Dec(SrcHeight, Y + SrcHeight - Dst.Height); for I := 0 to Pred(SrcHeight) do begin PS := Src.Get8PixelPtrUnsafe(SrcX, SrcY + I); PD := Dst.Get8PixelPtrUnsafe(X, Y + I); Move(PS^, PD^, SrcWidth); end; end; procedure StretchRGB32BitmapTrunc(Dst, Src: TRGB32BitmapCore); var Cols: TIntArray; Rows: TIntArray; X, Y, PX, TX, OX, PY, TY, OY: Integer; I: Integer; PD, PS, PDLine, PSLine: PRGB32Pixel; DstDataWidth, DstDataHeight: Integer; SrcDataWidth, SrcDataHeight: Integer; SrcRowPixelStride, DstRowPixelStride: Integer; begin DstDataWidth := Dst.Width; DstDataHeight := Dst.Height; SrcDataWidth := Src.Width; SrcDataHeight := Src.Height; SrcRowPixelStride := Src.RowPixelStride; DstRowPixelStride := Dst.RowPixelStride; Cols := DivideTrunc(SrcDataWidth, DstDataWidth); Rows := DivideTrunc(SrcDataHeight, DstDataHeight); if DstDataWidth <= SrcDataWidth then begin PX := 0; OX := 0; for X := 0 to High(Cols) do begin TX := Cols[X]; Cols[X] := (PX + TX shr 1) - OX; OX := (PX + TX shr 1); Inc(PX, TX); end; end; if DstDataHeight <= SrcDataHeight then begin PY := 0; OY := 0; for Y := 0 to High(Rows) do begin TY := Rows[Y]; Rows[Y] := (PY + Rows[Y] shr 1) - OY; OY := (PY + TY shr 1); Inc(PY, TY); end; end; PD := PRGB32Pixel(Dst.Pixels); PS := PRGB32Pixel(Src.Pixels); for Y := 0 to High(Rows) do begin if DstDataHeight <= SrcDataHeight then begin Inc(PS, Rows[Y] * SrcRowPixelStride); end; PDLine := PD; PSLine := PS; if DstDataWidth > SrcDataWidth then begin for X := 0 to High(Cols) do begin if Cols[X] = 1 then begin PDLine^ := PSLine^; Inc(PDLine); end else begin FillDWord(PDLine^, Cols[X], PSLine^); Inc(PDLine, Cols[X]); end; Inc(PSLine); end; end else begin for X := 0 to High(Cols) do begin Inc(PSLine, Cols[X]); PDLine^ := PSLine^; Inc(PDLine); end; end; if DstDataHeight > SrcDataHeight then begin PDLine := PD; Inc(PD, DstRowPixelStride); for I := 2 to Rows[Y] do begin Move(PDLine^, PD^, DstDataWidth shl 2); Inc(PD, DstRowPixelStride); end; Inc(PS, SrcRowPixelStride); end else begin Inc(PD, DstRowPixelStride); end; end; end; procedure StretchRGB8BitmapTrunc(Dst, Src: TRGB8BitmapCore); var Cols: TIntArray; Rows: TIntArray; X, Y, PX, TX, OX, PY, TY, OY: Integer; I: Integer; PD, PS, PDLine, PSLine: PRGB8Pixel; DstDataWidth, DstDataHeight: Integer; SrcDataWidth, SrcDataHeight: Integer; SrcRowPixelStride, DstRowPixelStride: Integer; begin DstDataWidth := Dst.Width; DstDataHeight := Dst.Height; SrcDataWidth := Src.Width; SrcDataHeight := Src.Height; SrcRowPixelStride := Src.RowPixelStride; DstRowPixelStride := Dst.RowPixelStride; Cols := DivideTrunc(SrcDataWidth, DstDataWidth); Rows := DivideTrunc(SrcDataHeight, DstDataHeight); if DstDataWidth <= SrcDataWidth then begin PX := 0; OX := 0; for X := 0 to High(Cols) do begin TX := Cols[X]; Cols[X] := (PX + TX shr 1) - OX; OX := (PX + TX shr 1); Inc(PX, TX); end; end; if DstDataHeight <= SrcDataHeight then begin PY := 0; OY := 0; for Y := 0 to High(Rows) do begin TY := Rows[Y]; Rows[Y] := (PY + Rows[Y] shr 1) - OY; OY := (PY + TY shr 1); Inc(PY, TY); end; end; PD := PRGB8Pixel(Dst.Pixels); PS := PRGB8Pixel(Src.Pixels); for Y := 0 to High(Rows) do begin if DstDataHeight <= SrcDataHeight then begin Inc(PS, Rows[Y] * SrcRowPixelStride); end; PDLine := PD; PSLine := PS; if DstDataWidth > SrcDataWidth then begin for X := 0 to High(Cols) do begin if Cols[X] = 1 then begin PDLine^ := PSLine^; Inc(PDLine); end else begin FillByte(PDLine^, Cols[X], PSLine^); Inc(PDLine, Cols[X]); end; Inc(PSLine); end; end else begin for X := 0 to High(Cols) do begin Inc(PSLine, Cols[X]); PDLine^ := PSLine^; Inc(PDLine); end; end; if DstDataHeight > SrcDataHeight then begin PDLine := PD; Inc(PD, DstRowPixelStride); for I := 2 to Rows[Y] do begin Move(PDLine^, PD^, DstDataWidth); Inc(PD, DstRowPixelStride); end; Inc(PS, SrcRowPixelStride); end else begin Inc(PD, DstRowPixelStride); end; end; end; procedure StretchRGB32BitmapTrunc(Dst: TRGB32BitmapCore; DstX, DstY, DstWidth, DstHeight: Integer; SrcX, SrcY, SrcWidth, SrcHeight: Integer; Src: TRGB32BitmapCore); var Cols: TIntArray; Rows: TIntArray; X, Y: Integer; SX, SY, DX, DY: Integer; I, J, C: Integer; PD, PS, PDLine, PSLine: PRGB32Pixel; DstDataWidth, DstDataHeight: Integer; SrcDataWidth, SrcDataHeight: Integer; SrcRowPixelStride, DstRowPixelStride: Integer; begin DstDataWidth := Dst.Width; DstDataHeight := Dst.Height; SrcDataWidth := Src.Width; SrcDataHeight := Src.Height; SrcRowPixelStride := Src.RowPixelStride; DstRowPixelStride := Dst.RowPixelStride; Cols := DivideTrunc(SrcWidth, DstWidth); Rows := DivideTrunc(SrcHeight, DstHeight); if DstWidth <= SrcWidth then Cols := GetDifference(GetMidPoints(Cols)); if DstHeight <= SrcHeight then Rows := GetDifference(GetMidPoints(Rows)); PD := Dst.Get32PixelPtrUnsafe(DstX, DstY); PS := Src.Get32PixelPtrUnsafe(SrcX, SrcY); DY := DstY; SY := SrcY; for Y := 0 to High(Rows) do begin if DstHeight <= SrcHeight then begin Inc(PS, Rows[Y] * SrcRowPixelStride); Inc(SY, Rows[Y]); end; if DstHeight > SrcHeight then C := Rows[Y] else C := 1; for I := 1 to C do begin DX := DstX; SX := SrcX; PDLine := PD; PSLine := PS; if (SY >= 0) and (SY < SrcDataHeight) and (DY >= 0) and (DY < DstDataHeight) then begin if (DstWidth > SrcWidth) then begin for X := 0 to High(Cols) do begin if Cols[X] = 1 then begin if (SX >= 0) and (SX < SrcDataWidth) and (DX >= 0) and (DX < DstDataWidth) then PDLine^ := PSLine^; Inc(PDLine); Inc(DX); end else begin if (SX >= 0) and (SX < SrcDataWidth) then begin if (DX + Cols[X] <= 0) or (DX >= DstDataWidth) then begin Inc(PDLine, Cols[X]); Inc(DX, Cols[X]); end else for J := 1 to Cols[X] do begin if (DX >= 0) and (DX < DstDataWidth) then PDLine^ := PSLine^; Inc(PDLine); Inc(DX); end; end else begin Inc(PDLine, Cols[X]); Inc(DX, Cols[X]); end; end; Inc(PSLine); Inc(SX); end; end else begin for X := 0 to High(Cols) do begin Inc(PSLine, Cols[X]); Inc(SX, Cols[X]); if (SX >= 0) and (SX < SrcDataWidth) and (DX >= 0) and (DX < DstDataWidth) then PDLine^ := PSLine^; Inc(PDLine); Inc(DX); end; end; end; if DstHeight > SrcHeight then begin Inc(PD, DstRowPixelStride); Inc(DY); end; end; if DstHeight > SrcHeight then begin Inc(PS, SrcRowPixelStride); Inc(SY); end else begin Inc(PD, DstRowPixelStride); Inc(DY); end; end; end; // ! SrcX < 0, SrcY < 0, SrcX + SrcWidth > Bitmap.Width, SrcY + SrcHeight > Bitmap.Height // ! results in mash procedure DrawRGB32Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth, SrcHeight: Integer; Bitmap: TRGB32BitmapCore); var Clip: TRect; begin if (Bitmap = nil) or (Bitmap.Pixels = nil) then Exit; if (Bitmap.Width <= 0) or (Bitmap.Height <= 0) then Exit; if (SrcWidth <= 0) or (SrcHeight <= 0) then Exit; Clip := GetDCClipRect(Dest); if (DstX >= Clip.Right) or (DstY >= Clip.Bottom) or (DstX + SrcWidth < Clip.Left) or (DstY + SrcHeight < Clip.Top) then Exit; // clipping: ClipDimension(Clip.Left, Clip.Right, DstX, SrcX, SrcWidth); ClipDimension(Clip.Top, Clip.Bottom, DstY, SrcY, SrcHeight); WidgetSetDrawRGB32Bitmap(Dest, DstX, DstY, SrcX, SrcY, SrcWidth, SrcHeight, Bitmap); end; // ! SrcX < 0, SrcY < 0, SrcX + SrcWidth > Bitmap.Width, SrcY + SrcHeight > Bitmap.Height // ! results in mash procedure StretchDrawRGB32Bitmap(Dest: HDC; DstX, DstY, DstWidth, DstHeight: Integer; SrcX, SrcY, SrcWidth, SrcHeight: Integer; Bitmap: TRGB32BitmapCore); var Clip: TRect; {$IFDEF StretchRGB32} Temp: TRGB32BitmapCore; X, Y, W, H: Integer; {$ENDIF} begin if (Bitmap = nil) or (Bitmap.Pixels = nil) then Exit; if (Bitmap.Width <= 0) or (Bitmap.Height <= 0) then Exit; if (SrcWidth <= 0) or (SrcHeight <= 0) then Exit; if (DstWidth <= 0) or (DstHeight <= 0) then Exit; Clip := GetDCClipRect(Dest); if (DstX >= Clip.Right) or (DstY >= Clip.Bottom) or (DstX + DstWidth < Clip.Left) or (DstY + DstHeight < Clip.Top) then Exit; if (DstWidth = SrcWidth) and (DstHeight = SrcHeight) then begin DrawRGB32Bitmap(Dest, DstX, DstY, SrcX, SrcY, SrcWidth, SrcHeight, Bitmap); Exit; end; {$IFDEF StretchRGB32} X := Max(Clip.Left, DstX); Y := Max(Clip.Top, DstY); W := Min(Clip.Right, DstX + DstWidth) - X; H := Min(Clip.Bottom, DstY + DstHeight) - Y; Temp := TRGB32BitmapCore.Create(W, H); try StretchRGB32BitmapTrunc(Temp, DstX - X, DstY - Y, DstWidth, DstHeight, SrcX, SrcY, SrcWidth, SrcHeight, Bitmap); DrawRGB32Bitmap(Dest, X, Y, 0, 0, W, H, Temp); finally Temp.Free; end; {$ELSE} WidgetSetStretchDrawRGB32Bitmap(Dest, DstX, DstY, DstWidth, DstHeight, SrcX, SrcY, SrcWidth, SrcHeight, Bitmap); {$ENDIF} end; procedure StretchDrawRGBMaskShapePortion(Dest: HDC; DstX, DstY, DstWidth, DstHeight: Integer; Bitmap: TRGB8BitmapCore; DX, DY, DW, DH: Integer; BgPen: HPEN; FgPen: HPEN); var ZoomX, ZoomY: Single; Clip: TRect; procedure DrawMask(SX, SY, EX, EY: Integer); var X, Y: Integer; P: PRGB8Pixel; V1, V2: TRGB8Pixel; A, B, C: Integer; Temp: HGDIOBJ; begin if EX >= Bitmap.Width then EX := Pred(Bitmap.Width); if EY >= Bitmap.Height then EY := Pred(Bitmap.Height); Temp := SelectObject(Dest, BgPen); try for Y := SY to EY do begin if Pred(SX) >= 0 then V2 := Bitmap.Get8PixelPtr(Pred(SX), Y)^ else V2 := 0; P := Bitmap.Get8PixelPtr(SX, Y); for X := Pred(SX) to EX do begin V1 := V2; if X < Pred(Bitmap.Width) then V2 := P^ else V2 := 0; if (V1 = $FF) and (V2 <> $FF) then begin A := DstX + Round(Succ(X) * ZoomX); B := DstY + Round(Y * ZoomY); C := DstY + Round(Succ(Y) * ZoomY); if ((X + Y) and $1) > 0 then begin SelectObject(Dest, BgPen); MoveToEx(Dest, A, B, nil); LineTo(Dest, A, C); end else begin SelectObject(Dest, FgPen); MoveToEx(Dest, A, B, nil); LineTo(Dest, A, C); end; end else if (V1 <> $FF) and (V2 = $FF) then begin A := DstX + Round(Succ(X) * ZoomX); B := DstY + Round(Y * ZoomY); C := DstY + Round(Succ(Y) * ZoomY); if ((X + Y) and $1) > 0 then begin SelectObject(Dest, BgPen); MoveToEx(Dest, A - 1, B, nil); LineTo(Dest, A - 1, C); end else begin SelectObject(Dest, FgPen); MoveToEx(Dest, A - 1, B, nil); LineTo(Dest, A - 1, C); end; end; Inc(P); end; end; for X := SX to EX do begin if Pred(SY) >= 0 then V2 := Bitmap.Get8PixelPtr(X, Pred(SY))^ else V2 := 0; P := Bitmap.Get8PixelPtr(X, SY); for Y := Pred(SY) to EY do begin V1 := V2; if Y < Pred(Bitmap.Height) then V2 := P^ else V2 := 0; if (V1 = $FF) and (V2 <> $FF) then begin A := DstX + Round(X * ZoomX); B := DstX + Round(Succ(X) * ZoomX); C := DstY + Round(Succ(Y) * ZoomY); if ((X + Y) and $1) > 0 then begin SelectObject(Dest, BgPen); MoveToEx(Dest, A, C, nil); LineTo(Dest, B, C); end else begin SelectObject(Dest, FgPen); MoveToEx(Dest, A, C, nil); LineTo(Dest, B, C); end; end else if (V1 <> $FF) and (V2 = $FF) then begin A := DstX + Round(X * ZoomX); B := DstX + Round(Succ(X) * ZoomX); C := DstY + Round(Succ(Y) * ZoomY); if ((X + Y) and $1) > 0 then begin SelectObject(Dest, BgPen); MoveToEx(Dest, A, C - 1, nil); LineTo(Dest, B, C - 1); end else begin SelectObject(Dest, FgPen); MoveToEx(Dest, A, C - 1, nil); LineTo(Dest, B, C - 1); end; end; Inc(P, Bitmap.RowPixelStride); end; end; finally SelectObject(Dest, Temp); end; end; begin if (Bitmap = nil) or (Bitmap.Pixels = nil) then Exit; if (Bitmap.Width <= 0) or (Bitmap.Height <= 0) then Exit; if (DstWidth <= 0) or (DstHeight <= 0) then Exit; Clip := GetDCClipRect(Dest); ZoomX := DstWidth / Bitmap.Width; ZoomY := DstHeight / Bitmap.Height; if (Floor(DstX + DX * ZoomX) >= Clip.Right) or (Floor(DstY + DY * ZoomY) >= Clip.Bottom) or (Ceil(DstX + (DX + DW) * ZoomX) < Clip.Left) or (Ceil(DstY + (DY + DH) * ZoomY) < Clip.Top) then Exit; DrawMask(DX, DY, Pred(DX + DW), Pred(DY + DH)); end; // ! SrcX < 0, SrcY < 0, SrcX + SrcWidth > Bitmap.Width, SrcY + SrcHeight > Bitmap.Height // ! results in mash procedure DrawRGB8Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth, SrcHeight: Integer; Bitmap: TRGB8BitmapCore); var Clip: TRect; begin if (Bitmap = nil) or (Bitmap.Pixels = nil) then Exit; if (Bitmap.Width <= 0) or (Bitmap.Height <= 0) then Exit; if (SrcWidth <= 0) or (SrcHeight <= 0) then Exit; Clip := GetDCClipRect(Dest); if (DstX >= Clip.Right) or (DstY >= Clip.Bottom) or (DstX + SrcWidth < Clip.Left) or (DstY + SrcHeight < Clip.Top) then Exit; // clipping: ClipDimension(Clip.Left, Clip.Right, DstX, SrcX, SrcWidth); ClipDimension(Clip.Top, Clip.Bottom, DstY, SrcY, SrcHeight); WidgetSetDrawRGB8Bitmap(Dest, DstX, DstY, SrcX, SrcY, SrcWidth, SrcHeight, Bitmap); end; (* LineBresenham - standard Bresenham's line plotting algorithm Note: Result depends on order of points. *) procedure LineBresenham(X1, Y1, X2, Y2: Integer; DrawPixel: TDrawPixelProcedure); var Y, X: Integer; DX, DY, SX, SY, E: Integer; begin DrawPixel(X1, Y1); if (Y1 = Y2) and (X1 = X2) then Exit; DX := X2 - X1; DY := Y2 - Y1; if DX < 0 then begin SX := -1; DX := -DX; end else SX := 1; if DY < 0 then begin SY := -1; DY := -DY; end else SY := 1; DX := DX shl 1; DY := DY shl 1; X := X1; Y := Y1; if DX > DY then begin E := DY - DX shr 1; while X <> X2 do begin if E >= 0 then begin Inc(Y, SY); Dec(E, DX); end; Inc(X, SX); Inc(E, DY); DrawPixel(X, Y); end; end else begin E := DX - DY shr 1; while Y <> Y2 do begin if E >= 0 then begin Inc(X, SX); Dec(E, DY); end; Inc(Y, SY); Inc(E, DX); DrawPixel(X, Y); end; end; end; procedure FillPixelRect(X1, Y1, X2, Y2: Integer; DrawPixel: TDrawPixelProcedure); var X, Y: Integer; begin SortRect(X1, Y1, X2, Y2); for Y := Y1 to Y2 do for X := X1 to X2 do DrawPixel(X, Y); end; procedure FillPixelRow(X1, X2, Y: Integer; DrawPixel: TDrawPixelProcedure); inline; var X: Integer; begin MinMax(X1, X2); for X := X1 to X2 do DrawPixel(X, Y); end; procedure NormalRectangle(X1, Y1, X2, Y2: Integer; DrawOutlinePixel, DrawFillPixel: TDrawPixelProcedure); var X, Y: Integer; begin SortRect(X1, Y1, X2, Y2); for X := X1 to X2 do DrawOutlinePixel(X, Y1); if Y1 < Y2 then for X := X1 to X2 do DrawOutlinePixel(X, Y2); for Y := Succ(Y1) to Pred(Y2) do begin DrawOutlinePixel(X1, Y); if X1 < X2 then DrawOutlinePixel(X2, Y); for X := Succ(X1) to Pred(X2) do DrawFillPixel(X, Y); end; end; (* EllipticRectangle - accurate elliptic rectangle plotting algorithm LX, LY - length of straight section of elliptic rectangle If both LX and LY are set to 0, the result is ellipse. *) procedure EllipticRectangle(X1, Y1, X2, Y2: Integer; LX, LY: Integer; DrawOutlinePixel, DrawFillPixel: TDrawPixelProcedure); var CX, CY, CX1, CY1, A, B, NX, NY: Single; X, Y, EX, EY: Integer; LX1, LY1: Integer; LX2, LY2: Integer; DivSqrA, DivSqrB: Single; I, J, S: Integer; EdgeList: Array of TPoint; procedure AddEdge(X, Y: Integer); begin if (EdgeList[Y].X = -1) or (X < EdgeList[Y].X) then EdgeList[Y].X := X; if (EdgeList[Y].Y = -1) or (X > EdgeList[Y].Y) then EdgeList[Y].Y := X; end; begin if (X1 = X2) and (Y1 = Y2) then begin DrawOutlinePixel(X1, Y1); Exit; end; SortRect(X1, Y1, X2, Y2); if (X2 - X1 = 1) or (Y2 - Y1 = 1) then begin FillPixelRect(X1, Y1, X2, Y2, DrawOutlinePixel); Exit; end; if (LX > X2 - X1) or (LY > Y2 - Y1) then begin NormalRectangle(X1, Y1, X2, Y2, DrawOutlinePixel, DrawFillPixel); Exit; end; SetLength(EdgeList, Ceil((Y2 - Y1 + 1) / 2)); for I := 0 to Pred(High(EdgeList)) do EdgeList[I] := Point(-1, -1); EdgeList[High(EdgeList)] := Point(0, 0); A := (X2 - X1 + 1 - LX) / 2; B := (Y2 - Y1 + 1 - LY) / 2; CX := (X2 + X1 + 1) / 2; CY := (Y2 + Y1 + 1) / 2; CX1 := X2 + 1 - A - Floor(CX); CY1 := Y2 + 1 - B - Floor(CY); EX := Floor(Sqr(A) / Sqrt(Sqr(A) + Sqr(B)) + Frac(A)); EY := Floor(Sqr(B) / Sqrt(Sqr(A) + Sqr(B)) + Frac(B)); DivSqrA := 1 / Sqr(A); DivSqrB := 1 / Sqr(B); NY := B; AddEdge(Floor(CX1), Round(CY1 + B) - 1); for X := 1 to Pred(EX) do begin NY := B * Sqrt(1 - Sqr(X + 0.5 - Frac(A)) * DivSqrA); AddEdge(Floor(CX1) + X, Round(CY1 + NY) - 1); end; LX1 := Floor(CX1) + Pred(EX); LY1 := Round(CY1 + NY) - 1; NX := A; AddEdge(Round(CX1 + A) - 1, Floor(CY1)); for Y := 1 to Pred(EY) do begin NX := A * Sqrt(1 - Sqr(Y + 0.5 - Frac(B)) * DivSqrB); AddEdge(Round(CX1 + NX) - 1, Floor(CY1) + Y); end; LX2 := Round(CX1 + NX) - 1; LY2 := Floor(CY1) + Pred(EY); if Abs(LX1 - LX2) > 1 then begin if Abs(LY1 - LY2) > 1 then AddEdge(LX1 + 1, LY1 - 1) else AddEdge(LX1 + 1, LY1); end else if Abs(LY1 - LY2) > 1 then AddEdge(LX2, LY1 - 1); for I := 0 to High(EdgeList) do begin if EdgeList[I].X = -1 then EdgeList[I] := Point(Round(CX1 + A) - 1, Round(CX1 + A) - 1) else Break; end; for J := 0 to High(EdgeList) do begin if (J = 0) and (Frac(CY) > 0) then begin for I := EdgeList[J].X to EdgeList[J].Y do begin DrawOutlinePixel(Floor(CX) + I, Floor(CY) + J); DrawOutlinePixel(Ceil(CX) - Succ(I), Floor(CY) + J); end; for I := Ceil(CX) - EdgeList[J].X to Floor(CX) + Pred(EdgeList[J].X) do begin DrawFillPixel(I, Floor(CY) + J); end; end else if (J = High(EdgeList)) then begin if Frac(CX) > 0 then S := -EdgeList[J].Y else S := -Succ(EdgeList[J].Y); for I := S to EdgeList[J].Y do begin DrawOutlinePixel(Floor(CX) + I, Floor(CY) + J); DrawOutlinePixel(Floor(CX) + I, Ceil(CY) - Succ(J)); end; end else begin for I := EdgeList[J].X to EdgeList[J].Y do begin DrawOutlinePixel(Floor(CX) + I, Floor(CY) + J); DrawOutlinePixel(Floor(CX) + I, Ceil(CY) - Succ(J)); if Floor(CX) + I <> Ceil(CX) - Succ(I) then begin DrawOutlinePixel(Ceil(CX) - Succ(I), Floor(CY) + J); DrawOutlinePixel(Ceil(CX) - Succ(I), Ceil(CY) - Succ(J)); end; end; for I := Ceil(CX) - EdgeList[J].X to Floor(CX) + Pred(EdgeList[J].X) do begin DrawFillPixel(I, Floor(CY) + J); DrawFillPixel(I, Ceil(CY) - Succ(J)); end; end; end; end; (* FloodFillScanLine - 4-directional scan line stack based flood fill algorithm with control of visited pixels. *) procedure FloodFillScanLine(X, Y, W, H: Integer; GetPixel: TGetPixelFunction; SamePixel: TSamePixelFunction; DrawPixel: TDrawPixelProcedure); var S: TRGB32Pixel; SX, EX, I: Integer; Added: Boolean; Visited: Array of Byte; Stack: Array of Integer; StackCount: Integer; function CheckPixel(AX, AY: Integer): Boolean; inline; begin if Visited[AX + AY * W] = 1 then Result := False else begin Result := SamePixel(AX, AY, S); end; end; procedure Push(AX, AY: Integer); inline; begin if StackCount >= High(Stack) then SetLength(Stack, Length(Stack) shl 1); Stack[StackCount] := AX or (AY shl 16); Inc(StackCount); end; procedure Pop(var AX, AY: Integer); inline; begin Dec(StackCount); AX := Stack[StackCount] and $FFFF; AY := (Stack[StackCount] shr 16) and $FFFF; end; begin if (X >= 0) and (X < W) and (Y >= 0) and (Y < H) then begin S := GetPixel(X, Y); SetLength(Stack, 1); StackCount := 0; SetLength(Visited, W * H); FillChar(Visited[0], Length(Visited), #0); Push(X, Y); repeat Pop(X, Y); if not CheckPixel(X, Y) then Continue; SX := X; while (SX > 0) and CheckPixel(Pred(SX), Y) do Dec(SX); EX := X; while (EX < Pred(W)) and CheckPixel(Succ(EX), Y) do Inc(EX); FillChar(Visited[SX + Y * W], Succ(EX - SX), #1); FillPixelRow(SX, EX, Y, DrawPixel); Added := False; if Y > 0 then for I := SX to EX do if CheckPixel(I, Pred(Y)) then begin if Added then Continue; Push(I, Pred(Y)); Added := True; end else Added := False; Added := False; if Y < Pred(H) then for I := SX to EX do if CheckPixel(I, Succ(Y)) then begin if Added then Continue; Push(I, Succ(Y)); Added := True; end else Added := False; until StackCount <= 0; end; end; end.