Материалы представленные на сайте исключительно с целью ознакомления пользователям Интернета и не преследуют коммерческих целей или нарушение авторских прав.
© 2018 - 2024
1 Сухарев М.В. Основы Delphi. Профессиональный подход – СПб.: Наука и Техника, 2004.
2 Кэнту М. Delphi 7: для профессионалов – СПб.: Питер, 2004.
Приложение
Текст программы
program Qtree;
uses Forms,
UnitMainForm in 'UnitMainForm.pas' {MainForm},
UnitModel in 'UnitModel.pas';
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TMainForm, MainForm);
Application.Run;
end.
unit UnitModel;
interface
uses Classes;
const M = 3; //число точек в листе
type
//Тип узла дерева-----------------------------------
TNodeKind = (nkBranch, nkLeaf);
TPoint = record
X: real;
Y: real;
end;
TRect = record
X1, Y1, X2, Y2: real;
end;
//Массив для хранения точек в листе-----------------
TArrayOfPoints = array[1..M] of TPoint;
//Узел дерева---------------------------------------
PNode = ^TNode;
TNode = packed record
case Kind: TNodeKind of
nkBranch: (SZ, SV, YZ, YV: PNode);
nkLeaf: (Points: TArrayOfPoints;
PointsCount: integer);
end;
function InsertPoint(var Node: PNode; Bounds: TRect; Point: TPoint): boolean;
procedure DeletePoint(var Node: PNode; Bounds: TRect; Point: TPoint);
procedure ClearTree(var Node: PNode);
function Find(Node: PNode; const Bounds, Rect: TRect): TList;
implementation
//Установка характеристик нового листа =======================================
procedure SetProperties(var ChildNode: PNode);
begin
New(ChildNode);
ChildNode^.Kind:= nkLeaf;
ChildNode^.PointsCount:= 0; //в массиве нет точек
end;
//Копирование точек из листа в дополнительный массив =========================
procedure CopyPoints(Node: PNode; var DopArray: TArrayOfPoints; var i: integer);
var j: integer;
begin
for j:=1 to Node^.PointsCount do
begin
DopArray[i]:= Node^.Points[j];
inc(i);
end;
end;
//ВСТАВКА ТОЧКИ В ДЕРЕВО =====================================================
function InsertPoint(var Node: PNode; Bounds: TRect; Point: TPoint): boolean;
var CurNode: PNode; //текущий квадрант
DopArray: TArrayOfPoints; //дополнительный массив (когда делим узел)
i: integer;
midX, midY: real;
NewBounds: TRect;
begin
if Node = nil then
begin
New(Node);
Node^.Kind:= nkLeaf;
Node^.PointsCount:= 0;
end;
CurNode:= Node;
Result:= true;
with Bounds do
begin
while CurNode^.Kind = nkBranch do //если ветвь, то смотрим, куда идти
begin
midX:= (X2 - X1)/2 + X1;
midY:= (Y2 - Y1)/2 + Y1;
if Point.X < midX then
if Point.Y < midY then
begin
CurNode:= CurNode^.SZ;
X2:= midX;
Y2:= midY;
end
else
begin
CurNode:= CurNode^.YZ;
Y1:= midY;
X2:= midX;
end
else
if Point.Y < midY then
begin
CurNode:= CurNode^.SV;
X1:= midX;
Y2:= midY;
end
else
begin
CurNode:= CurNode^.YV;
X1:= midX;
Y1:= midY;
end;
end;
midX:= (X2 - X1)/2 + X1;
midY:= (Y2 - Y1)/2 + Y1;
end;
//Собственно вставка----------------------------------------------------------
//Проверить, есть ли место в массиве точек и нет ли уже там новой:
for i:=1 to CurNode^.PointsCount do
if (CurNode^.Points[i].X = Point.X)and(CurNode^.Points[i].Y = Point.Y) then
begin
Result:= false;
Exit;
end;
//Если массив не заполнен, вставляем точку...
if CurNode^.PointsCount < M then
begin
CurNode^.Points[CurNode^.PointsCount + 1]:= Point;
CurNode^.PointsCount:= CurNode^.PointsCount + 1;
end
else
begin
//...иначе делим лист на 4 новых:
DopArray:= CurNode^.Points;
CurNode^.Kind:= nkBranch;
SetProperties(CurNode^.SZ);
SetProperties(CurNode^.SV);
SetProperties(CurNode^.YZ);
SetProperties(CurNode^.YV);
//Распределение точек по узлам
for i:=1 to M do
with Bounds do
if DopArray[i].X < midX then
if DopArray[i].Y < midY then
begin
NewBounds.X1:= X1;
NewBounds.X2:= (X2 - X1)/2 + X1;
NewBounds.Y1:= Y1;
NewBounds.Y2:= (Y2 - Y1)/2 + Y1;
InsertPoint(CurNode^.SZ, NewBounds, DopArray[i]);
end
else
begin
NewBounds.X1:= X1;
NewBounds.X2:= (X2 - X1)/2 + X1;
NewBounds.Y1:= (Y2 - Y1)/2 + Y1;
NewBounds.Y2:= Y2;
InsertPoint(CurNode^.YZ, NewBounds, DopArray[i]);
end
else
if DopArray[i].Y < midY then
begin
NewBounds.X1:= (X2 - X1)/2 + X1;
NewBounds.X2:= X2;
NewBounds.Y1:= Y1;
NewBounds.Y2:= (Y2 - Y1)/2 + Y1;
InsertPoint(CurNode^.SV, NewBounds, DopArray[i]);
end
else
begin
NewBounds.X1:= (X2 - X1)/2 + X1;
NewBounds.X2:= X2;
NewBounds.Y1:= (Y2 - Y1)/2 + Y1;
NewBounds.Y2:= Y2;
InsertPoint(CurNode^.YV, NewBounds, DopArray[i]);
end;
//Вставка новой точки
InsertPoint(CurNode, Bounds, Point);
end;
end;
//УДАЛЕНИЕ ТОЧКИ ИЗ ДЕРЕВА ===================================================
procedure DeletePoint(var Node: PNode; Bounds: TRect; Point: TPoint);
var CurNode, ParentNode: PNode;
DopArray: TArrayOfPoints;
midX, midY, PointsInNodes, numSZ, numSV, numYZ, numYV: real;
there: boolean;
i, N: integer;
begin
if Node = nil then
Exit;
CurNode:= Node;
ParentNode:= CurNode;
with Bounds do
while CurNode^.Kind = nkBranch do //если ветвь, то смотрим, куда идти
begin
ParentNode:= CurNode;
midX:= (X2 - X1)/2 + X1;
midY:= (Y2 - Y1)/2 + Y1;
if Point.X < midX then
if Point.Y < midY then
begin
CurNode:= CurNode^.SZ;
X2:= midX;
Y2:= midY;
end
else
begin
CurNode:= CurNode^.YZ;
Y1:= midY;
X2:= midX;
end
else
if Point.Y < midY then
begin
CurNode:= CurNode^.SV;
X1:= midX;
Y2:= midY;
end
else
begin
CurNode:= CurNode^.YV;
X1:= midX;
Y1:= midY;
end;
end;
//Собственно удаление-------------------------------------------------------
N:= CurNode^.PointsCount;
//Проверить, есть ли в массиве удаляемая точка:
there:= false;
for i:=1 to M do
if (CurNode^.Points[i].X = Point.X)and(CurNode^.Points[i].Y = Point.Y) then
begin
there:= true;
break;
end;
//Удаляем точку (либо выходим, если таковой не имеется)
if there then
begin
CurNode^.Points[i]:= CurNode^.Points[N];
CurNode^.PointsCount:= CurNode^.PointsCount - 1;
end
else Exit;
if Node^.Kind = nkLeaf then
Exit;
//Посмотрим, можно ли объединить соседние узлы
numSZ:= ParentNode^.SZ^.PointsCount;
numSV:= ParentNode^.SV^.PointsCount;
numYZ:= ParentNode^.YZ^.PointsCount;
numYV:= ParentNode^.YV^.PointsCount;
PointsInNodes:= numSZ + numSV + numYZ + numYV;
if PointsInNodes <= M then
begin
//Точки из всех листьев переносим в вышестоящий узел
i:=1;
CopyPoints(ParentNode^.SZ, DopArray, i);
CopyPoints(ParentNode^.SV, DopArray, i);
CopyPoints(ParentNode^.YZ, DopArray, i);
CopyPoints(ParentNode^.YV, DopArray, i);
//Удаляем старые листья
Dispose(ParentNode^.SZ);
Dispose(ParentNode^.SV);
Dispose(ParentNode^.YZ);
Dispose(ParentNode^.YV);
ParentNode^.Kind:= nkLeaf;
ParentNode^.Points:= DopArray;
end;
end;
//УДАЛЕНИЕ ДЕРЕВА ============================================================
procedure ClearTree(var Node: PNode);
begin
if Node = nil then
Exit;
if Node^.Kind = nkBranch then
begin
ClearTree(Node^.SZ);
ClearTree(Node^.SV);
ClearTree(Node^.YZ);
ClearTree(Node^.YV);
end;
Dispose(Node);
Node:= nil;
end;
//ПОИСК ТОЧЕК В ЗАДАННОЙ ОБЛАСТИ =============================================
function Find(Node: PNode; const Bounds, Rect: TRect): TList;
var NewBounds: TRect;
i: integer;
begin
Result:= TList.Create;
if Node = nil then
Exit;
with Bounds do
if (X2 >= Rect.X1)and(X1 <= Rect.X2)and(Y2 >= Rect.Y1)and(Y1 <= Rect.Y2) then
if Node^.Kind = nkBranch then
begin
NewBounds.X1:= X1;
NewBounds.X2:= (X2 - X1)/2 + X1;
NewBounds.Y1:= Y1;
NewBounds.Y2:= (Y2 - Y1)/2 + Y1;
Result.Assign(Find(Node^.SZ, NewBounds, Rect), laOr);
NewBounds.X1:= (X2 - X1)/2 + X1;
NewBounds.X2:= X2;
NewBounds.Y1:= Y1;
NewBounds.Y2:= (Y2 - Y1)/2 + Y1;
Result.Assign(Find(Node^.SV, NewBounds, Rect), laOr);
NewBounds.X1:= X1;
NewBounds.X2:= (X2 - X1)/2 + X1;
NewBounds.Y1:= (Y2 - Y1)/2 + Y1;
NewBounds.Y2:= Y2;
Result.Assign(Find(Node^.YZ, NewBounds, Rect), laOr);
NewBounds.X1:= (X2 - X1)/2 + X1;
NewBounds.X2:= X2;
NewBounds.Y1:= (Y2 - Y1)/2 + Y1;
NewBounds.Y2:= Y2;
Result.Assign(Find(Node^.YV, NewBounds, Rect), laOr);
end
else
begin
for i:=1 to Node^.PointsCount do
if (Node^.Points[i].X >= Rect.X1)and
(Node^.Points[i].X <=Rect.X2)and
(Node^.Points[i].Y >= Rect.Y1)and
(Node^.Points[i].Y <= Rect.Y2) then
Result.Add(@(Node^.Points[i]));
end;
end;
end.
unit UnitMainForm;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, UnitModel, ComCtrls, Buttons;
const Xmax = 1024; //ширина всего квадрата, отведенного под квадродерево
type
TMainForm = class(TForm)
MaxImage: TImage;
ShapeMax: TShape;
MinImage: TImage;
ShapeView: TShape;
Shape3: TShape;
LabelTop: TLabel;
LabelLeft: TLabel;
LabelRight: TLabel;
LabelBottom: TLabel;
StatusBar: TStatusBar;
SBtnCursor: TSpeedButton;
SBtnPoints: TSpeedButton;
ButtonClear: TBitBtn;
ButtonDelete: TBitBtn;
procedure DrawPoint(const Point: TPoint; PointColor: TColor);
procedure ClearBackground(Image: TImage);
procedure DrawRegion(const Node: PNode; const Bounds: TRect);
procedure ShapeViewMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure ShapeViewMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure ShapeViewMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure MaxImageMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure MaxImageClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure ButtonClearClick(Sender: TObject);
procedure ButtonDeleteClick(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
private
{ Private declarations }
public
{ Public declarations }
end;
var
MainForm: TMainForm;
implementation
{$R *.dfm}
const K = 10.56; //масштаб (MaxImage.Width/MinImage.Width)
R = 3; //радиус точки на форме
LightColor = clLime; //цвет подсветки точек
SelectColor = clRed; //цвет выделенной точки
BackColor = clWhite; //цвет фона
var Tree: PNode;
X0, Y0: integer;
drag: boolean = false; //флажок перетаскивания окна просмотра
PointCount: integer = 0; //число точек в дереве
mainBounds, Query: TRect; //главный квадрант и окно просмотра
LightPoint, SelectedPoint: TPoint;
//Отрисовка точки ============================================================
procedure TMainForm.DrawPoint(const Point: TPoint; PointColor: TColor);
var dopX, dopY: integer;
begin
//В большом окне...
with Point do
begin
with MaxImage.Canvas do
begin
Brush.Color:= PointColor;
Brush.Style:= bsSolid;
Pen.Color:= PointColor;
dopX:= round(X - Query.X1);
dopY:= round(Y - Query.Y1);
Ellipse(dopX-R, dopY-R, dopX+R, dopY+R);
end;
//...и в малом:
with MinImage.Canvas do
begin
Brush.Color:= PointColor;
Brush.Style:= bsSolid;
Pen.Color:= PointColor;
Ellipse(round(X/K)-1, round(Y/K)-1, round(X/K)+1, round(Y/K)+1);
end;
end;
end;
//"Очистка" фона =============================================================
procedure TMainForm.ClearBackground(Image: TImage);
begin
with Image.Canvas do
begin
Brush.Style:= bsSolid;
Brush.Color:= BackColor;
Rectangle(-1,-1,Image.Width + 1,Image.Height + 1);
end;
end;
//Отрисовка просматриваемой области ==========================================
procedure TMainForm.DrawRegion(const Node: PNode; const Bounds: TRect);
var FindedPoints: TList;
dopPoint: TPoint;
i: integer;
begin
FindedPoints:= TList.Create;
with FindedPoints do
begin
Assign(Find(Node, mainBounds, Bounds), laOr);
if Capacity <> 0 then
for i:= 0 to Count - 1 do
begin
dopPoint:= TPoint(FindedPoints[i]^);
if (dopPoint.X = SelectedPoint.X)and(dopPoint.Y = SelectedPoint.Y) then
DrawPoint(dopPoint, SelectColor)
else DrawPoint(dopPoint, clBlack);
end;
Free;
end;
end;
//Задание начальных координат областей и точек ===============================
procedure TMainForm.FormCreate(Sender: TObject);
begin
with mainBounds do
begin
X1:= 0;
Y1:= 0;
X2:= Xmax;
Y2:= Xmax;
end;
with Query do
begin
X1:= 0;
Y1:= 0;
X2:= MaxImage.Width;
Y2:= MaxImage.Width;
end;
with LightPoint do
begin
X:= -4;
Y:= -4;
end;
with SelectedPoint do
begin
X:= -3;
Y:= -3;
end;
end;
//НАВИГАЦИЯ В МАЛОМ ОКНЕ =====================================================
procedure TMainForm.ShapeViewMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
X0:= X;
Y0:= Y;
drag:= true;
end;
procedure TMainForm.ShapeViewMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
drag:= false;
end;
procedure TMainForm.ShapeViewMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
var newLeft, newTop: integer;
begin
if drag then
with Sender as TShape do
begin
newLeft:= Left + X - X0;
newTop:= Top + Y - Y0;
if newLeft + Width >= MinImage.Left + MinImage.Width + 1 then
newLeft:= MinImage.Left + MinImage.Width + 1 - Width;
if newLeft <= MinImage.Left - 1 then
newLeft:= MinImage.Left - 1;
Left:= newLeft;
if newTop + Height >= MinImage.Top + MinImage.Height + 1 then
newTop:= MinImage.Top + MinImage.Height + 1 - Height;
if newTop <= MinImage.Top - 1 then
newTop:= MinImage.Top - 1;
Top:= newTop;
//Границы просматриваемой области-----------------------------------
Query.X1:= round((Left - MinImage.Left + 1)*K);
Query.X2:= round((Left - MinImage.Left + Width + 1)*K);
Query.Y1:= round((Top - MinImage.Top + 1)*K);
Query.Y2:= round((Top - MinImage.Top + Height + 1)*K);
LabelLeft.Caption:= FloatToStr(Query.X1);
LabelRight.Caption:= FloatToStr(Query.X2);
LabelTop.Caption:= FloatToStr(Query.Y1);
LabelBottom.Caption:= FloatToStr(Query.Y2);
ClearBackground(MaxImage);
DrawRegion(Tree, Query);
end;
end;
//Отображение координат точек в строке состояния =============================
procedure TMainForm.MaxImageMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
var Point: TPoint;
Rect: TRect;
str: string[30];
List: TList;
begin
if SBtnCursor.Down then
MaxImage.Cursor:= crDefault
else MaxImage.Cursor:= crCross;
with StatusBar do
with MaxImage.Canvas do
begin
//Координаты указателя мыши
Panels[0].Text := 'X: ' + FloatToStr(X + Query.X1);
Panels[1].Text := 'Y: ' + FloatToStr(Y + Query.Y1);
//Если указатель наведен на точку:
if (Pixels[X,Y] = clBlack)or(Pixels[X,Y] = LightColor)or
(Pixels[X,Y] = SelectColor) then
begin
Point.X:= X + Query.X1;
Point.Y:= Y + Query.Y1;
with Point do
begin
Rect.X1:= X - R;
Rect.X2:= X + R;
Rect.Y1:= Y - R;
Rect.Y2:= Y + R;
end;
List:= TList.Create;
List.Assign(Find(Tree, mainBounds, Rect), laOr);
if List.Capacity <> 0 then
begin
Point:= TPoint(List[0]^);
Panels[3].Text:= 'Точка ' + FloatToStr(Point.X) + '; ' +
FloatToStr(Point.Y);
//"Подсветка" точки----------------------------------------------
if Pixels[round(Point.X - Query.X1),round(Point.Y - Query.Y1)] <>
LightColor then
with LightPoint do
begin
if X >= 0 then
if (X <> SelectedPoint.X)or(Y <> SelectedPoint.Y) then
DrawPoint(LightPoint, clBlack)
else DrawPoint(LightPoint, SelectColor);
str:= StatusBar.Panels[3].Text;
X:= StrToFloat(Copy(str, Pos(' ', str)+1, Pos(';', str)-
Pos(' ', str)-1));
Y:= StrToFloat(Copy(str, Pos(';', str)+2, 10));
DrawPoint(LightPoint, LightColor);
end;
List.Free;
end;
end
else
//Долой "подсветку":
with LightPoint do
begin
Panels[3].Text:= '';
if Tree = nil then
Exit;
if Pixels[round(X - Query.X1), round(Y - Query.Y1)] =
LightColor then
if (X = SelectedPoint.X)and(Y = SelectedPoint.Y) then
DrawPoint(LightPoint, SelectColor)
else DrawPoint(LightPoint, clBlack);
end;
end;
end;
//Клик по большому окну ======================================================
procedure TMainForm.MaxImageClick(Sender: TObject);
var Point: TPoint;
str: string[30];
i, j: integer;
begin
Point.X:= StrToInt(copy(StatusBar.Panels[0].Text, 4, 10));
Point.Y:= StrToInt(copy(StatusBar.Panels[1].Text, 4, 10));
if SBtnPoints.Down then //В режиме добавления точек -----------------------
begin
//Добавление точки в дерево
if InsertPoint(Tree, mainBounds, Point) then
PointCount:= PointCount + 1;
ClearBackground(MaxImage);
ClearBackground(MinImage);
//Перерисовка области просмотра
DrawRegion(Tree, Query);
DrawRegion(Tree, mainBounds);
StatusBar.Panels[2].Text:= 'Количество точек: ' + IntToStr(PointCount);
end
else
begin
if (Point.X = SelectedPoint.X)and(Point.Y = SelectedPoint.Y) then
Exit;
i:= round(Point.X - Query.X1);
j:= round(Point.Y - Query.Y1);
with MaxImage.Canvas do
begin
if (Pixels[i,j] = LightColor)or(Pixels[i,j] = clBlack) then
//"Запомнить" выбранную точку -------------------------------------
with SelectedPoint do
begin
str:= StatusBar.Panels[3].Text;
if str = '' then
Exit;
if X >= 0 then
DrawPoint(SelectedPoint, clBlack);
X:= StrToFloat(Copy(str, Pos(' ', str)+1, Pos(';', str)-Pos(' ',
str)-1));
Y:= StrToFloat(Copy(str, Pos(';', str)+2, 10));
StatusBar.Panels[4].Text:= 'Выбрано: ' + FloatToStr(X) + '; ' +
FloatToStr(Y);
DrawPoint(SelectedPoint, SelectColor);
ButtonDelete.Enabled:= true;
end;
end;
end;
end;
//Удаление точки =============================================================
procedure TMainForm.ButtonDeleteClick(Sender: TObject);
begin
DeletePoint(Tree, mainBounds, SelectedPoint);
if (SelectedPoint.X >= Query.X1)and(SelectedPoint.X <= Query.X2)and
(SelectedPoint.Y >= Query.Y1)and(SelectedPoint.Y <= Query.Y2) then
begin
SelectedPoint.X:= -3;
LightPoint.X:= -4;
ClearBackground(MaxImage);
ClearBackground(MinImage);
DrawRegion(Tree, mainBounds);
end;
PointCount:= PointCount - 1;
StatusBar.Panels[4].Text:= '';
ButtonDelete.Enabled:= false;
end;
//Удаление дерева ============================================================
procedure TMainForm.ButtonClearClick(Sender: TObject);
begin
ClearTree(Tree);
ClearBackground(MaxImage);
ClearBackground(MinImage);
DrawRegion(Tree, mainBounds);
PointCount:= 0;
with StatusBar do
begin
Panels[2].Text:= '';
Panels[3].Text:= '';
Panels[4].Text:= '';
end;
SelectedPoint.X:= -3;
LightPoint.X:= -4;
StatusBar.Panels[4].Text:= '';
ButtonDelete.Enabled:= false;
end;
//Перемещение окошка с помощью клавиш ========================================
procedure TMainForm.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
const dif = 4;
begin
drag:= true;
with ShapeView do
begin
X0:= Left + round(Width/2);
Y0:= Top + round(Height/2);
end;
if Key = VK_UP then
ShapeViewMouseMove(ShapeView, Shift, X0, Y0 - dif)
else
if Key = VK_DOWN then
ShapeViewMouseMove(ShapeView, Shift, X0, Y0 + dif)
else
if Key = VK_LEFT then
ShapeViewMouseMove(ShapeView, Shift, X0 - dif, Y0)
else
ShapeViewMouseMove(ShapeView, Shift, X0 + dif, Y0);
drag:= false;
end;
end.
Дата: 2019-07-24, просмотров: 184.