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.