DBR Delphi-Ecke

// Ein Muster wird über einen Würfel gelegt.
// Siehe aber auch Bilder zu einem Vierkant formen.

// Getestet mit D2010 unter Win7

// Variante 1
// Da eine Seite abgeklappt wird, eignet sich das Ganze nicht für Portraits.
// Die Größe des Würfels richtet sich nach der geringsten Abmessung des
// Musters und kann durch Aufrufen von "cube" unter der Angabe des
// Musterbildes ermittelt werden.


mutation = True border^ = clBlack	mutation = False border^ = nil	Image1.Picture.Bitmap


type 
  PColor = ^TColor;

function frontface(src: TBitmap): Integer; 
var 
  w, h: Integer; 
begin 
  w := src.width div 3; 
  h := src.height div 2; 
  if h < w then 
    result := h 
  else 
    result := w; 
end; 
 
function cube(src: TBitmap): Integer; overload; 
begin 
  result := trunc(frontface(src) * 1.333); 
end;

procedure cube(cnv: TCanvas; Ground: TColor; x, y: Integer; src: TBitmap; 
  mutation: Boolean; border: PColor = nil); overload; 
var 
  hlp: TBitmap; 
  w, m, md3, m33, mm: Integer; 
  Points: array [0 .. 2] of TPoint; 
begin 
  m := frontface(src); 
  m33 := trunc(m * 1.333); 
  md3 := m div 3; 
  mm := m + m; 
  hlp := TBitmap.create; 
  hlp.width := m * 3; 
  hlp.height := m * 2; 
  w := (hlp.width - src.width) div 2; 
  hlp.Canvas.draw(w, 0, src); 
  with cnv do 
  begin 
    Brush.Color := Ground; 
    FillRect(rect(x, y, x + m33, y + m33)); 
    if border <> nil then 
      Pen.Color := border^; 
    if mutation then 
    begin 
      CopyRect(rect(x, y + md3, m + x, m33 + y), hlp.Canvas, 
        rect(hlp.width - mm, hlp.height - m, hlp.width - m, hlp.height)); 
      Points[0] := point(x + md3, y); 
      Points[1] := point(x + m33, y); 
      Points[2] := point(x, y + md3); 
      PlgBlt(handle, Points, hlp.Canvas.handle, hlp.width - mm, 0, 
        hlp.width - mm, m, 0, 0, 0); 
      Points[0] := point(x + m, y + md3 - 1); 
      Points[1] := point(x + trunc(m * 1.666) - 1, y - md3); 
      Points[2] := point(x + m, y + m33 - 1); 
      PlgBlt(handle, Points, hlp.Canvas.handle, hlp.width - m, 0, 
        hlp.width - m, m, 0, 0, 0); 
      if border <> nil then 
      begin 
        moveto(x, y + md3 - 1); 
        lineto(x + m - 1, y + md3 - 1); 
        lineto(x + m - 1, y + m33 - 1); 
        lineto(x, y + m33 - 1); 
        lineto(x, y + md3 - 1); 
        lineto(x + md3 - 1, y); 
        lineto(x + m33 - 1, y); 
        lineto(x + m33 - 1, y + m - 1); 
        lineto(x + m - 1, y + m33 - 1); 
        moveto(x + m - 1, y + md3 - 1); 
        lineto(x + m33 - 1, y); 
      end; 
    end 
    else 
    begin 
      CopyRect(rect(x + md3, y + md3, m33 + x, m33 + y), hlp.Canvas, 
        rect(hlp.width - mm, hlp.height - m, hlp.width - m, hlp.height)); 
      Points[0] := point(x, y); 
      Points[1] := point(x + m, y); 
      Points[2] := point(x + md3, y + md3); 
      PlgBlt(handle, Points, hlp.Canvas.handle, hlp.width - mm, 0, 
        hlp.width - mm, m, 0, 0, 0); 
      Points[1] := point(x + md3, y + md3); 
      Points[2] := point(x, y + m - 1); 
      PlgBlt(handle, Points, hlp.Canvas.handle, 0, 0, m, m, 0, 0, 0); 
      if border <> nil then 
      begin 
        moveto(x, y + m - 1); 
        lineto(x, y); 
        lineto(x + m - 1, y); 
        lineto(x + m33 - 1, y + md3 - 1); 
        lineto(x + m33 - 1, y + m33 - 1); 
        lineto(x + md3 - 1, y + m33 - 1); 
        lineto(x + md3 - 1, y + md3 - 1); 
        lineto(x + m33 - 1, y + md3 - 1); 
        moveto(x, y); 
        lineto(x + md3, y + md3); 
        moveto(x, y + m - 1); 
        lineto(x + md3, y + m33); 
      end; 
    end; 
  end; 
  hlp.free; 
