DBR Delphi-Ecke

// Eine Bitmap wird zu einem Zylinder geformt. Dabei muss das Bild
// mindestens 50 Pixel breit sein, und seine Höhe muss mindestens ein
// Sechstel der Breite betragen. Die Variablen dunkel1 und dunkel2
// bestimmen, in wie weit das Innere des Zylinders abgedunkelt dargestellt
// wird. ist dabei ein Wert größer als der andere, wird das Innere nach
// unten hin zusätzlich abgedunkelt (vergleiche Beispiel 3 mit Beispiel 1).
// Die Variable Schatten bewirkt, dass auch das Äußere des Zylinders zum
// Rand hin abgedunkelt wird (vergleiche auch hier das Beispiel 3 mit dem
// Beispiel 1). Das Grundprinzip (Ellipsen-Quadrant zeichnen) habe ich
// abgeschaut bei Jack E. Bresenham (* 11. Oktober 1937 in Clovis, New
// Mexico, ehemals Programmierer bei IBM). Die Variablen x und y in der
// Funktion DrawZylinder bestimmen die linke und die obere Position des
// Zylinders auf der Zeichenfläche und die Funktion selbst gibt bei
// Gelingen die Breite und die Höhe des Zylinders zurück.
// Mittels der Funktion CalculateZylinder kann man lediglich die
// Zylindermaße ermitteln ohne den Zylinder selbst zu zeichnen.
// siehe auch: Bilder zu einem Vierkant formen


Original

Röhre offen (Beispiel 1)	Röhre geschlossen (Beispiel 2)	Mit Abdunkeln (Beispiel 3)
dunkel1 := 40; dunkel2 := 40; schatten := 0;	schatten := 0;	dunkel1 := 0; dunkel2 := 200; schatten := 180;

// Getestet mit D4 unter XP

// Variante 1

type 
  PColor = ^TColor; 
 
var 
  r, g, b: Byte; 
  bild, spalte: TBitmap; 
  dunkel1, dunkel2, schatten: byte; 
  rx, ry, wlo, wro, wlu, wru, diff: integer; 
  step_i, step_a, schattierung: single; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  bild := TBitmap.create; 
  spalte := TBitmap.create; 
  spalte.pixelformat := pf24bit; 
  spalte.width := 1; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  spalte.free; 
  bild.free; 
end; 
 
procedure makespalte(x, hoch: integer; dkl: single; p, v: boolean); 
var 
  y, z, step: integer; 
  pb, ps: PBytearray; 
  function SetByte(i: integer): byte; 
  asm 
  CMP  EAX, 255 
  JG   @MAX 
  CMP  EAX, 0 
  JGE  @OK 
  MOV  EAX, 0 
  JMP  @OK 
 @MAX: 
  MOV  EAX,255 
 @OK: 
  end; 
begin 
  x := x * 3; 
  z := ord(not v); 
  for y := 0 to hoch do begin 
    pb := bild.scanline[y]; 
    ps := spalte.scanline[y]; 
    step := trunc(dkl + y * step_i * z); 
    if v or not p then begin 
      ps[0] := setbyte(pb[x] - step); 
      ps[1] := setbyte(pb[x + 1] - step); 
      ps[2] := setbyte(pb[x + 2] - step); 
    end else begin 
      ps[0] := b; 
      ps[1] := g; 
      ps[2] := r; 
    end; 
  end; 
end; 
 
procedure go(x0, y0: integer; cnv: TCanvas; p, v: boolean); 
var 
  x, y, rx2, ry2, F, Fx, Fy, yy, ryy, rxx, k, h: integer; 
  xx: single; 
