Сухарев М.В. Основы Delphi. Профессиональный подход – СПб.: Наука и Техника, 2004

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.