Список использованных источников
Абрамов С.А., Зима Е.В. Начало программирования на языке Паскаль.-М.: Наука, 1988.
Вирт Н. Алгоритмы + структуры данных = программы: пер. с англ. под ред. Д.Б. Подшивалова М.:Мир, 1985г, 392с.
Йодан Э. Структурное программирование и конструирование программ. М.:Мир, 1989. – 416с.
Прайс Д. Программирование на языке Паскаль: Практическое руководство. М.: Мир. 1987, -232с.
http://ru.wikipedia.org
http://www.al.cs.msu.su
Приложение а. Листинг программы
uses
Forms,
Unit1 in 'Unit1.pas' {Form1},
DynStruct in 'DynStruct.pas',
SquareFinder in 'SquareFinder.pas';
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, Buttons;
type
TForm1 = class(TForm)
img1: TImage;
btn1: TButton;
btn2: TButton;
btn3: TButton;
btn4: TButton;
btn5: TButton;
btn6: TBitBtn;
lbl1: TLabel;
dlgOpen1: TOpenDialog;
dlgSave1: TSaveDialog;
procedure FormPaint(Sender: TObject);
procedure img1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure btn5Click(Sender: TObject);
procedure btn3Click(Sender: TObject);
procedure btn4Click(Sender: TObject);
procedure btn1Click(Sender: TObject);
procedure btn2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses DynStruct, SquareFinder;
const
PointW = 10;
PointH = 10;
GridRows = 40;
GridCols = 40;
var
pointListRoot : pPointNode;
squareListRoot : pSquareNode;
procedure TForm1.FormPaint(Sender: TObject);
const Colors : array[ 1..5 ] of TColor = ( clRed, clLime, clYellow, clFuchsia, clAqua );
var i : integer;
tz : pPointNode;
dz : pSquareNode;
SCnt : integer;
begin
form1.Canvas.Brush.Color := clSilver;
form1.Canvas.Pen.Width := 1;
form1.Canvas.Pen.Color := clBlack;
form1.Canvas.FillRect( Rect( img1.Left, img1.Top, img1.Left + img1.Width, img1.Top + img1.Height ) );
form1.Canvas.Rectangle( img1.Left, img1.Top, img1.Left + img1.Width, img1.Top + img1.Height );
for i := 1 to GridCols - 1 do
begin
form1.Canvas.MoveTo( img1.Left + i * PointW, img1.Top );
form1.Canvas.LineTo( img1.Left + i * PointW, img1.Top + img1.Height );
end;
for i := 1 to GridRows - 1 do
begin
form1.Canvas.MoveTo( img1.Left, img1.Top + i * PointH );
form1.Canvas.LineTo( img1.Left + img1.Width, img1.Top + i * PointH );
end;
form1.Canvas.Brush.Color := clBlue;
tz := pointListRoot^.next;
while tz <> nil do
begin
form1.Canvas.FillRect( Rect(
img1.Left + ( tz^.Point.X - 1 ) * PointW + 1,
img1.Top + ( tz^.Point.Y - 1 ) * PointH + 1,
img1.Left + tz^.Point.X * PointW,
img1.Top + tz^.Point.Y * PointH ) );
tz := tz^.Next;
end;
form1.Canvas.Pen.Width := 3;
dz := squareListRoot^.Next;
SCnt := 0;
while dz <> nil do
begin
form1.Canvas.Pen.Color := Colors[ SCnt mod 5 + 1 ];
form1.Canvas.MoveTo( img1.Left + dz^.Square[ 1 ].X * PointW - PointW div 2,
img1.Top + dz^.Square[ 1 ].Y * PointH - PointH div 2 );
form1.Canvas.LineTo( img1.Left + dz^.Square[ 2 ].X * PointW - PointW div 2,
img1.Top + dz^.Square[ 2 ].Y * PointH - PointH div 2 );
form1.Canvas.LineTo( img1.Left + dz^.Square[ 3 ].X * PointW - PointW div 2,
img1.Top + dz^.Square[ 3 ].Y * PointH - PointH div 2 );
form1.Canvas.LineTo( img1.Left + dz^.Square[ 4 ].X * PointW - PointW div 2,
img1.Top + dz^.Square[ 4 ].Y * PointH - PointH div 2 );
form1.Canvas.LineTo( img1.Left + dz^.Square[ 1 ].X * PointW - PointW div 2,
img1.Top + dz^.Square[ 1 ].Y * PointH - PointH div 2 );
dz := dz^.Next;
inc( SCnt );
end;
lbl1.Caption := 'Квадратов ' + IntToStr( SCnt );
end;
procedure TForm1.img1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var iX, iY : integer;
begin
iX := X div PointW + 1;
iY := Y div PointH + 1;
AddPointNode( pointListRoot, iX, iY );
DestroySquareList( squareListRoot );
squareListRoot := InitSquareList;
Invalidate;
Update;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
pointListRoot := InitPointList;
squareListRoot := InitSquareList;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
DestroyPointList( pointListRoot );
DestroySquareList( squareListRoot );
end;
procedure TForm1.btn5Click(Sender: TObject);
begin
DestroySquareList( squareListRoot );
squareListRoot := FindSquares( pointListRoot );
Invalidate;
Update;
end;
procedure TForm1.btn3Click(Sender: TObject);
var i, X, Y : integer;
begin
for i := 1 to 50 do
begin
X := random( GridCols ) + 1;
Y := random( GridRows ) + 1;
AddPointNode( pointListRoot, X, Y );
end;
Invalidate;
Update;
end;
procedure ClearAll;
begin
DestroyPointList( pointListRoot );
DestroySquareList( squareListRoot );
pointListRoot := InitPointList;
squareListRoot := InitSquareList;
end;
procedure TForm1.btn4Click(Sender: TObject);
begin
ClearAll;
Invalidate;
Update;
end;
procedure TForm1.btn1Click(Sender: TObject);
var f : TextFile;
X, Y : integer;
begin
if dlgOpen1.Execute then
begin
ClearAll;
AssignFile( f, dlgOpen1.FileName );
Reset( f );
while not eof( f ) do
begin
readln( f, X );
readln( f, Y );
AddPointNode( pointListRoot, X, Y );
end;
CloseFile( f );
end;
Invalidate;
Update;
end;
procedure TForm1.btn2Click(Sender: TObject);
var f : TextFile;
tz : pPointNode;
begin
if dlgSave1.Execute then
begin
AssignFile( f, dlgSave1.FileName );
Rewrite( f );
tz := pointListRoot^.Next;
while tz <> nil do
begin
Writeln( f, tz^.Point.X );
Writeln( f, tz^.Point.Y );
tz := tz^.Next;
end;
CloseFile( f );
end;
end;
end.
unit DynStruct;
interface
type
tPoint = record
X, Y : integer;
end;
tSquare = array[ 1..4 ] of tPoint;
// POINTS ////////////////////////////
pPointNode = ^tPointNode;
tPointNode = record
Next : pPointNode;
Point : tPoint;
end;
// SQUARES ///////////////////////////
pSquareNode = ^tSquareNode;
tSquareNode = record
Next : pSquareNode;
Square : tSquare;
end;
// POINTS ////////////////////////////
function InitPointList : pPointNode;
procedure DestroyPointList( var root : pPointNode );
procedure AddPointNode( root: pPointNode; X, Y : integer );
// SQUARES ///////////////////////////
function InitSquareList : pSquareNode;
procedure DestroySquareList( var root : pSquareNode );
procedure AddSquareNode( root: pSquareNode; P1, P2, P3, P4 : tPoint );
implementation
function InitPointList : pPointNode;
var root : pPointNode;
begin
new(root);
root^.Next := nil;
result := root;
end;
procedure DestroyPointList( var root : pPointNode );
var tz : pPointNode;
begin
while root^.Next <> nil do
begin
tz := root^.Next;
root^.Next := tz^.Next;
dispose( tz );
end;
dispose( root );
root := nil;
end;
procedure AddPointNode( root : pPointNode; X, Y : integer );
var tz : pPointNode;
equalityFlag : boolean;
begin
tz := root;
equalityFlag := false;
while ( tz^.Next <> nil ) and ( not equalityFlag ) do
begin
if ( tz^.Point.X = X ) and ( tz^.Point.Y = Y ) then equalityFlag := true;
tz := tz^.Next;
end;
if ( not equalityFlag ) then
begin
new( tz^.Next );
tz := tz^.Next;
tz^.Point.X := X;
tz^.Point.Y := Y;
tz^.Next := nil;
end;
end;
function InitSquareList : pSquareNode;
var root : pSquareNode;
begin
new(root);
root^.Next := nil;
result := root;
end;
procedure DestroySquareList( var root : pSquareNode );
var tz : pSquareNode;
begin
while root^.Next <> nil do
begin
tz := root^.Next;
root^.Next := tz^.Next;
dispose( tz );
end;
dispose( root );
root := nil;
end;
function SquaresAreEqual( pts1, pts2 : tSquare ) : boolean;
var i, j : integer;
equal : boolean;
begin
result := true;
for i := 1 to 4 do
begin
equal := false;
for j := 1 to 4 do
if ( pts1[ i ].X = pts2[ j ].X ) and ( pts1[ i ].Y = pts2[ j ].Y ) then equal := true;
result := result and equal;
end;
end;
procedure AddSquareNode( root: pSquareNode; P1, P2, P3, P4 : tPoint );
var tz : pSquareNode;
pts : tSquare;
equalityFlag : boolean;
begin
pts[ 1 ] := P1;
pts[ 2 ] := P2;
pts[ 3 ] := P3;
pts[ 4 ] := P4;
tz := root;
equalityFlag := false;
while ( tz^.Next <> nil ) and ( not equalityFlag ) do
begin
if ( tz <> root ) and SquaresAreEqual( tz^.Square, pts ) then
equalityFlag := true;
tz := tz^.Next;
end;
equalityFlag := equalityFlag or SquaresAreEqual( tz^.Square, pts );
if not equalityFlag then
begin
new( tz^.Next );
tz := tz^.Next;
tz^.Square := pts;
tz^.Next := nil;
end;
end;
end.
unit SquareFinder;
interface
uses DynStruct;
function FindSquares( listRoot : pPointNode ) : pSquareNode;
implementation
const
eps = 0.001;
function vecLength( v : tPoint ) : real;
begin
result := sqrt( v.X * v.X + v.Y * v.Y );
end;
function vecOrth( v1, v2 : tPoint ) : boolean;
begin
result := ( v1.X * v2.X + v1.Y * v2.Y ) = 0;
end;
function FindSquares( listRoot : pPointNode ) : pSquareNode;
var tz1, tz2, tz3, tz4 : pPointNode;
v1, v2, v3, v4 : tPoint;
v1l, v2l, v3l, v4l : real;
Squares : pSquareNode;
begin
Squares := InitSquareList;
tz1 := listRoot^.Next;
while tz1 <> nil do
begin
tz2 := listRoot^.Next;
while tz2 <> nil do
begin
v1.X := tz2^.Point.X - tz1^.Point.X;
v1.Y := tz2^.Point.Y - tz1^.Point.Y;
v1l := vecLength( v1 );
if ( v1l > eps ) then
begin
tz3 := listRoot^.Next;
while tz3 <> nil do
begin
v2.X := tz3^.Point.X - tz2^.Point.X;
v2.Y := tz3^.Point.Y - tz2^.Point.Y;
v2l := vecLength( v2 );
if ( vecOrth( v1, v2 ) ) and ( v1l - v2l <= eps ) then
begin
tz4 := listRoot^.Next;
while tz4 <> nil do
begin
v3.X := tz4^.Point.X - tz3^.Point.X;
v3.Y := tz4^.Point.Y - tz3^.Point.Y;
v3l := vecLength( v3 );
if ( vecOrth( v2, v3 ) ) and ( v2l - v3l <= eps ) then
begin
v4.X := tz4^.Point.X - tz1^.Point.X;
v4.Y := tz4^.Point.Y - tz1^.Point.Y;
v4l := vecLength( v4 );
if ( vecOrth( v3, v4 ) ) and ( v3l - v4l <= eps ) then
begin
AddSquareNode( Squares, tz1^.Point, tz2^.Point, tz3^.Point, tz4^.Point );
end;
end;
tz4 := tz4^.Next;
end;
end;
tz3 := tz3^.Next;
end;
end;
tz2 := tz2^.Next;
end;
tz1 := tz1^.Next;
end;
result := Squares;
end;
end.