begin 
  h := pred(bild.height); 
  if not v then begin 
    wlo := round(bild.width / 4) + diff; 
    wro := round(bild.width / 4); 
    wru := round(bild.width * 3 / 4); 
  end else begin 
    wlo := 0; 
    wro := pred(bild.width); 
    wru := trunc(bild.width / 2); 
  end; 
  wlu := wru - diff; 
  rx2 := rx * rx; 
  ry2 := ry * ry; 
  inc(x0, rx); 
  inc(y0, ry); 
  F := Round(ry2 - rx2 * ry + 0.25 * rx2); 
  rxx := rx2 + rx2; 
  Fx := 0; 
  Fy := rxx * ry; 
  x := 0; 
  y := ry; 
  ryy := ry2 + ry2; 
  k := ry * 2; 
  // hinten Mitte: 
  makespalte(wlo, k, dunkel1, p, false); 
  bitblt(cnv.handle, x0 - x, y0 - y, 1, k, 
    spalte.canvas.handle, 0, 0, srcCopy); 
  // vorn Mitte: 
  makespalte(wlu, h, 0, p, true); 
  bitblt(cnv.handle, x0 + x, y0 + y, 1, h, 
    spalte.canvas.handle, 0, 0, srcCopy); 
  while Fx < Fy do begin 
    if F >= 0 then begin 
      dec(y); 
      Fy := Fy - rxx; 
      F := F - Fy; 
    end; 
    inc(x); 
    Fx := Fx + ryy; 
    F := F + Fx + ry2; 
    // hinten links (Innenteil) 
    makespalte(wlo, k, dunkel1, p, false); 
    inc(wlo); 
    bitblt(cnv.handle, x0 - x, y0 - y, 1, k, 
      spalte.canvas.handle, 0, 0, srcCopy); 
    // hinten rechts (Innenteil) 
    makespalte(wro, k, dunkel1, p, false); 
    dec(wro); 
    bitblt(cnv.handle, x0 + x, y0 - y, 1, k, 
      spalte.canvas.handle, 0, 0, srcCopy); 
    // vorn links (Innenteil) 
    makespalte(wlu, h, schattierung, p, true); 
    dec(wlu); 
    bitblt(cnv.handle, x0 - x, y0 + y, 1, h, 
      spalte.canvas.handle, 0, 0, srcCopy); 
    // vorn rechts (Innenteil) 
    makespalte(wru, h, schattierung, p, true); 
    inc(wru); 
    bitblt(cnv.handle, x0 + x, y0 + y, 1, h, 
      spalte.canvas.handle, 0, 0, srcCopy); 
    schattierung := schattierung + step_a; 
  end; 
  xx := x + 0.5; 
  yy := pred(y); 
  F := Round(ry2 * xx * xx + rx2 * yy * yy - rx2 * ry2); 
  while y > 0 do begin 
    if F <= 0 then begin 
      inc(x); 
      Fx := Fx + ryy; 
      F := F + Fx; 
    end; 
    dec(y); 
    Fy := Fy - rxx; 
    F := F + rx2 - Fy; 
    // hinten links (Außenteil) 
    makespalte(wlo, k, dunkel1, p, false); 
    inc(wlo); 
    bitblt(cnv.handle, x0 - x, y0 - y, 1, k, 
      spalte.canvas.handle, 0, 0, srcCopy); 
    // hinten rechts (Außenteil) 
    makespalte(wro, k, dunkel1, p, false); 
    dec(wro); 
    bitblt(cnv.handle, x0 + x, y0 - y, 1, k, 
      spalte.canvas.handle, 0, 0, srcCopy); 
    // vorn links (Außenteil) 
    makespalte(wlu, h, schattierung, p, true); 
    dec(wlu); 
    bitblt(cnv.handle, x0 - x, y0 + y, 1, h, 
      spalte.canvas.handle, 0, 0, srcCopy); 
    // vorn rechts (Außenteil) 
    makespalte(wru, h, schattierung, p, true); 
    inc(wru); 
    bitblt(cnv.handle, x0 + x, y0 + y, 1, h, 
      spalte.canvas.handle, 0, 0, srcCopy); 
    schattierung := schattierung + step_a; 
  end; 
end; 
 
function DrawZylinder(vari: boolean; x, y: integer; cnv: TCanvas; pc: PColor; 
  doit: boolean = true): TPoint; 
const 
  teiler = 4.21; 
