unit ucanvasextras;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils,Graphics,types,lcltype,lclintf,IntfGraphics,dialogs;

implementation
type
  unschaerfe = 0..20;
  ausschlag = -20..20;
  shp = (Diagonal=0, Dreieck=1, Diamant=2, Linse=3);
  rgbarray = array[0..2] of byte;
  argbarray = array of rgbarray;


function trunc1(value:Real):byte;
var
  w:Integer;
begin
  w:=trunc(value);
  result:=Byte(w);
end;

procedure farbverlauf
  (bmp:TBitmap;dc: HDC; x, y, breit, hoch: 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;
  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.pixelformat := pf24bit;
  o  := high(oben);
  u := high(unten);
  if o = u then begin
    if o > 0 then begin
      bmp.width := breit;
      bmp.height := hoch;
      setlength(ao, o + 1);
      setlength(au, u + 1);
      rgbermitteln(oben, ao, o);
      rgbermitteln(unten, au, u);
      fo := trunc(breit / o + 1) * 3;
      for h := 0 to hoch - 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 <= breit * 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 / hoch))));
              end;
            end;
            inc(w, 3);
          end;
        end;
      end;
      bitblt(dc, x, y, breit, hoch, bmp.canvas.handle, 0, 0, srccopy);
    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;

procedure farbverlauf1
  (dc: HDC; 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;
  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
      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;
      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;


procedure verlauf(bm: TBitmap; farbe1, farbe2: 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;
begin
  bm.pixelformat := pf24bit;
  if art = Diamant then
    h := bm.height shr 1
  else h := bm.height - 1;
  if art <> Diagonal then
    w := bm.width shr 1 else
    w := bm.width;
  w3 := w * 3;
  farbe1 := colortorgb(farbe1);
  farbe2 := colortorgb(farbe2);
  ra := getrvalue(farbe1);
  ga := getgvalue(farbe1);
  ba := getbvalue(farbe1);
  ri := getrvalue(farbe2);
  gi := getgvalue(farbe2);
  bi := getbvalue(farbe2);
  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 := bm.scanline[y];
    a := y / h;
    if art = 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;
  if art <> Diagonal then
    stretchblt(bm.canvas.handle, w, 0, w + 1, h + 1,
      bm.canvas.handle, w - 1, 0, -w, h, SRCCOPY);
  if art = Diamant then
    stretchblt(bm.canvas.handle, 0, h + 1, bm.width, h,
      bm.canvas.handle, 0, h, bm.width, -h, SRCCOPY);
end;

procedure MosaikVerlauf(bm: TBitmap; 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 (bm.height > 1) and (bm.width > 1) then begin
    if (stufesenk > bm.height) or (stufesenk < 2) then stufesenk := bm.height;
    if (stufewaag > bm.width) or (stufewaag < 2) then stufewaag := bm.width;
    vh := pred(stufesenk);
    vw := pred(stufewaag);
    fh := round(bm.height / stufesenk);
    fw := round(bm.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 := bm.width else
        uw := succ(i) * fw;
      for j := 0 to vh do begin
        with bm.canvas 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 := bm.height else
            uh := succ(j) * fh;
          fillrect(rect(i * fw, j * fh, uw, uh));
        end;
      end;
    end;
  end;
end;

procedure RotateFont(cnv: TCanvas; Winkel: integer);
var
  Logfont: TLogFont;
begin
  GetObject(cnv.Font.Handle, sizeof(Logfont), @Logfont);
  Logfont.lfEscapement := winkel * 10;
  Logfont.lfOrientation := Logfont.lfEscapement;
  cnv.Font.Handle := CreateFontIndirect(Logfont);
end;

procedure WaveTextOut(cnv: TCanvas; x, y: integer;
  amplitude: ausschlag; txt: string);
var
  a, i, j, z, lg: integer;
  s: TSize;
begin
  lg := length(txt);
  if lg = 0 then exit;
  a := abs(amplitude);
  with cnv do begin
    s := TextExtent(txt);
    fillrect(rect(x - 2, y - a, x + s.cx + 2, y + s.cy + a));
    z := y;
    j := 2;
    moveto(x, y);
    for i := 0 to lg - 1 do begin
      if txt[i + 1] <> #32 then
        z := trunc(y + sin(i - j) * amplitude) else inc(j);
      textout(penpos.x, z, txt[i + 1]);
    end;
  end;
end;

function SchattenSchrift
  (cnv: TCanvas; txt, fontname: string; fontsize: integer;
  fontstyle: TFontstyles; x, y, xversatz, yversatz: integer;
  fontfarbe: array of TColor; schattenfarbe: TColor;
  unscharf: unschaerfe; var rct: TRect;pbrush:Tbrush): boolean;
var
  sz: TSize;
  bm: TBitmap;
  p: array[0..2] of PBytearray;
  xv, yv, i, j, k, w, z, li, lg, ob, vd2, txtl, txto: integer;
  tempColor,a:Array of TColor;
begin
  result := false;
  lg := length(fontfarbe);
  if lg = 0 then begin
    lg:=length(txt)-1;
    SetLength(tempColor,2);
    for i:=0 to lg do
      tempColor[i]:=rgb(random(255),random(255),random(255));
    a:=tempColor;
  end
  else begin
    SetLength(a,high(fontfarbe)+1);
    for i:=0 to high(fontfarbe) do
    a[i]:=fontfarbe[i];
  end;


  if (lg = 0) or (txt = '') then exit;
  vd2 := unscharf shr 1;
  xv := abs(xversatz);
  yv := abs(yversatz);
  li := ord(xversatz > 0) * xversatz + vd2 + 1;
  ob := ord(yversatz > 0) * yversatz;
  txtl := 1 + vd2 + ord(xversatz < 0) * xv;
  txto := vd2 + ord(yversatz < 0) * yv;
  dec(x, txtl);
  dec(y, txto);
  bm := TBitmap.create;
  bm.pixelformat := pf24bit;
  with bm.canvas do begin
    font.name := fontname;
    font.color := schattenfarbe;
    font.size := fontsize;
    font.style := fontstyle;
    sz := Textextent(txt);
    bm.width := 1 + unscharf + sz.cx + xv;
    bm.height := 1 + unscharf + sz.cy + yv;
    brush:=pbrush;
    rct := rect(x, y, x + bm.width, y + bm.height);
    bm.canvas.copyrect(rect(0, 0, bm.width, bm.height), cnv, rct);
    textout(li, ob + vd2, txt);
    for k := 1 to unscharf do
      for j := ob + 1 to ob + sz.cy + vd2 do begin
        for w := 0 to 2 do
          p[w] := bm.scanline[j - 1 + w];
        for i := li to li + sz.cx - 1 do begin
          z := i * 3;
          for w := 0 to 2 do
            p[1][z + w] := round((p[0][z + w] + p[2][z + w] +
              p[1][(i - 1) * 3 + w] + p[1][(i + 1) * 3 + w]) / 4);
        end;
      end;
    font.color := a[0];
    textout(txtl, txto, txt[1]);
    for i := 1 to length(txt) - 1 do begin
      if lg > i then font.color := a[i];
      textout(penpos.x, txto, txt[i + 1]);
    end;
  end;
  cnv.draw(x, y, bm);
  bm.free;
  result := true;
end;

procedure DrawGradient(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;

end.