end; 

 
 
// --- Beispielaufrufe: --- 
 
var 
  xx: Integer = 100; 
  yy: Integer = 50; 
 
  // Größe ermitteln
procedure TForm1.Button1Click(Sender: TObject);  
var 
  groesse: Integer; 
begin 
  groesse := cube(Image1.Picture.Bitmap); 
  With Canvas do 
    Rectangle(xx, yy, xx + groesse, yy + groesse); // z.B. 
end; 
 
// Abbildungen 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  c: TColor; 
begin
  c := clBlack; 
  cube(Canvas, Color, xx, yy, Image1.Picture.Bitmap, true, @c); 
  cube(Canvas, Color, xx + 200, yy, Image1.Picture.Bitmap, false);
end;

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

// Variante 2
// Es werden zwei weitere Möglichkeiten zur Verfügung gestellt: Die
// Seitenteile können mittels der Variablen "cant" nach vorn gekippt
// (also gedreht) werden und mittels "light" können Seitenteile und
// Oberseite beleuchtet bzw. beschattet werden, wobei die rechte Seite
// immer beschattet wird. Zur Größenermittlung wird auf "frontface"
// und die Funktion "cube" von Variante 1 (siehe oben) zugegriffen.


mutation = True border^ = clRed cant = True light = 0	mutation = False border^ = nil cant = True light = -66	mutation = True border^ = clRed cant = False light = 85	mutation = False border^ = nil cant = False light = 100

type 
  brightness = -120 .. 120;

procedure cube(cnv: TCanvas; Ground: TColor; x, y: Integer; src: TBitmap; 
  mutation: Boolean = False; cant: Boolean = False; light: brightness = 0; 
  border: PColor = nil); overload; 
