algorytm.org

Implementacja w Delphi/Pascal



Baza Wiedzy
wersja offline serwisu przeznaczona na urządzenia z systemem Android
Darowizny
darowiznaWspomóż rozwój serwisu
Nagłówki RSS
Artykuły
Implementacje
Komentarze
Forum
Bookmarki






Sonda
Implementacji w jakim języku programowania poszukujesz?

Dithering dla obrazów kolorowych - Implementacja w Delphi/Pascal
Ocena użytkownikóww: *****  / 1
SłabyŚwietny
Nadesłany przez Tomasz Lubiński, 30 lipca 2009 01:00
Kod przedstawiony poniżej przedstawia główną część rozwiązania problemu.
Pobierz pełne rozwiązanie.

Jeżeli nie odpowiada Ci sposób formatowania kodu przez autora skorzystaj z pretty printer'a i dostosuj go automatycznie do siebie.

Dithering - Delphi/Unit1.pas:
//Tomasz Lubiński (C) 2009
// www.algorytm.org
//Algorytmy Ditheringu

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, ComCtrls, SHELLAPI;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Label1: TLabel;
    Image2: TImage;
    Image3: TImage;
    Label2: TLabel;
    Label3: TLabel;
    Button1: TButton;
    GroupBox1: TGroupBox;
    Label4: TLabel;
    Shape1: TShape;
    Shape2: TShape;
    Shape3: TShape;
    Shape4: TShape;
    Shape5: TShape;
    Shape6: TShape;
    Shape7: TShape;
    Shape8: TShape;
    Shape9: TShape;
    Shape10: TShape;
    Shape11: TShape;
    Shape12: TShape;
    Shape13: TShape;
    Shape14: TShape;
    Shape15: TShape;
    Shape16: TShape;
    UpDown1: TUpDown;
    Edit1: TEdit;
    ColorDialog1: TColorDialog;
    Label5: TLabel;
    ComboBox1: TComboBox;
    Label6: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure Edit1Change(Sender: TObject);
    procedure Shape1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormCreate(Sender: TObject);
    procedure Label6Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;


  PPixelRec = ^TPixelRec;
  TPixelRec = packed record
    B: Byte;
    G: Byte;
    R: Byte;
    Reserved: Byte;
  end;

  TErrorTable =Array [-3..249] of Array [0..231] of Real;
  PErrorTable = ^TErrorTable;

var
  Form1: TForm1;
  eb, eg, er: TErrorTable;
  colors: Array [1..16] of TPixelRec;

  dif: Array[0..10] of Array [0..2] of Array [0..5] of Real =
(
   (
      (0,        0,        0,        0,        7.0/16.0, 0),
      (0,        0,        3.0/16.0, 5.0/16.0, 1.0/16.0, 0),
      (0,        0       , 0,        0,        0,        0)
   ),
   (
      (0,        0,        0,        0,        7.0/48.0, 5.0/48.0),
      (0,        3.0/48.0, 5.0/48.0, 7.0/48.0, 5.0/48.0, 3.0/48.0),
      (0,        1.0/48.0, 3.0/48.0, 5.0/48.0, 3.0/48.0, 1.0/48.0)
   ),
   (
      (0,        0,        0,        0,        8.0/42.0, 4.0/42.0),
      (0,        2.0/42.0, 4.0/42.0, 8.0/42.0, 4.0/42.0, 2.0/42.0),
      (0,        1.0/42.0, 2.0/42.0, 4.0/42.0, 2.0/42.0, 1.0/42.0)
   ),
   (
      (0,        0,        0,        0,        8.0/32.0, 4.0/32.0),
      (0,        2.0/32.0, 4.0/32.0, 8.0/32.0, 4.0/32.0, 2.0/32.0),
      (0,        0       , 0,        0,        0,        0)
   ),
   (
      (0,        0,        0,        0,        7.0/16.0, 0),
      (0,        1.0/16.0, 3.0/16.0, 5.0/16.0, 0,        0),
      (0,        0       , 0,        0,        0,        0)
   ),
   (
      (0,        0,        0,        0,        5.0/32.0, 3.0/32.0),
      (0,        2.0/32.0, 4.0/32.0, 5.0/32.0, 4.0/32.0, 2.0/32.0),
      (0,        0       , 2.0/32.0, 3.0/32.0, 2.0/32.0, 0)
   ),
   (
      (0,        0,        0,        0,        4.0/16.0, 3.0/16.0),
      (0,        1.0/16.0, 2.0/16.0, 3.0/16.0, 2.0/16.0, 1.0/16.0),
      (0,        0       , 0,        0,        0,        0)
   ),
   (
      (0,        0,        0,        0,        2.0/4.0,  0),
      (0,        0,        1.0/4.0,  1.0/4.0,  0,        0),
      (0,        0,        0,        0,        0,        0)
   ),
   (
      (0,        0,        0,        0,        1.0/8.0,  1.0/8.0),
      (0,        0,        1.0/8.0,  1.0/8.0,  1.0/8.0,  0),
      (0,        0,        0,        1.0/8.0,  0,        0)
   ),
   (
      (0,        0,        0,        0,        4.0/8.0,  0),
      (0,        1.0/8.0,  1.0/8.0,  2.0/8.0,  0,        0),
      (0,        0,        0,        0,        0,        0)
   ),
   (
      (0,        0,        0,        0,        8.0/16.0, 0),
      (1.0/16.0, 1.0/16.0, 2.0/16.0, 4.0/16.0, 0,        0),
      (0,        0,        0,        0,        0,        0)
   )
);

