{
   Autor: Michael Springwald
   Ertellt am 20.Oktober.2008
   Änderungen
   ------------------------------------------------------------------
01 -                                -                               -
   ------------------------------------------------------------------
02 -                                -                               -
   ------------------------------------------------------------------
03 -                                -                               -
   ------------------------------------------------------------------
04 -                                -                               -
   ------------------------------------------------------------------
05 -                                -                               -
   ------------------------------------------------------------------
}

unit uGradient;

{$mode objfpc}{$H+}

interface


uses
  Classes, SysUtils,opbitmap,Graphics,lazbridge,LCLType,LCLProc,LCLIntf,
  Dialogs
  ;

type
   Pint64Array = ^Tint64Array;
   Tint64Array = Array[0..32767] of int64;

   unschaerfe = 0..20;
   ausschlag = -20..20;
   shp = (shp_Diagonal=0, shp_Dreieck=1, shp_Diamant=2, shp_Linse=3);
   rgbarray = array[0..2] of byte;
   argbarray = array of rgbarray;

   procedure GradientA(ACanvas: TCanvas; aW, AH:Integer; aColor1, aColor2: TColor; art: shp);
   procedure GradientB(ACanvas: TCanvas; Rect: TRect; Horicontal: Boolean; Colors: array of TColor);
   procedure GradientC(ACanvas:TCanvas;  x, y, breit, hoch: integer; ar: array of TColor; Winkel: Single);
   procedure GradientD(aCanvas:TCanvas; x, y, aw, ah: integer; oben, unten: array of TColor);

   procedure MosaikGradient(ca:TCanvas; F1, F2: TColor; stufewaag, stufesenk: byte);

implementation

// ----------------------------------------------------------------------------
procedure GradientA(ACanvas: TCanvas; aW, AH:Integer; aColor1, aColor2: TColor; art: shp);
var
  x, y, h, w, w3: integer;
  p: PByteArray;
  ri, gi, bi: byte;
  ra, ga, ba: word;
  rd, gd, bd, a, d: single;
  op:TCanvasOPBitmap;
begin
  op:=TCanvasOPBitmap.create;
  op.Width:=aW;
  op.Height:=aH;
  op.pixelformat := Opbitmap.pf24bit;
  if art = shp_Diamant then
    h := op.height shr 1
  else h := op.height - 1;
  if art <> shp_Diagonal then
    w := op.width shr 1 else
    w := op.width;
  w3 := w * 3;
  aColor1 := colortorgb(aColor1);
  aColor2 := colortorgb(aColor2);

  ra := getrvalue(aColor1); ga := getgvalue(aColor1); ba := getbvalue(aColor1);
  ri := getrvalue(aColor2); gi := getgvalue(aColor2); bi := getbvalue(aColor2);
  rd := ri - ra; gd := gi - ga; bd := bi - ba;

  inc(ra, ra); inc(ga, ga); inc(ba, ba);

  for y := 0 to h do begin
    p := op.scanline[y];
    a := y / h;
    if art = shp_Linse then a := sin(pi * a);
    x := 0;

    while x < w3 do begin
      d := a + x / w3;
      p^[x] := (trunc((ba + bd * d) / 2));
      p^[x + 1] := trunc((ga + gd * d) / 2);
      p^[x + 2] := trunc((ra + rd * d) / 2);
      inc(x, 3);
    end;
  end;

  //stretchblt muss ersetzt werden:
  if art <> shp_Diagonal then begin
   for y := 0 to h do
    for x := 0 to w do
      op.Pixels[w+w-x-1,y]:=op.Pixels[x,y];
  end;

  if art = shp_Diamant then begin
   for y := 0 to h do
     for x := 0 to op.width do
       op.Pixels[x,h+h-y-1]:=op.Pixels[x,y];
  end;

  AssignOpBitmapToCanvas(op,ACanvas,0,0);
  op.free;
end; // GradientA

// ----------------------------------------------------------------------------
procedure GradientB(ACanvas: TCanvas; Rect: TRect; Horicontal: Boolean; Colors: array of TColor);
type
  RGBArray = array[0..2] of Byte;
var
  x, y, z, stelle, mx, bis, faColorsh, mass: Integer;
  Faktor: double;
  A: RGBArray;
  B: array of RGBArray;
  merkw: integer;
  merks: TPenStyle;
  merkp: TColor;
