unit Unit1; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
  Dialogs, StdCtrls, ExtCtrls; 
 
type 
  TForm1 = class(TForm) 
    PaintBox1: TPaintBox; 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure FormPaint(Sender: TObject); 
    procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); 
    procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; 
      X, Y: Integer); 
    procedure PaintBox1MouseUp(Sender: TObject; Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); 
    procedure FormShow(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    function Vorbereitung(gr: TGraphic; dm: TBitmap; cl: TColor): TPoint; 
    procedure DoIt(Rad: Double); 
    procedure Rotate(grphk: TGraphic; Rad: Double; cl: TColor); 
    procedure Zeigen(cnv: TCanvas; X, Y: Integer); 
    function Sektor(X, Y: Integer): byte; 
    function Distance(a, b: TPoint): Double; 
    function Rechnen(X, Y: Integer): Double; 
    function drin(X, Y: Integer): Boolean; 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.dfm} uses math; 
 
type 
  TOffset = record 
    fx: Double; 
    fy: Double; 
  end; 
 
var 
  diff: TPoint; 
  r, g, b: byte; 
  Rad: Double = 0.0; 
  mRad: Double = 0.0; 
  s1, s3: Double; 
  links, oben, mitte: Integer; 
  Quell, Ziel: TBitmap; 
  dcxy, scx, scy: Word; 
  ZStep, QStep, PQuell, PZiel: Cardinal; 
  offs: array [1 .. 4, 0 .. 8] of TOffset; 
  Hintergrund: TColor; 
  startwinkel, stellwinkel: Double; 
  p0, p1, p2: TPoint; 
  isdown: Boolean = false; 
  Ersatz: TColor; 
 
function TForm1.Distance(a, b: TPoint): Double; 
var 
  dx, dy: Integer; 
begin 
  dx := a.X - b.X; 
  dy := a.Y - b.Y; 
  result := sqrt(dx * dx + dy * dy); 
end; 
 
function TForm1.drin(X, Y: Integer): Boolean; 
begin 
  result := sqr(mitte - X) + sqr(mitte - Y) <= sqr(mitte); 
end; 
 
function WinkelRad(a, b, c: Double): Double; 
var 
  X: Double; 
begin 
  X := (a * a + b * b - c * c) / (2 * a * b + 0.0001); 
  result := ArcCos(X); 
end; 
 
function TForm1.Vorbereitung(gr: TGraphic; dm: TBitmap; cl: TColor): TPoint; 
begin 
  Quell.PixelFormat := pf32bit; 
  Quell.Width := gr.Width; 
  Quell.Height := gr.Height; 
  Quell.Canvas.Draw(0, 0, gr); 
  Ziel := dm; 
  Ziel.PixelFormat := pf32bit; 
  Ziel.Canvas.Brush.Color := ColorToRGB(cl); 
  scx := (Quell.Width - 1) shr 1; 
  scy := (Quell.Height - 1) shr 1; 
  Ziel.Width := 2 + trunc(sqrt(sqr(Quell.Width) + sqr(Quell.Height))) or 1; 
  Ziel.Height := Ziel.Width; 
  result.X := (Ziel.Width - Quell.Width + 1) shr 1; 
  result.Y := (Ziel.Height - Quell.Height + 1) shr 1; 
  dcxy := trunc(Ziel.Width / 2); 
  PQuell := Cardinal(Quell.scanline[0]); 
  QStep := PQuell - Cardinal(Quell.scanline[1]); 
  PZiel := Cardinal(Ziel.scanline[0]); 
  ZStep := PZiel - Cardinal(Ziel.scanline[1]); 
end; 
 
procedure TForm1.DoIt(Rad: Double); 
var 
  vi, vj, vsin, vcos, tx, ty, xtx, xty, ytx, yty: Double; 
  ttx, tty, sumR, sumG, sumB, X, Y, t: Word; 
  pix, Ybase1, Ybase2, PS, PD: Cardinal; 
  trunctx, truncty: SmallInt; 
  i, j, vier: byte; 
