uutilsea.pas

这是一道很基本的程序

{ interface-based implementation of
  Dan Taylor's ([e-mail])
  Evolutionary TSP Algorithm demo program
Modified: September 2002
  by Nikolai Shokhirev ([e-mail])
  http://www.chem.arizona.edu/~shokhirn/index.html) }
{ type definitions }
unit uUtilsEA;

interface

uses
  classes, extctrls, controls, Graphics, Windows;

type

  TFloat = Double;

  TInt = Integer;

  ArrayInt = array of TInt;

  ArrayFloat = array of TFloat;

  TPoint2D = record
    X: TFloat;
    Y: TFloat;
  end;
  
// painting object, the base class for Display
  TPainter0 = class(TPaintBox)
  private
    fXmin: TFloat;
    fXmax: TFloat;
    fYmin: TFloat;
    fYmax: TFloat;
    fNXmin: TInt;
    fNXmax: TInt;
    fNYmin: TInt;
    fNYmax: TInt;
    fIWidth: TFloat;
    fIHeight: TFloat;
    fRWidth: TFloat;
    fRHeight: TFloat;
    fXYRatio: TFloat;
    fPPUX, fPPUY: TFloat;
    fBgColor: TColor; // used in Clear
    function GetXmin: TFloat;
    function GetXmax: TFloat;
    function GetYmin: TFloat;
    function GetYmax: TFloat;
    procedure SetXmin(const Value: TFloat);
    procedure SetXmax(const Value: TFloat);
    procedure SetYmin(const Value: TFloat);
    procedure SetYmax(const Value: TFloat);
    function GetXYRatio: TFloat;
    procedure SetXYRatio(const Value: TFloat);
    function GetPPUX: TFloat;
    function GetPPUY: TFloat;
    function GetBgColor: TColor;
    procedure SetBgColor(const Value: TColor);
    function GetBrushColor: TColor;
    function GetPenColor: TColor;
    procedure SetBrushColor(const Value: TColor);
    procedure SetPenColor(const Value: TColor);
    function GetPenWidth: TInt;
    procedure SetPenWidth(const Value: TInt);
  public
    constructor Create(aOwner: TComponent; aParent: TWinControl);
    destructor Destroy; override;
    procedure SetRanges(aXmin, aXmax, aYmin, aYmax, aXYRatio: TFloat);
    procedure SetPPU;
    procedure Clear;
    function rRect2iRect(x1, x2, y1, y2: TFloat): TRect;
    function rx2ix(x: TFloat): TInt;
    function ry2iy(y: TFloat): TInt;
    function ix2rx(ix: TInt): TFloat;
    function iy2ry(iy: TInt): TFloat;
    procedure MoveTo(x, y: TFloat);
    procedure LineTo(x, y: TFloat);
    procedure Line(x1, y1, x2, y2: TFloat);
    procedure Circle(x, y, r: TFloat);
    property Xmin: TFloat read GetXmin write SetXmin;
    property Xmax: TFloat read GetXmax write SetXmax;
    property Ymin: TFloat read GetYmin write SetYmin;
    property Ymax: TFloat read GetYmax write SetYmax;
    property PPUX: TFloat read GetPPUX;
    property PPUY: TFloat read GetPPUY;
    property XYRatio: TFloat read GetXYRatio write SetXYRatio;
    property BgColor: TColor read GetBgColor write SetBgColor;
    property PenColor: TColor read GetPenColor write SetPenColor;
    property PenWidth: TInt read GetPenWidth write SetPenWidth;
    property BrushColor: TColor read GetBrushColor write SetBrushColor;
  end;
  
implementation

uses
  Math;

{ Painter0 }

constructor TPainter0.Create(aOwner: TComponent; aParent: TWinControl);
begin
  inherited Create(aOwner);
  Parent := aParent;
  Align := alClient;
end;

procedure TPainter0.SetRanges(aXmin, aXmax, aYmin, aYmax, aXYRatio: TFloat);
begin
  fXmin := aXmin;
  fXmax := aXmax;
  fYmin := aYmin;
  fYmax := aYmax;
  fXYRatio := aXYRatio;
  SetPPU;
end;

destructor TPainter0.Destroy;
begin
  inherited;
  //
end;

procedure TPainter0.SetPPU;
begin
  fIWidth := ClientWidth;
  fIHeight := ClientHeight;
  fRWidth := fXmax-fXmin;
  fRHeight := fYmax-fYmin;
  fNXmin := 0;
  fNXmax := ClientWidth-1;
  fNYmin := 0;
  fNYmax := ClientHeight-1;
  if fXYRatio > 0 then
    if(1.0 > fRWidth*fIHeight*fXYRatio/fRHeight/fIWidth) then
    begin
      fPPUY := fIHeight/fRHeight;
      fPPUX := fPPUY*fXYRatio;
      fNXmin := (ClientWidth-round(fPPUX*fRWidth)) div 2;
      fNXmax := ClientWidth - fNXmin - 1;
    end else
    begin
      fPPUX := fIWidth/fRWidth;
      fPPUY := fPPUX/fXYRatio;
      fNYmin := (ClientHeight-round(fPPUY*fRHeight)) div 2;
      fNYmax := ClientHeight - fNYmin - 1;
    end
  else
  begin
    fPPUX := fIWidth/fRWidth;
    fPPUY := fIHeight/fRHeight;
  end;
end;

function TPainter0.GetXYRatio: TFloat;
begin
  result := fXYRatio;
end;

procedure TPainter0.SetXYRatio(const Value: TFloat);
begin
  fXYRatio := Value;
  SetPPU;
end;

function TPainter0.GetPPUX: TFloat;
begin
  result := fPPUX;
end;

function TPainter0.GetPPUY: TFloat;
begin
  result := fPPUY;
end;

function TPainter0.rRect2iRect(x1, x2, y1, y2: TFloat): TRect;
begin
  result := Rect(rx2ix(x1), ry2iy(y2), rx2ix(x2), ry2iy(y1));
end;

function TPainter0.rx2ix(x: TFloat): TInt;
begin
  result := fNXmin + round(PPUX*(x-fXmin));
end;

function TPainter0.ry2iy(y: TFloat): TInt;
begin
  result := fNYmax - round(PPUY*(y-fYmin));
end;

function TPainter0.ix2rx(ix: TInt): TFloat;
begin
  result := fXmin + (ix-fNXmin)/fPPUX;
end;

function TPainter0.iy2ry(iy: TInt): TFloat;
begin
  result := fYmin + (fNYmax-iy)/fPPUY;
end;

function TPainter0.GetXmin: TFloat;
begin
  result := fXmin;
end;

function TPainter0.GetXmax: TFloat;
begin
  result := fXmax;
end;

function TPainter0.GetYmin: TFloat;
begin
  result := fYmin;
end;

function TPainter0.GetYmax: TFloat;
begin
  result := fYmax;
end;

procedure TPainter0.SetXmin(const Value: TFloat);
begin
  fXmin := Value;
  SetPPU;
end;

procedure TPainter0.SetXmax(const Value: TFloat);
begin
  fXmax := Value;
  SetPPU;
end;

procedure TPainter0.SetYmin(const Value: TFloat);
begin
  fYmin := Value;
  SetPPU;
end;

procedure TPainter0.SetYmax(const Value: TFloat);
begin
  fYmax := Value;
  SetPPU;
end;

procedure TPainter0.LineTo(x, y: TFloat);
begin
  with Canvas do
    LineTo(rx2ix(x),ry2iy(y));
end;

procedure TPainter0.MoveTo(x, y: TFloat);
begin
  with Canvas do
    MoveTo(rx2ix(x),ry2iy(y));
end;

procedure TPainter0.Line(x1, y1, x2, y2: TFloat);
begin
  with Canvas do
  begin
    MoveTo(rx2ix(x1),ry2iy(y1));
    LineTo(rx2ix(x2),ry2iy(y2));
  end;
end;

procedure TPainter0.Circle(x, y, r: TFloat);
var
  ix, iy, irx, iry: TInt;
begin
  ix := rx2ix(x);
  iy := ry2iy(y);
  irx := round(r*PPUX);
  iry := round(r*PPUY);
  with Canvas do
  begin
    Ellipse(ix-irx,iy-iry,ix+irx,iy+iry);
  end;
end;

procedure TPainter0.Clear;
begin
  with Canvas do
  begin
    Brush.Color := fBgColor;
    FillRect(Parent.ClientRect);
  end;
end;

function TPainter0.GetBgColor: TColor;
begin
  result := fBgColor;
end;

procedure TPainter0.SetBgColor(const Value: TColor);
begin
  fBgColor := Value
end;

function TPainter0.GetBrushColor: TColor;
begin
  result := Canvas.Brush.Color;
end;

function TPainter0.GetPenColor: TColor;
begin
  result := Canvas.Pen.Color;
end;

procedure TPainter0.SetBrushColor(const Value: TColor);
begin
  Canvas.Brush.Color := Value;
end;

procedure TPainter0.SetPenColor(const Value: TColor);
begin
  Canvas.Pen.Color := Value;
end;

function TPainter0.GetPenWidth: TInt;
begin
  result := Canvas.Pen.Width;
end;

procedure TPainter0.SetPenWidth(const Value: TInt);
begin
  Canvas.Pen.Width := Value;
end;

end.