begin
  mx := High(Colors);
  if mx > 0 then
  begin
    if Horicontal then
      mass := Rect.Right - Rect.Left
    else
      mass := Rect.Bottom - Rect.Top;
    SetLength(b, mx + 1);
    for x := 0 to mx do
    begin
      Colors[x] := ColorToRGB(Colors[x]);
      b[x][0] := GetRValue(Colors[x]);
      b[x][1] := GetGValue(Colors[x]);
      b[x][2] := GetBValue(Colors[x]);
    end;
    merkw := ACanvas.Pen.Width;
    merks := ACanvas.Pen.Style;
    merkp := ACanvas.Pen.Color;
    ACanvas.Pen.Width := 1;
    ACanvas.Pen.Style := psSolid;
    faColorsh := Round(mass / mx);
    for y := 0 to mx - 1 do
    begin
      if y = mx - 1 then
        bis := mass - y * faColorsh - 1
      else
        bis := faColorsh;
      for x := 0 to bis do
      begin
        Stelle := x + y * faColorsh;
        faktor := x / bis;
        for z := 0 to 3 do
          a[z] := Trunc(b[y][z] + ((b[y + 1][z] - b[y][z]) * Faktor));
        ACanvas.Pen.Color := RGB(a[0], a[1], a[2]);
        if Horicontal then
        begin
          ACanvas.MoveTo(Rect.Left + Stelle, Rect.Top);
          ACanvas.LineTo(Rect.Left + Stelle, Rect.Bottom);
        end
        else
        begin
          ACanvas.MoveTo(Rect.Left, Rect.Top + Stelle);
          ACanvas.LineTo(Rect.Right, Rect.Top + Stelle);
        end;
      end;
    end;
    b := nil;
    ACanvas.Pen.Width := merkw;
    ACanvas.Pen.Style := merks;
    ACanvas.Pen.Color := merkp;
  end
  else
    // Please specify at least two colors
    raise EMathError.Create('Es müssen mindestens zwei Farben angegeben werden.');
end; // GradientB

// ----------------------------------------------------------------------------
procedure GradientC(ACanvas:TCanvas; x, y, breit, hoch: integer; ar: array of TColor; Winkel: Single);
var
//  bmp: TBitmap;
  o, w, h, j, c, z, v, br, fo: integer;
  ao: array of array[0..2] of byte;
  p: PBytearray;
  bmp:TCanvasOPBitmap;
  procedure rgbermitteln;
  var
    i: integer;
  begin
    for i := 0 to o do begin
      ar[i] := colortorgb(ar[i]);
      ao[i][2] := getrvalue(ar[i]);
      ao[i][1] := getgvalue(ar[i]);
      ao[i][0] := getbvalue(ar[i]);
    end;
    for i := 0 to 2 do
      ao[o + 1][i] := ao[0][i];
  end;
  function rechnen: byte;
  begin
    result := trunc(ao[j][z] + (ao[j + 1][z] - ao[j][z]) * (w / fo));
  end;
begin
  if (breit > 1) and (hoch > 1) then begin
    if (Winkel >= -45) and (Winkel <= 45) then begin
      bmp:=TCanvasOPBitmap.create;
      bmp.Width:=breit;
      bmp.Height:=hoch;
      bmp.pixelformat := Opbitmap.pf24bit;

      o := high(ar);
      if (o > 0) and (o < 8) then begin
//        bmp := TBitmap.create;
  //      bmp.pixelformat := pf24bit;
        Winkel := -Winkel / 45;
        fo := round(breit / o + 1.3333) * 3;
        bmp.width := breit;
        bmp.height := hoch;
        br := breit * 3;
        setlength(ao, o + 2);
        rgbermitteln;
        for h := 0 to hoch - 1 do begin
          p := bmp.scanline[h];
          for j := 0 to o do begin
            w := 0;
            while w < fo do begin
              c := j * fo + w + round(h * Winkel) * 3;
              v := br + fo + o * 3;
              while c < 0 do inc(c, v);
              while c >= v do dec(c, v);
              if c < br then
                for z := 0 to 2 do
                  p^[c + z] := rechnen;
              inc(w, 3);
            end;
          end;
        end;
//        bitblt(dc, x, y, breit, hoch, bmp.canvas.handle, 0, 0, srccopy);
  //      bmp.free;
        AssignOpBitmapToCanvas(bmp,ACanvas,0,0);
        bmp.free;

      end else showmessage('Anzahl der Farben ungültig!');
    end else showmessage('Der Winkel muss zwischen -45.0 und +45.0 liegen!');
  end else showmessage('Abmaße zu gering!');
end; // GradientC

