ub1.pas

很经典的算法

{ Demo unit : Bezier curves and smothing algorithm
  Jean-Yves Queinec    [e-mail]

  Keywords : Bezier curves
             Smoothing algorithm with smooth factor
             square to circle transformation
             coloured flowers
}
unit UB1;

interface

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

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Button1: TButton;
    UpDown1: TUpDown;
    Edit1: TEdit;
    Label1: TLabel;
    UpDown2: TUpDown;
    Edit2: TEdit;
    Label2: TLabel;
    Button2: TButton;
    Button3: TButton;
    Image1: TImage;
    CheckBox1: TCheckBox;
    CheckBox2: TCheckBox;
    Panel2: TPanel;
    RadioGroup1: TRadioGroup;
    Panel3: TPanel;
    PaintBox1: TPaintBox;
    Panelcolo: TPanel;
    Panel4: TPanel;
    PaintBox2: TPaintBox;
    CheckBox3: TCheckBox;
    SpeedButton1: TSpeedButton;
    Panel5: TPanel;
    Memo1: TMemo;
    Button4: TButton;
    Button5: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure UpDown1Click(Sender: TObject; Button: TUDBtnType);
    procedure FormCreate(Sender: TObject);
    procedure UpDown2Click(Sender: TObject; Button: TUDBtnType);
    procedure FormDestroy(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure CheckBox2Click(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
    procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure RadioGroup1Click(Sender: TObject);
    procedure CheckBox1Click(Sender: TObject);
    procedure PaintBox2MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure PaintBox2Paint(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure PaintBox2MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
  private
    Bmpfond : Tbitmap;              { background bitmap with grid pattern  }

    Figure : integer;               { kingd of shape }
    cx, cy : integer;               { image centre }
    NB1 : longint;                  { Nunber of points }
    AA : array[0..64] of Tpoint;    { points  }
    NB2 : longint;                  { number of points used for Bezier curve  }
    BB : array[0..64*3] of Tpoint;  { points for Bezier curve}
    { polygon drawing }
    Anglepoly : single;             { angle regular polygon }
    Angles : array[0..64*3] of single; { memorize original angles }
    drawing : boolean;
    Startp : integer;      { current BB point (clic select) }
    Startangle : single;   { starting angle for current point }
    Startx : integer;
    Starty : integer;
    infoang  : array[0..2] of single;   { to draw a polygon }
    { colors }
    couleur : array[0..127] of Tcolor;

  public
    Procedure Affichage(lisser : boolean);
    procedure Dessin;
    procedure Quadrillage;
    procedure lissage(acoef: integer);
    procedure polygone;
    procedure sinusoide;
    procedure Lescouleurs;
    procedure setpipette(pstyle : boolean);
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}
const
  crpipette = 2;


{---- The Form ---}
procedure TForm1.FormCreate(Sender: TObject);
begin
  Screen.Cursors[crPipette] := LoadCursor(HInstance, 'PCURSEUR');
  drawing := false;
  lescouleurs;
  quadrillage;
  figure := 0;
  affichage(true);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Bmpfond.free;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  close;
end;

{---- Utility Fonctions ----------}
Function Egalpoints(pt1, pt2 : tpoint): boolean;
begin
  IF (pt1.x = pt2.x) AND (pt1.y = Pt2.y) then result := true
  else result := false;
end;

Function arctangente(ax, ay : integer) : single;
var
  symetrie : boolean;
  wx, wy : single;
begin
  if ax < 0 then symetrie := true else symetrie := false;
  wx :=  abs(ax);
  wy := -ay;
  IF wx < 0.001 then  { avoid zero divide }
  begin
    if wy < 0 then result := pi+pi/2 else result := pi/2;
  end
  else
  begin
    result := arctan(wy / wx);
    IF symetrie then result := pi - result;
  end;
end;

procedure Tform1.quadrillage;   // bmpfond grid pattern
var
  i : integer;
begin
  Bmpfond := tbitmap.create;
  Bmpfond.width   := image1.width;
  Bmpfond.height  := image1.height;
  with Bmpfond.canvas do
  begin
    brush.color := clwhite;
    fillrect(rect(0,0,Image1.width, Image1.height));
    cx := Image1.width div 2;
    cy := Image1.height div 2;
    for i := 1 to Image1.width div 10 do
    begin
      if i mod 5 = 0 then pen.color := $00B0E0FF else pen.color := $00F0F4FF;
      moveto(cx+i*5, 0); lineto(cx+i*5, Image1.height);
      moveto(cx-i*5, 0); lineto(cx-i*5, Image1.height);
    end;
    for i := 1 to Image1.height div 10 do
    begin
      if i mod 5 = 0 then pen.color := $00B0E0FF else pen.color := $00F0F4FF;
      moveto(0,cy+i*5); lineto(Image1.width,cy+i*5);
      moveto(0,cy-i*5); lineto(Image1.width,cy-i*5);
    end;
    pen.color:= $0080B0D0;
    moveto(0,cy); lineto(Image1.width,cy);
    moveto(cx,0); lineto(cx, Image1.height);
  end;
end;

{ Smoothing algorithm
  computes Bezier control points
  acoef is the smoothing factor
  Takes care of points 0 and NB2 when they are at the same
  location(closed curve) }
procedure TForm1.lissage(acoef: integer);
var
  i, j : integer;

  Function sym(a, b : integer): integer;  // symmmetry  b / a
  begin
    result := a - ((b-a)*acoef) div 100;
  end;
  Function mil(a, b : integer): integer;  // middle
  begin
    result := (a+b) div 2;
  end;

  // computes a control point position based on
  // symmetries of 2 adjacents points BB n-1 et BBn+1.
  Function ctrlpt(pt, pt1, pt2 : tpoint): tpoint;
  begin
    result.x := mil(mil(pt.x, pt1.x), mil(sym(pt.x, pt2.x), pt.x));
    result.y := mil(mil(pt.y, pt1.y), mil(sym(pt.y, pt2.y), pt.y));
  end;

begin
  // Computes control points
  For j := 1 to NB1-1 do  // points of the cource (edges) excluding end points
  begin
    i := j*3;        // range of point in the  BB array
    BB[i-1] := ctrlpt(BB[i], BB[i-3], BB[i+3]); // prior control point
    BB[i+1] := ctrlpt(BB[i], BB[i+3], BB[i-3]); // next control point
  end;
  IF egalpoints(BB[0], BB[NB2]) then
  begin   // closed curve
    BB[0+1]   := ctrlpt(BB[0], BB[3], BB[NB2-3]);
    BB[NB2-1] := ctrlpt(BB[NB2], BB[NB2-3], BB[3]);
  end
  else
  begin   // open curve
    BB[1]     := BB[0];    // "right" control point from 0
    BB[NB2-1] := BB[NB2];  // "lef" control point from NB2
  end;
end;

procedure TForm1.Affichage(lisser : boolean);
var
 i : integer;
begin
  Image1.canvas.draw(0,0,bmpfond);
  case figure of
    0 : polygone;
    1 : sinusoide;
  end;
  IF lisser then
  begin
    // copy the AA array points to BB array
    NB2 := NB1*3;
    for i := 0 to NB1 do
    begin
       BB[i*3] := AA[i]; // interval is 3 points
    end;
    lissage(Updown1.position);
    // memorize angular positions in order to keep good precision
    // during successive points displacements
    IF figure = 0 then for i := 0 to NB2 do
    begin
      Angles[i] := arctangente(BB[i].x-cx, BB[i].y-cy);
      if i < 3 then infoang[i] := Angles[i]; // memorize angles
    end;
  end;
  IF checkbox1.checked then
  begin
    with image1.canvas do
    begin
      pen.color := clsilver;
      polyline(slice(AA,NB1+1));
      pen.color := clblack;
    end;
  end;
  dessin;
end;

// Regular Polygon from number of points NB1
procedure Tform1.Polygone;
var
  i : integer;
  a1, b : single; // angle and radius
  cx, cy : integer;  // centre
begin
  cx := image1.width div 2;
  cy := image1.height div 2;