begin 
  vsin := sin(Rad); 
  vcos := cos(Rad); 
  for j := 0 to 2 do 
  begin 
    vj := 0.333 * j; 
    yty := vj * vcos; 
    ytx := vj * vsin; 
    for i := 0 to 2 do 
    begin 
      vi := 0.333 * i; 
      xtx := vi * vcos; 
      xty := vi * vsin; 
      for vier := 1 to 4 do 
        with offs[vier, i + 3 * j] do 
          case vier of 
            1: 
              begin 
                fx := xtx + ytx; 
                fy := -xty + yty; 
              end; 
            2: 
              begin 
                fx := -xtx + ytx; 
                fy := xty + yty; 
              end; 
            3: 
              begin 
                fx := -xtx - ytx; 
                fy := xty - yty; 
              end; 
            else 
              begin 
                fx := xtx - ytx; 
                fy := -xty - yty; 
              end; 
            end; 
    end; 
  end; 
  for Y := 0 to dcxy do 
  begin 
    yty := Y * vcos; 
    ytx := Y * vsin; 
    Ybase1 := PZiel - (dcxy + Y) * ZStep; 
    t := dcxy - Y; 
    Ybase2 := PZiel - t * ZStep; 
    for X := 0 to dcxy do 
    begin 
      xtx := X * vcos; 
      xty := X * vsin; 
      for i := 1 to 4 do 
      begin 
        case i of 
          1: 
            begin 
              PD := Ybase1 + ((dcxy + X) shl 2); 
              tx := xtx + ytx; 
              ty := -xty + yty; 
            end; 
          2: 
            begin 
              t := dcxy - X; 
              PD := Ybase1 + (t shl 2); 
              tx := -xtx + ytx; 
              ty := xty + yty; 
            end; 
          3: 
            begin 
              PD := Ybase2 + (t shl 2); 
              tx := -xtx - ytx; 
              ty := xty - yty; 
            end; 
          else 
            begin 
              PD := Ybase2 + ((dcxy + X) shl 2); 
              tx := xtx - ytx; 
              ty := -xty - yty; 
            end; 
          end; 
        sumR := 0; 
        sumG := 0; 
        sumB := 0; 
        for j := 0 to 8 do 
        begin 
          trunctx := trunc(tx + offs[i, j].fx); 
          truncty := trunc(ty + offs[i, j].fy); 
          if (abs(trunctx) > scx) or (abs(truncty) > scy) then 
          begin 
            sumR := sumR + r; 
            sumG := sumG + g; 
            sumB := sumB + b; 
          end 
          else 
          begin 
            ttx := scx + trunctx; 
            tty := scy + truncty; 
            PS := PQuell - tty * QStep + (ttx shl 2); 
            pix := PDWord(PS)^; 
            sumR := sumR + ((pix shr 16) and $FF); 
            sumG := sumG + ((pix shr 8) and $FF); 
            sumB := sumB + (pix and $FF); 
          end; 
        end; 
        sumR := sumR div 9; 
        sumG := sumG div 9; 
        sumB := sumB div 9; 
        pix := (sumR shl 16) or (sumG shl 8) or sumB; 
        PDWord(PD)^ := pix; 
      end; 
    end; 
  end; 
end; 
 
procedure TForm1.Rotate(grphk: TGraphic; Rad: Double; cl: TColor); 
begin 
  r := Getrvalue(cl); 
  g := Getgvalue(cl); 
  b := Getbvalue(cl); 
  diff := Vorbereitung(grphk, Ziel, cl); 
  DoIt(Rad); 
end; 
 