implementation

{$R *.DFM}

//---------------------------------------------------------------------------
//pobiera kolory zdefiniowane przez uzytkownika
procedure getColors();
var
   n, i: Integer;
begin

   for i:=0 to Form1.ComponentCount-1 do
   begin
      if (Pos('Shape', Form1.Components[i].Name) = 1) then
      begin
         n := StrToInt(Copy(Form1.Components[i].Name, 6, 2));
         colors[n].b := GetBValue(TShape(Form1.Components[i]).Brush.Color);
         colors[n].g := GetGValue(TShape(Form1.Components[i]).Brush.Color);
         colors[n].r := GetRValue(TShape(Form1.Components[i]).Brush.Color);
         colors[n].reserved := 0;
      end;
   end;
end;

//---------------------------------------------------------------------------
//znajduje kolor w palecie najblizszy zadanemu pikslowi
function findNearest(b: Real; g: Real; r: Real; cnt: Integer): Integer;
var
   i: Integer;
   d, tmp: Real;
begin
   d := (colors[1].b - b) * (colors[1].b - b);
   d := d + (colors[1].g - g) * (colors[1].g - g);
   d := d + (colors[1].r - r) * (colors[1].r - r);

   result := 1;

   for i:=2 to cnt do
   begin
      tmp := (colors[i].b - b) * (colors[i].b - b);
      tmp := tmp + (colors[i].g - g) * (colors[i].g - g);
      tmp := tmp + (colors[i].r - r) * (colors[i].r - r);

      if (d > tmp) then
      begin
         d := tmp;
         result := i;
      end;
   end;

end;
//---------------------------------------------------------------------------
//ucina podana wartosc do zakresu 0-255 (dopuszczalne wartosci dla piksla)
function clip(x: Real): Real;
begin
   if (x > 255) then result := 255
   else if (x < 0) then result := 0
   else result := x;
end;
//---------------------------------------------------------------------------
//propaguje blad do komorek sasiednich
procedure propagateError(alg: Integer; w: Real; e: PErrorTable; i: Integer; j: Integer);
begin
   e[i+1][j  ] := e[i+1][j  ] + (w*dif[alg][0][4]);
   e[i+2][j  ] := e[i+2][j  ] + (w*dif[alg][0][5]);

   e[i-3][j+1] := e[i-3][j+1] + (w*dif[alg][1][0]);
   e[i-2][j+1] := e[i-2][j+1] + (w*dif[alg][1][1]);
   e[i-1][j+1] := e[i-1][j+1] + (w*dif[alg][1][2]);
   e[i  ][j+1] := e[i  ][j+1] + (w*dif[alg][1][3]);
   e[i+1][j+1] := e[i+1][j+1] + (w*dif[alg][1][4]);
   e[i+2][j+1] := e[i+2][j+1] + (w*dif[alg][1][5]);

   e[i-3][j+2] := e[i-3][j+2] + (w*dif[alg][2][0]);
   e[i-2][j+2] := e[i-2][j+2] + (w*dif[alg][2][1]);
   e[i-1][j+2] := e[i-1][j+2] + (w*dif[alg][2][2]);
   e[i  ][j+2] := e[i  ][j+2] + (w*dif[alg][2][3]);
   e[i+1][j+2] := e[i+1][j+2] + (w*dif[alg][2][4]);
   e[i+2][j+2] := e[i+2][j+2] + (w*dif[alg][2][5]);