var 
  f: boolean; 
  i, r2: integer; 
  function mass: TPoint; 
  begin 
    result := point(succ(rx * 2), pred(bild.height + r2)); 
  end; 
begin 
  result := point(0, 0); 
  if (bild.width < 50) or (bild.height < bild.width div 6) 
    then exit; 
  try 
    rx := trunc(bild.width / teiler); 
    ry := round(rx / 3); 
    r2 := ry + ry; 
    if not doit then 
      result := mass 
    else begin 
      bild.pixelformat := pf24bit; 
      if dunkel1 > dunkel2 then begin 
        i := dunkel1; 
        dunkel1 := dunkel2; 
        dunkel2 := i; 
      end; 
      step_i := (dunkel2 - dunkel1) / r2; 
      schattierung := 0; 
      if schatten = 0 then 
        step_a := 0 else 
        step_a := schatten / (rx + rx); 
      if pc <> nil then begin 
        b := getbvalue(pc^); 
        g := getgvalue(pc^); 
        r := getrvalue(pc^); 
        f := true; 
      end else f := false; 
      spalte.height := bild.height; 
      diff := bild.width - trunc(rx * teiler); 
      go(x, y, cnv, f, vari); 
      result := mass; 
    end; 
  except 
  end; 
end; 
 
function CalculateZylinder: TPoint; 
begin 
  result := DrawZylinder(false, 0, 0, nil, nil, false); 
end; 
 
// -- Beispielaufrufe -- 
 
// Beispiel 1 
// Bild hinten sichtbar (Röhre offen) 
 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  pkt: TPoint; 
  variante: boolean; 
begin 
  variante := True; 
  dunkel1 := 40; 
  dunkel2 := 40; 
  schatten := 0; 
  bild.loadfromfile('d:\bilder\Test.bmp'); 
  pkt := DrawZylinder(variante, 50, 10, Canvas, nil); 
  if pkt.y = 0 
    then showmessage('Verarbeitung war nicht möglich!') 
  else begin 
    label1.caption := 'Zylinderhöhe: ' + inttostr(pkt.y) + ' Pixel'; 
    label2.caption := 'Zylinderbreite: ' + inttostr(pkt.x) + ' Pixel'; 
  end; 
end; 
 
// Beispiel 2 
// Bild hinten nicht sichtbar (Röhre geschlossen), 
// wird durch Angabe einer Farbe erreicht 
 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  f: TColor; 
begin 
  f := clgreen; 
  schatten := 0; 
  bild.loadfromfile('d:\bilder\Test.bmp'); 
  if DrawZylinder(true, 250, 10, Canvas, @f).y = 0 
    then showmessage('Fehler bei der Verarbeitung!'); 
end; 
 
// Beispiel 3 
// Röhre wird innen nach unten 
// und außen zum Rand hin dunkler 
 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  dunkel1 := 0; 
  dunkel2 := 200; 
  schatten := 180; 
  bild.loadfromfile('d:\bilder\Test.bmp'); 
  if DrawZylinder(true, 450, 10, Canvas, nil).y = 0 
    then showmessage('Fehler bei der Verarbeitung!'); 
end; 
 
// Beispiel 4 
// nur Abmaße der Röhre ermitteln ohne sie zu zeichnen 
 
procedure TForm1.Button4Click(Sender: TObject); 
var 
  pkt: TPoint; 
begin 
  bild.loadfromfile('d:\bilder\Test.bmp'); 
  pkt := CalculateZylinder; 
  if pkt.y = 0 
    then showmessage('Ermittlung war nicht möglich!') 
  else 
    showmessage('Zylinderhöhe: ' + inttostr(pkt.y) + ' Pixel'#13#10 + 
      'Zylinderbreite: ' + inttostr(pkt.x) + ' Pixel'); 
end; 
 
// Beispiel 5 
// die Röhre wird doppelt so breit wie bei den anderen Beispielen, 
// dafür ist das komplette Bild vorn zu sehen 
 
