//Tomasz Lubiński (C)2009
// http://www.algorytm.org
//Patterning - technika mikrowzorcow

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Image1: TImage;
    Label1: TLabel;
    Image2: TImage;
    Label2: TLabel;
    Label4: TLabel;
    Edit1: TEdit;
    Button1: TButton;
    UpDown1: TUpDown;
    Label6: TLabel;
    dispersed: TRadioButton;
    cluster: TRadioButton;
    procedure Button1Click(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;

var
  Form1: TForm1;

  pattern : array [0..1] of array [0..2] of array [0..2] of Byte =
  (
     (
        (8, 3, 4),
        (6, 1, 2),
        (7, 5, 9)
     ),
     (
        (1, 7, 4),
        (5, 8, 3),
        (6, 2, 9)
     )
  );

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var i,j,k,l,choosenPattern: Integer;
    p: Real;
    pixelOrg, pixelNew: PPixelRec;
    white, black: TPixelRec;
begin

//przygotuj wartosci bialy i czarny
white.B := 255;
white.G := 255;
white.R := 255;
black.B := 0;
black.G := 0;
black.R := 0;

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

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

//pobierz prog
p := StrToInt(Form1.Edit1.Text) / 9;

//pobierz wybrany wzorzec
if (cluster.Checked = true) then
        choosenPattern := 0
else
        choosenPattern := 1;

//zwykle progowe
for j:=0 to Image1.Height-1 do
begin
        for k:=0 to 2 do
        begin
                pixelOrg := Image1.Picture.Bitmap.ScanLine[j];
                pixelNew := Image2.Picture.Bitmap.ScanLine[j*3 + k];
                for i:=0 to Image1.Width-1 do
                begin
                        for l:=0 to 2 do
                        begin
                                if (p * pattern[choosenPattern, k, l] > pixelOrg.r) then
                                        pixelNew^ := black
                                else
                                        pixelNew^ := white;
                                Inc(pixelNew);
                        end;
                        Inc(pixelOrg);
                end;
        end;
end;
end;

// http://www.algorytm.org link
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.