type 
  pc = ^TColor; 
 
var 
  bm, triangle: TBitmap; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  triangle := TBitmap.create; 
  bm := TBitmap.create; 
  bm.loadfromfile('c:\Frosch.bmp'); 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  bm.free; 
  triangle.free; 
end; 
 
function mach3(src, dst: TBitmap; grund: TColor; 
  rand, zu: pc; variante: boolean; lus: byte; zeichnen: boolean = true): TPoint; 
var 
  xs, xd, schmal, breit, mass, 
    w3, m3, b3: integer; 
  ps, pd: PBytearray; 
  r, g, b, rz, gz, bz: byte; 
  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; 
  procedure strich; 
  begin 
    pd[xd] := b; 
    pd[xd + 1] := g; 
    pd[xd + 2] := r; 
  end; 
  procedure oben; 
  begin 
    pd[xd] := bz; 
    pd[xd + 1] := gz; 
    pd[xd + 2] := rz; 
  end; 
  procedure gerade(h, t, d: integer; z, r: boolean); 
  var 
    y: integer; 
  begin 
    for y := 0 to h do begin 
      xs := m3; 
      xd := 0; 
      ps := src.scanline[y]; 
      pd := dst.scanline[y + t]; 
      while xd < b3 do begin 
        if z then oben else begin 
          if (y = 0) and r then strich else begin 
            pd[xd] := setbyte(ps[xs] - d); 
            pd[xd + 1] := setbyte(ps[xs + 1] - d); 
            pd[xd + 2] := setbyte(ps[xs + 2] - d); 
          end; 
        end; 
        inc(xs, 3); 
        inc(xd, 3); 
      end; 
    end; 
  end; 
  procedure links(h, d: integer; t: PInteger; z, r: boolean); 
  var 
    y: integer; 
  begin 
    for y := 0 to h do begin 
      xs := m3; 
      xd := 0; 
      ps := src.scanline[y]; 
      while xd < m3 do begin 
        pd := dst.scanline[y + t^ div 6]; 
        if z then oben else begin 
          if (y = 0) and r then strich else begin 
            pd[xd] := setbyte(ps[xs] - d); 
            pd[xd + 1] := setbyte(ps[xs + 1] - d); 
            pd[xd + 2] := setbyte(ps[xs + 2] - d); 
          end; 
        end; 
        dec(xs, 3); 
        inc(xd, 3); 
      end; 
    end; 
  end; 
  procedure rechts(h, t, d, w: integer; z, r: boolean); 
  var 
    y: integer; 
  begin 
    for y := 0 to h do begin 
      xs := w3; 
      xd := m3; 
      ps := src.scanline[y]; 
      while xd < b3 do begin 
        if w < 0 then 
          pd := dst.scanline[y + xd div 6 - schmal] else 
          pd := dst.scanline[y - xd div 6 + mass]; 
        if z then oben else begin 
          if ((xd = m3) or (y = 0) and r) and (rand <> nil) then strich 
          else begin 
            pd[xd] := setbyte(ps[xs] - d); 
            pd[xd + 1] := setbyte(ps[xs + 1] - d); 
            pd[xd + 2] := setbyte(ps[xs + 2] - d); 
          end; 
        end; 
        dec(xs, 3); 
        inc(xd, 3); 
      end; 
    end; 
  end; 
begin 
  result := point(0, 0); 
  try 
    if (src = nil) or (src.width < 24) 
      or (src.width / src.height > 3) 
      then exit; 
    schmal := src.width div 8; 
    breit := src.width div 2; 
    mass := src.width div 4; 
    if zeichnen then begin 
      dst.width := breit; 
      dst.height := src.height + schmal; 
      if rand <> nil then begin 
        rand^ := ColorToRGB(rand^); 
        r := getrvalue(rand^); 
        g := getgvalue(rand^); 
        b := getbvalue(rand^); 
      end; 
      if zu <> nil then begin 
        zu^ := ColorToRGB(zu^); 
        rz := getrvalue(zu^); 
        gz := getgvalue(zu^); 
        bz := getbvalue(zu^); 
      end; 
      src.pixelformat := pf24bit; 
      dst.pixelformat := pf24bit; 
      w3 := src.width * 3 - 3; 
      m3 := mass * 3; 
      b3 := breit * 3; 
      with dst.canvas do begin 
        brush.color := grund; 
        fillrect(cliprect); 
      end; 
      if not variante then begin 
        gerade(schmal, 0, lus, zu <> nil, false); 
        links(src.height - 1, -(lus div 2), @xd, false, rand <> nil); 
        rechts(src.height - 2, schmal, 0, 1, false, true); 
      end else begin 
        links(schmal, lus, @xs, zu <> nil, false); 
        rechts(schmal, 0, lus, -1, zu <> nil, false); 
        gerade(src.height - 1, schmal, 0, false, rand <> nil); 
      end; 
    end; 
    result := point(breit, src.height + schmal); 
  except 
  end; 
end; 
 
function calculateTriangle(src: TBitmap): TPoint; 
begin 
  result := mach3(bm, nil, 0, nil, nil, false, 0, false); 
end; 
 

// ---------- Beispiele ---------- 
 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  pr, pg: pc; 
  c, g: TColor; 
  p: TPoint; 
begin 
// Beispiel 1 
  pr := @c; 
  c := $33CF33; 
  if mach3(bm, triangle, color, pr, nil, false, 75).x > 0 then 
    canvas.draw(20, 30, triangle) else 
    showmessage('Fehler 1'); 
// Beispiel 2 
  pg := @g; 
  g := clgreen; 
  if mach3(bm, triangle, color, nil, pg, true, 0).x > 0 then 
    canvas.draw(280, 30, triangle) else 
    showmessage('Fehler 2'); 
// Beispiel 3 (nur Abmaße abfragen) 
  p := CalculateTriangle(bm); 
  if p.x = 0 then showmessage('Fehler') else 
    showmessage('Zielbitmap hat ' + inttostr(p.x) + ' x ' + 
      inttostr(p.y) + ' Pixel'); 
end;