// ----------------------------------------------------------------------------
procedure GradientD(aCanvas:TCanvas; x, y, aw, ah: integer; oben, unten: array of TColor);
var
  b1, b2: rgbarray;
  o, u, w, h, j, c, z, fo: integer;
  ao: argbarray;
  au: argbarray;
  p: PByteArray;
  bmp:TCanvasOPBitmap;

  procedure rgbermitteln(at: array of TColor; ar: argbarray; k: integer);
  var i: integer;
  begin
    for i := 0 to k do begin
      at[i] := colortorgb(at[i]);
      ar[i][2] := getrvalue(at[i]);
      ar[i][1] := getgvalue(at[i]);
      ar[i][0] := getbvalue(at[i]);
    end;
  end;
  function rechnen(ar: argbarray): byte;
  begin
    result := trunc(ar[j][z] + (ar[j + 1][z] - ar[j][z]) * (w / fo));
  end;
begin
  bmp:=TCanvasOPBitmap.create;
  bmp.Width:=aW;
  bmp.Height:=aH;
  bmp.pixelformat := Opbitmap.pf24bit;

  o  := high(oben);
  u := high(unten);
  if o = u then begin
    if o > 0 then begin
      bmp.width := aW;
      bmp.height := aH;
      setlength(ao, o + 1);
      setlength(au, u + 1);
      rgbermitteln(oben, ao, o);
      rgbermitteln(unten, au, u);
      fo := trunc(aW / o + 1) * 3;
      for h := 0 to aH - 1 do begin
//        bmp.
        p := bmp.scanline[h];
        for j := 0 to o do begin
          w := 0;
          while w <= fo - 1 do begin
            c := j * fo + w;
            if c <= aW * 3 - 1 then begin
              for z := 0 to 2 do begin
                b1[z] := rechnen(ao);
                b2[z] := rechnen(au);

                p^[c + z] := trunc(b1[z] + (b2[z] - b1[z]) * (h / aH));
              end;
            end;
            inc(w, 3);
          end;
        end;
      end;
    //  bitblt(dc, x, y, breit, hoch, bmp.canvas.handle, 0, 0, srccopy);
      AssignOpBitmapToCanvas(bmp,ACanvas,0,0);
      bmp.free;

    end else showmessage('Es müssen mindestens zwei Farben angegeben werden!');
  end else
    showmessage('Die Anzahl der Farben muss oben und unten gleich sein!');
end; // GradientD

// ----------------------------------------------------------------------------
procedure MosaikGradient(ca:TCanvas; F1, F2: TColor; stufewaag, stufesenk: byte);
var
  r1, g1, b1: byte;
  vh, vw, uh, uw, fh, fw, i, j: integer;
  rj, gj, bj, ri, bi, gi, drh, dgh, dbh, drw, dgw, dbw: single;
begin
  if (ca.height > 1) and (ca.width > 1) then begin
    ca.FillRect(0,0,ca.Width,ca.Height);
    if (stufesenk > ca.height) or (stufesenk < 2) then stufesenk := ca.height;
    if (stufewaag > ca.width) or (stufewaag < 2) then stufewaag := ca.width;
    vh := pred(stufesenk);
    vw := pred(stufewaag);
    fh := round(ca.height / stufesenk);
    fw := round(ca.width / stufewaag);
    F1 := ColorToRGB(F1);
    F2 := ColorToRGB(F2);
    r1 := getrvalue(F1);
    g1 := getgvalue(F1);
    b1 := getbvalue(F1);
    drh := (getrvalue(F2) - r1) / vh;
    dgh := (getgvalue(F2) - g1) / vh;
    dbh := (getbvalue(F2) - b1) / vh;
    drw := (getrvalue(F2) - r1) / vw;
    dgw := (getgvalue(F2) - g1) / vw;
    dbw := (getbvalue(F2) - b1) / vw;
    for i := 0 to vw do begin
      ri := r1 + i * drw;
      gi := g1 + i * dgw;
      bi := b1 + i * dbw;
      if i = vw then uw := ca.width else
        uw := succ(i) * fw;
      with ca do begin
        for j := 0 to vh do begin
          rj := r1 + j * drh;
          gj := g1 + j * dgh;
          bj := b1 + j * dbh;
          brush.color := RGB(round((rj + ri) / 2), round((gj + gi) / 2),
            round((bj + bi) / 2));
          if j = vh then uh := ca.height else
            uh := succ(j) * fh;
          fillrect(rect(i * fw, j * fh, uw, uh));
        end;
      end;
    end;
  end;
end; // MosaikGradient

end.