1  unit YogenTeiriU;
   2   
   3  interface
   4   
   5  uses
   6    Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   7    Dialogs, ExtCtrls, StdCtrls;
   8   
   9  type
  10    TFormMain = class(TForm)
  11      PanelMain: TPanel;
  12      ButtonClose: TButton;
  13      ImageMain: TImage;
  14      procedure ButtonCloseClick(Sender: TObject);
  15      procedure FormCreate(Sender: TObject);
  16      procedure ImageMainMouseDown(Sender: TObject; Button: TMouseButton;
  17        Shift: TShiftState; X, Y: Integer);
  18      procedure ImageMainMouseUp(Sender: TObject; Button: TMouseButton;
  19        Shift: TShiftState; X, Y: Integer);
  20      procedure ImageMainMouseMove(Sender: TObject; Shift: TShiftState; X,
  21        Y: Integer);
  22    private
  23      TenA,TenB,TenC : TPoint;                // 三角形の頂点
  24      MouseDown : Boolean;                    // マウスボタンを押しているか
  25      procedure Triangle(A,B,C : TPoint);     // 三角形を描く
  26      procedure ClearGraph(Color : TColor);   // 画面消去
  27    public
  28      { Public 宣言 }
  29    end;
  30   
  31  var
  32    FormMain: TFormMain;
  33   
  34  implementation
  35   
  36  {$R *.dfm}
  37  (******************** 一般のプロシージャ ********************)
  38  function Nagasa2Jou(A,B : TPoint) : Real;
  39           (* 線分ABの長さの２乗 *)
  40  begin
  41    Nagasa2Jou := Sqr(A.X-B.X)+Sqr(A.Y-B.Y);
  42  end; (* Nagasa2Jou *)
  43   
  44  function Nagasa(A,B : TPoint) : Real;
  45           (* 線分ABの長さ *)
  46  begin
  47    Nagasa := Sqrt(Sqr(A.X-B.X)+Sqr(A.Y-B.Y));
  48  end; (* Nagasa *)
  49   
  50  function Kyori(P,A,B : TPoint) : Real;
  51           (* 点Pから直線ABまでの距離 *)
  52  begin
  53    Kyori := Abs((A.Y-B.Y)*(P.X-B.X)-(A.X-B.X)*(P.Y-B.Y)) /
  54             Sqrt(Sqr(A.Y-B.Y)+Sqr(A.X-B.X)) ;
  55  end; (* Kyori *)
  56   
  57  function Juushin(A,B,C : TPoint; Alpha,Beta,Gamma : Real) : TPoint;
  58           (* 三角形ABCの荷重重心 *)
  59  var
  60    X,Y : Integer;
  61  begin
  62    X := Round((Alpha*A.X+Beta*B.X+Gamma*C.X)/(Alpha+Beta+Gamma));
  63    Y := Round((Alpha*A.Y+Beta*B.Y+Gamma*C.Y)/(Alpha+Beta+Gamma));
  64    Juushin := Point(X,Y);
  65  end; (* Juushin *)
  66   
  67  function Gaishin(A,B,C : TPoint) : TPoint;
  68           (* 三角形の外心 *)
  69  var
  70    AB2,BC2,CA2 : Real;
  71  begin
  72    AB2 := Nagasa2Jou(A,B);
  73    BC2 := Nagasa2Jou(B,C);
  74    CA2 := Nagasa2Jou(C,A);
  75    Gaishin := Juushin(A,B,C,BC2*(CA2+AB2-BC2),CA2*(AB2+BC2-CA2),AB2*(BC2+CA2-AB2));
  76  end; (* Gaishin *)
  77   
  78  function Naishin(A,B,C : TPoint) : TPoint;
  79           (* 三角形ABCの内心 *)
  80  var
  81    AB,BC,CA : Real;
  82  begin
  83    AB := Nagasa(A,B);
  84    BC := Nagasa(B,C);
  85    CA := Nagasa(C,A);
  86    Naishin := Juushin(A,B,C,BC,CA,AB);
  87  end; (* Naishin *)
  88   
  89  function Bunten(A,B : TPoint; Alpha,Beta : Real) : TPoint;
  90           (* AB の β:α の分点 *)
  91  var
  92    X,Y : Integer;
  93  begin
  94    try
  95    X := Round((Alpha*A.X+Beta*B.X)/(Alpha+Beta));
  96    Y := Round((Alpha*A.Y+Beta*B.Y)/(Alpha+Beta));
  97    Bunten := Point(X,Y);
  98    except
  99    Bunten := A;
 100    end;
 101  end; (* Bunten *)
 102   
 103  function SuisenNoAshi(A,B,C : TPoint) : TPoint;
 104           (* C から AB に下ろした垂線の足 *)
 105  var
 106    AB2,BC2,CA2 : Real;
 107  begin
 108    AB2 := Nagasa2Jou(A,B);
 109    BC2 := Nagasa2Jou(B,C);
 110    CA2 := Nagasa2Jou(C,A);
 111    SuisenNoAshi := Bunten(A,B,AB2+BC2-CA2,CA2+AB2-BC2);
 112  end; {SuisenNoAshi}
 113   
 114  function Menseki2(A,B,C : TPoint) : Real;
 115           (* 三角形ABCの符号付面積の2倍 *)
 116  begin
 117    Menseki2 := (A.X-C.X)*(B.Y-C.Y)-(A.Y-C.Y)*(B.X-C.X);
 118  end; (* Menseki2 *)
 119   
 120  procedure Seihoukei(A,B,C : TPoint; var P,Q : TPoint);
 121            (* 三角形 ABC の外側で ABPQ が正方形になるような P,Q *)
 122  var
 123    PM : -1..1;
 124  begin
 125    if Menseki2(A,B,C) > 0
 126      then PM := -1
 127      else PM := +1;
 128    P.X := B.X-PM*(B.Y-A.Y);
 129    P.Y := B.Y+PM*(B.X-A.X);
 130    Q.X := A.X+PM*(A.Y-B.Y);
 131    Q.Y := A.Y-PM*(A.X-B.X);
 132  end; {Seihoukei}
 133   
 134  (******************** フォームのメソッド ********************)
 135  procedure TFormMain.ClearGraph(Color : TColor);
 136            (* Image 全体を Color 色に初期化 *)
 137  begin
 138    with ImageMain.Canvas do
 139      begin
 140        Brush.Color := Color;
 141        Brush.Style := bsSolid;
 142        FillRect(ClipRect);
 143      end;
 144  end; (* ClearGraph *)
 145   
 146  procedure TFormMain.Triangle(A,B,C : TPoint);
 147            (* 三角形ABCを描く    *)
 148            (* 外側に正方形を描く *)
 149  var
 150    D,E,F,G,H,I,J,K,L,M,N,O : TPoint;
 151  begin
 152    with ImageMain.Canvas do
 153      begin
 154        Brush.Style := bsClear;
 155        Pen.Width := 2;
 156        Polygon([A,B,C]);
 157   
 158        Pen.Width := 1;
 159        Seihoukei(B,C,A,E,D);
 160        Seihoukei(C,A,B,G,F);
 161        Seihoukei(A,B,C,I,H);
 162        Polygon([B,C,E,D]);
 163        Polygon([C,A,G,F]);
 164        Polygon([A,B,I,H]);
 165   
 166        J := SuisenNoAshi(B,C,A);
 167        K := SuisenNoAshi(D,E,A);
 168        L := SuisenNoAshi(C,A,B);
 169        M := SuisenNoAshi(F,G,B);
 170        N := SuisenNoAshi(A,B,C);
 171        O := SuisenNoAshi(H,I,C);
 172   
 173        PolyLine([A,K]);
 174        PolyLine([B,M]);
 175        PolyLine([C,O]);
 176        Brush.Style := bsFDiagonal;
 177        Brush.Color := clRed;
 178        Polygon([B,N,O,I]);
 179        Polygon([B,J,K,D]);
 180        Brush.Style := bsBDiagonal;
 181        Brush.Color := clLime;
 182        Polygon([C,J,K,E]);
 183        Polygon([C,L,M,F]);
 184        Brush.Style := bsHorizontal;
 185        Brush.Color := clBlue;
 186        Polygon([A,L,M,G]);
 187        Polygon([A,N,O,H]);
 188      end;
 189  end; (* Triangle *)
 190   
 191  (******************** イベントハンドラー ********************)
 192  procedure TFormMain.ButtonCloseClick(Sender: TObject);
 193  begin
 194    Close;
 195  end; (* ButtonCloseClick *)
 196   
 197  procedure TFormMain.FormCreate(Sender: TObject);
 198  begin
 199    //ImageMain.Canvas.Pen.Mode := pmNotXor;
 200    ImageMain.Canvas.Brush.Color := clAqua;
 201    TenA := Point(400,227);                     // 頂点を決める
 202    TenB := Point(300,400);
 203    TenC := Point(500,400);
 204    Triangle(TenA,TenB,TenC);                   // 三角形を描く
 205  end; (* FormCreate *)
 206   
 207  procedure TFormMain.ImageMainMouseDown(Sender: TObject;
 208    Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
 209  begin
 210    ImageMain.Cursor := crCross;                 // カーソルの形を変更
 211    Mouse.CursorPos := ClientToScreen(TenA);     // カーソルを点Aの上に移動
 212    MouseDown := True;                           // ボタンダウン中
 213  end; (* ImageMainMouseDown *)
 214   
 215  procedure TFormMain.ImageMainMouseUp(Sender: TObject; Button: TMouseButton;
 216    Shift: TShiftState; X, Y: Integer);
 217  begin
 218    ImageMain.Cursor := crDefault;               // カーソルの形を元に戻す
 219    MouseDown := False;                          // ボタンダウン終了
 220  end; (* ImageMainMouseUp *)
 221   
 222  procedure TFormMain.ImageMainMouseMove(Sender: TObject; Shift: TShiftState;
 223    X, Y: Integer);
 224  begin
 225    if MouseDown
 226      then begin
 227             ClearGraph(clWhite);                // 画面を消す
 228             TenA := Point(X,Y);                 // 点Aを変更
 229             Triangle(TenA,TenB,TenC);           // 三角形を描く
 230           end;
 231  end; (* ImageMainMouseMove *)
 232   
 233  end.