end;

procedure TForm1.Button1Click(Sender: TObject);
var i,j,cnt,alg: Integer;
    pixelOrg, pixelNew: PPixelRec;
begin

//przygotuj wartosci kolorow z palety
getColors();

//przygotuj obrazy wynikowe
Image2.Canvas.Brush.Color := clWhite;
Image2.Canvas.Rectangle(0, 0, Image2.Width, Image2.Height);
Image2.Picture.Bitmap.PixelFormat := pf32Bit;

Image3.Canvas.Brush.Color := clWhite;
Image3.Canvas.Rectangle(0, 0, Image3.Width, Image3.Height);
Image3.Picture.Bitmap.PixelFormat := pf32Bit;

//przygotuj format obrazu zrodlowego
Image1.Picture.Bitmap.PixelFormat := pf32Bit;

//pobierz liczbe kolorow i algorytm do uzycia
cnt := StrToInt(Form1.Edit1.Text);
alg := Form1.ComboBox1.ItemIndex;

//najblizsze sasiedztwo
for j:=0 to 229 do
begin
        pixelOrg := Image1.Picture.Bitmap.ScanLine[j];
        pixelNew := Image2.Picture.Bitmap.ScanLine[j];
        for i:=0 to 247 do
                begin
                pixelNew^ := colors[findNearest(pixelOrg.b, pixelOrg.g, pixelOrg.r, cnt)];
                Inc(pixelOrg);
                Inc(pixelNew);
                end;
end;

//dithering
for j:=0 to 231 do
        for i:=-2 to 249 do
                begin
                eb[i,j] := 0;
                eg[i,j] := 0;
                er[i,j] := 0;
                end;

for j:=0 to 229 do
begin
        pixelOrg := Image1.Picture.Bitmap.ScanLine[j];
        pixelNew := Image3.Picture.Bitmap.ScanLine[j];
        for i:=0 to 247 do
                begin
                pixelNew^ := colors[findNearest(clip(pixelOrg.b + eb[i,j]),
                                                clip(pixelOrg.g + eg[i,j]),
                                                clip(pixelOrg.r + er[i,j]), cnt)];

                propagateError(alg, clip(pixelOrg.b + eb[i,j]) - pixelNew.b , @eb, i, j);
                propagateError(alg, clip(pixelOrg.g + eg[i,j]) - pixelNew.g , @eg, i, j);
                propagateError(alg, clip(pixelOrg.r + er[i,j]) - pixelNew.r , @er, i, j);

                Inc(pixelOrg);
                Inc(pixelNew);
                end;
end;
end;

//---------------------------------------------------------------------------
//Pokazywanie i ukrywanie probek z palety barw
procedure TForm1.Edit1Change(Sender: TObject);
var
   cnt, n, i: Integer;
begin

   cnt := StrToInt(Edit1.Text);

   for i:=0 to Form1.ComponentCount-1 do
   begin
      if Pos('Shape', Components[i].Name) = 1 then
      begin
         n := StrToInt(Copy(Components[i].Name, 6, 2));
         if (n <= cnt) then TShape(Components[i]).Visible := true
            else TShape(Components[i]).Visible := false;
      end;
   end;
end;

//---------------------------------------------------------------------------
// Dialog umozliwiajacy zmiane palety barw
procedure TForm1.Shape1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
     if (ColorDialog1.Execute())  then
     begin
        TShape(Sender).Brush.Color := ColorDialog1.Color;
     end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
     Form1.ComboBox1.ItemIndex := 0;
end;

procedure TForm1.Label6Click(Sender: TObject);
begin
  with (Sender as Tlabel) do
 ShellExecute(Application.Handle,
             PChar('open'),
             PChar(Hint), 
             PChar(0),
             nil,
             SW_NORMAL);

end;

end.

Dodaj komentarz