var 
  bl, bm, br, bu: TBitmap; 
  m, md3, m33, w, p1, p2: Integer; 
  Points: array [0 .. 2] of TPoint; 
  procedure bmps(var b: TBitmap); 
  begin 
    b := TBitmap.create; 
    b.PixelFormat := pf24Bit; 
    b.width := m; 
    b.height := m; 
  end; 
  procedure makelight(bm: TBitmap; Value: brightness); 
    function SetByte(a, b: Integer): Byte; 
    asm 
     ADD  EAX, b 
     CMP  EAX, 255 
     JG   @MAX 
     CMP  EAX, 0 
     JGE  @OK 
     MOV  EAX, 0 
     JMP  @OK 
    @MAX: 
     MOV  EAX,255 
    @OK: 
   end; 
 
    var 
      i, j, b3: Integer; 
      p: PByteArray; 
    begin 
      b3 := bm.width * 3; 
      for j := 0 to bm.height - 1 do 
      begin 
        p := bm.ScanLine[j]; 
        i := 0; 
        while i < b3 do 
        begin 
          p[i] := SetByte(p[i], Value); 
          p[i + 1] := SetByte(p[i + 1], Value); 
          p[i + 2] := SetByte(p[i + 2], Value); 
          inc(i, 3); 
        end; 
      end; 
    end; 
 
  begin 
    m := frontface(src); 
    if m < 10 then 
    begin 
      ShowMessage('Das Bild ist zu klein für die Verarbeitung!'); 
      exit; 
    end; 
    md3 := m div 3; 
    m33 := trunc(m * 1.333); 
    bmps(bl); 
    bmps(bm); 
    bmps(br); 
    bmps(bu); 
    w := (src.width - m * 3) div 2; 
    bl.Canvas.CopyRect(bl.Canvas.ClipRect, src.Canvas, rect(w, 0, w + m, m)); 
    bm.Canvas.CopyRect(bm.Canvas.ClipRect, src.Canvas, 
      rect(w + m, 0, w + m * 2, m)); 
    br.Canvas.CopyRect(br.Canvas.ClipRect, src.Canvas, 
      rect(w + m * 2, 0, w + m * 3, m)); 
    bu.Canvas.CopyRect(bu.Canvas.ClipRect, src.Canvas, 
      rect(w + m, m, w + m * 2, m * 2)); 
    if light > 0 then 
      light := light div 2; 
    makelight(bl, light); 
    makelight(bm, light); 
    makelight(br, -abs(light)); 
    if cant then 
    begin 
      p1 := 2; 
      p2 := 1; 
    end 
    else 
    begin 
      p1 := 1; 
      p2 := 2; 
    end; 
    with cnv do 
    begin 
      if border <> nil then 
        Pen.Color := border^; 
      Brush.Color := Ground; 
      FillRect(rect(x, y, x + m33, y + m33)); 
      if mutation then 
      begin 
        draw(x, y + md3 - 1, bu); 
        Points[0] := point(x + md3 - 1, y); 
        Points[1] := point(x + m + md3 - 1, y); 
        Points[2] := point(x, y + md3 - 1); 
        PlgBlt(handle, Points, bm.Canvas.handle, 0, 0, m, m, 0, 0, 0); 
        Points[0] := point(x + m, y + md3 - 1); 
        Points[p1] := point(x + m - 1 + md3, y); 
        Points[p2] := point(x + m, y + m33 - 1); 
        PlgBlt(handle, Points, br.Canvas.handle, 0, 0, m, m, 0, 0, 0); 
        if border <> nil then 
        begin 
          moveto(x, y + md3 - 1); 
          lineto(x + m - 1, y + md3 - 1); 
          lineto(x + m - 1, y + m33 - 1); 
          lineto(x, y + m33 - 1); 
          lineto(x, y + md3 - 1); 
          lineto(x + md3 - 1, y); 
          lineto(x + m33 - 1, y); 
          lineto(x + m33 - 1, y + m - 1); 
          lineto(x + m - 1, y + m33 - 1); 
          moveto(x + m - 1, y + md3 - 1); 
          lineto(x + m33 - 1, y); 
        end; 
      end 
      else 
      begin 
        draw(x + md3 - 1, y + md3 - 1, bu); 
        Points[0] := point(x, y); 
        Points[1] := point(x + m, y); 
        Points[2] := point(x + md3, y + md3); 
        PlgBlt(handle, Points, bm.Canvas.handle, 0, 0, m, m, 0, 0, 0); 
        Points[p1] := point(x + md3, y + md3); 
        Points[p2] := point(x, y + m - 1); 
        PlgBlt(handle, Points, bl.Canvas.handle, 0, 0, m, m, 0, 0, 0); 
        if border <> nil then 
        begin 
          moveto(x, y + m - 1); 
          lineto(x, y); 
          lineto(x + m - 1, y); 
          lineto(x + m33 - 1, y + md3 - 1); 
          lineto(x + m33 - 1, y + m33 - 1); 
          lineto(x + md3 - 1, y + m33 - 1); 
          lineto(x + md3 - 1, y + md3 - 1); 
          lineto(x + m33 - 1, y + md3 - 1); 
          moveto(x, y); 
          lineto(x + md3, y + md3); 
          moveto(x, y + m - 1); 
          lineto(x + md3, y + m33); 
        end; 
      end; 
    end; 
    bu.free; 
    br.free; 
    bm.free; 
    bl.free; 
  end;

// ------Beispiele----- 
 
  procedure TForm1.Button3Click(Sender: TObject); 
  var 
    c: TColor; 
  begin 
    c := clRed; 
    cube(Canvas, Color, xx, yy + 200, Image1.Picture.Bitmap, True, True, 0, @c); 
    cube(Canvas, Color, xx + 200, yy + 200, Image1.Picture.Bitmap, False, True, 
      -66); 
    cube(Canvas, Color, xx + 400, yy + 200, Image1.Picture.Bitmap, True, False, 
      85, @c); 
    cube(Canvas, Color, xx + 600, yy + 200, Image1.Picture.Bitmap, True, True, 
      -75, @c); 
    cube(Canvas, Color, xx + 600, yy + 200, Image1.Picture.Bitmap, False, 
      False, 100); 
  end;

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