procedure TForm1.Zeigen(cnv: TCanvas; X, Y: Integer); 
begin 
  cnv.Draw(X - diff.X, Y - diff.Y, Ziel); 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Quell := TBitmap.Create; 
  Quell.LoadFromFile('knopf.bmp'); // z.B. 
  Ziel := TBitmap.Create; 
  Hintergrund := ColorToRGB(Color); // hier im Fall des DEMO-Programms
  Ersatz := Quell.Canvas.Pixels[0, 0]; 
  Quell.Canvas.Brush.Color := Hintergrund; 
  Quell.Canvas.FloodFill(0, 0, Ersatz, fssurface); 
  Quell.Canvas.FloodFill(Quell.Width - 1, 0, Ersatz, fssurface); 
  Quell.Canvas.FloodFill(0, Quell.Height - 1, Ersatz, fssurface); 
  Quell.Canvas.FloodFill(Quell.Width - 1, Quell.Height - 1, Ersatz, fssurface); 
  Doublebuffered := true; 
  Ziel.Assign(Quell); 
  PaintBox1.Width := Quell.Width; 
  PaintBox1.Height := Quell.Height; 
  mitte := round(Quell.Height / 2); 
  links := 0; 
  oben := 0; 
  Rotate(Quell, Rad, Hintergrund); 
  p0 := Point(mitte, mitte); 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  Quell.Free; 
  Ziel.Free; 
end; 
 
procedure TForm1.FormPaint(Sender: TObject); 
begin 
  Zeigen(PaintBox1.Canvas, links, oben); 
end; 
 
procedure TForm1.FormShow(Sender: TObject); 
begin 
  // damit beim Start die Paintbox zu sehen ist, auch dann,
  // wenn keine anderen Komponenten auf der Form plaziert sind: 
  SetWindowPos(handle, HWND_TOP, 0, 0, 0, 0, 
    SWP_NOMOVE or SWP_NOSIZE or SWP_SHOWWINDOW); 
  Application.ProcessMessages; 
  Zeigen(PaintBox1.Canvas, links, oben); 
end; 
 
function TForm1.Sektor(X, Y: Integer): byte; 
begin 
  if X > mitte then 
  begin 
    if Y < mitte then 
      result := 2 
    else 
      result := 4; 
  end 
  else 
  begin 
    if Y < mitte then 
      result := 1 
    else 
      result := 3; 
  end; 
end; 
 
function TForm1.Rechnen(X, Y: Integer): Double; 
begin 
  p1 := Point(X, Y); 
  s1 := round(Distance(p0, p1)); 
  case Sektor(X, Y) of 
    1: 
      begin 
        p2 := Point(mitte, round(mitte - s1)); 
        s3 := round(Distance(p1, p2)); 
        result := -WinkelRad(s1, s1, s3); 
      end; 
    2: 
      begin 
        p2 := Point(mitte, round(mitte - s1)); 
        s3 := round(Distance(p1, p2)); 
        result := WinkelRad(s1, s1, s3); 
      end; 
    3: 
      begin 
        p2 := Point(mitte, round(mitte + s1)); 
        s3 := round(Distance(p1, p2)); 
        result := WinkelRad(s1, s1, s3) + degtorad(180); 
      end; 
    else 
      begin 
        p2 := Point(round(mitte + s1), mitte); 
        s3 := round(Distance(p1, p2)); 
        result := WinkelRad(s1, s1, s3) + degtorad(90); 
      end; 
    end; 
end; 
 
procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  if drin(X, Y) then 
  begin 
    startwinkel := Rechnen(X, Y); 
    isdown := true; 
  end; 
end; 
 
procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; 
  X, Y: Integer); 
begin 
  if isdown and drin(X, Y)then 
  begin 
    stellwinkel := Rechnen(X, Y); 
    Rad := mRad + stellwinkel - startwinkel; 
    DoIt(Rad); 
    Zeigen(PaintBox1.Canvas, links, oben); 
  end; 
end; 
 
procedure TForm1.PaintBox1MouseUp(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  isdown := false; 
  mRad := Rad; 
end; 
 
end.