procedure TForm1.Button5Click(Sender: TObject); 
var 
  b: TBitmap; 
begin 
  bild.loadfromfile('d:\bilder\Test.bmp'); 
  b := TBitmap.create; 
  with b, canvas do begin 
    width := bild.width * 2; 
    height := bild.height; 
    brush.color := clgreen; 
    fillrect(cliprect); 
    draw(bild.width div 2, 0, bild); 
  end; 
  bild.assign(b); 
  b.free; 
  dunkel1 := 0; 
  dunkel2 := 100; 
  schatten := 200; 
  if DrawZylinder(true, 650, 10, Canvas, nil).y = 0 
    then showmessage('Fehler bei der Verarbeitung!'); 
end;

//-----------------------------------------------------------------

// Variante 2

// Wer auf Abdunkeln, Größenbestimmung und Schließen der Röhre
// sowie auf die Variation (siehe Variante "vari") verzichten kann,
// für den ist der nachfolgende einfache Code bestimmt
// (die erzeugte Röhre entspricht dem Beispiel 1).

var bild: TBitmap; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  bild := TBitmap.create; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  bild.free; 
end; 
 
procedure Zylinder(cnv: TCanvas; x0, y0: integer); 
const 
  teiler = 4.21; 
var 
  rx, ry, rx2, ry2, rx4, ry4, F, Fx, Fy, x, y, yy, diff, h, k, 
    wlo, wro, wlu, wru: integer; 
  xx: single; 
  procedure Teil; 
  begin 
    bitblt(cnv.handle, x0 - x, y0 - y, 1, k, 
      bild.canvas.handle, wlo, 0, srcCopy); 
    inc(wlo); 
    bitblt(cnv.handle, x0 + x, y0 - y, 1, k, 
      bild.canvas.handle, wro, 0, srcCopy); 
    dec(wro); 
    bitblt(cnv.handle, x0 - x, y0 + y, 1, h, 
      bild.canvas.handle, wlu, 0, srcCopy); 
    dec(wlu); 
    bitblt(cnv.handle, x0 + x, y0 + y, 1, h, 
      bild.canvas.handle, wru, 0, srcCopy); 
    inc(wru); 
  end; 
begin 
  h := pred(bild.height); 
  rx := trunc(bild.width / teiler); 
  ry := round(rx / 3); 
  rx2 := rx * rx; 
  ry2 := ry * ry; 
  rx4 := rx2 + rx2; 
  ry4 := ry2 + ry2; 
  F := Round(ry2 - rx2 * ry + 0.25 * rx); 
  Fx := 0; 
  Fy := rx4 * ry; 
  x := 0; 
  y := ry; 
  k := ry * 2; 
  diff := bild.width - trunc(rx * teiler); 
  wlo := 0; 
  wro := pred(bild.width); 
  wru := trunc(bild.width / 2); 
  wlu := wru - diff; 
  bitblt(cnv.handle, x0, y0 - y, 1, k, bild.canvas.handle, wlo, 0, srcCopy); 
  bitblt(cnv.handle, x0, y0 + y, 1, h, bild.canvas.handle, wlu, 0, srcCopy); 
  while Fx < Fy do begin 
    if F >= 0 then begin 
      dec(y); 
      Fy := Fy - rx4; 
      F := F - Fy; 
    end; 
    inc(x); 
    Fx := Fx + ry4; 
    F := F + Fx + ry2; 
    Teil; 
  end; 
  xx := x + 0.5; 
  yy := pred(y); 
  F := Round(ry2 * xx * xx + rx2 * yy * yy - rx2 * ry2); 
  while y > 0 do begin 
    if F <= 0 then begin 
      inc(x); 
      Fx := Fx + ry4; 
      F := F + Fx; 
    end; 
    dec(y); 
    Fy := Fy - rx4; 
    F := F + rx2 - Fy; 
    Teil; 
  end; 
end; 
 
 
// Beispielaufruf 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  bild.loadfromfile('c:\bilder\Test.bmp'); 
  Zylinder(canvas, 200, 100); 
end;