// Variante 3
// Diese Variante erlaubt es Gesichter (bzw. verschiedene Bilder) verwenden
// zu können.

 function dimension(b: array of TBitmap; out frontface: Integer): Integer; 
  var 
    i: Integer; 
  begin 
    frontface := maxint; 
    for i := 0 to high(b) do 
    begin 
      if b[i].width < frontface then 
        frontface := b[i].width; 
      if b[i].height < frontface then 
        frontface := b[i].height; 
    end; 
    result := trunc(frontface * 1.333); 
  end; 
 
  procedure cube_3(cnv: TCanvas; Ground: TColor; x, y: Integer; 
    src1, src2, src3: TBitmap; mutation: Boolean = False); 
  var 
    bl, bm, bu: TBitmap; 
    m, md3, m33: Integer; 
    Points: array [0 .. 2] of TPoint; 
    procedure bmps(var b: TBitmap); 
    begin 
      b := TBitmap.create; 
      b.width := m; 
      b.height := m; 
    end; 
    procedure conf(src, dst: TBitmap); 
    var 
      w, h: Integer; 
    begin 
      h := (src.height - m) div 2; 
      w := (src.width - m) div 2; 
      dst.Canvas.draw(-w, -h, src); 
    end; 
 
  begin 
    m33 := dimension([src1, src2, src3], m); 
    md3 := m div 3; 
    bmps(bl); 
    bmps(bm); 
    bmps(bu); 
    conf(src1, bl); 
    conf(src2, bm); 
    conf(src3, bu); 
    with cnv do 
    begin 
      Brush.Color := Ground; 
      FillRect(rect(x, y, x + m33, y + m33)); 
      if mutation then 
      begin 
        draw(x, y + md3 - 1, bu); 
        Points[0] := point(x + md3 - 1, y); 
        Points[1] := point(x + m + md3 - 1, y); 
        Points[2] := point(x, y + md3 - 1); 
        PlgBlt(handle, Points, bm.Canvas.handle, 0, 0, m, m, 0, 0, 0); 
        Points[0] := point(x + m, y + md3 - 1); 
        Points[1] := point(x + m - 1 + md3, y); 
        Points[2] := point(x + m, y + m33 - 1); 
        PlgBlt(handle, Points, bl.Canvas.handle, 0, 0, m, m, 0, 0, 0); 
      end 
      else 
      begin 
        draw(x + md3 - 1, y + md3 - 1, bu); 
        Points[0] := point(x, y); 
        Points[1] := point(x + m, y); 
        Points[2] := point(x + md3, y + md3); 
        PlgBlt(handle, Points, bm.Canvas.handle, 0, 0, m, m, 0, 0, 0); 
        Points[1] := point(x + md3, y + md3); 
        Points[2] := point(x, y + m - 1); 
        PlgBlt(handle, Points, bl.Canvas.handle, 0, 0, m, m, 0, 0, 0); 
      end; 
    end; 
    bu.free; 
    bm.free; 
    bl.free; 
  end; 
 
 
// Beispiel 
 
  procedure TForm1.Button4Click(Sender: TObject); 
  var 
    b1, b2, b3: TBitmap; 
  begin 
    b1 := TBitmap.create; 
    b1.LoadFromFile('D:\Bilder\Cube\frau.bmp'); 
    b2 := TBitmap.create; 
    b2.LoadFromFile('D:\Bilder\Cube\bernd.bmp'); 
    b3 := TBitmap.create; 
    b3.LoadFromFile('D:\Bilder\Cube\det.bmp'); 
    cube_3(Canvas, Color, 350, 100, b1, b2, b3); 
    cube_3(Canvas, Color, 50, 100, b1, b2, b3, True); 
    b3.free; 
    b2.free; 
    b1.free; 
  end;