/
n-dimens
/
pascalabcnet
Обзор
Документация
Войти
/
n-dimens
/
pascalabcnet
Код
Запросы
0
Задачи
Вики
Пакеты
0
Релизы
0
Аналитика
Безопасность
master
TestSuite/CompilationSamples/ABCObjects.pas
2 745 строк
78 KB
Mikhalkovich Stanislav
del doc
15 июн 2024, 19:25
15 июн 2024, 19:25
41177e7
Код
Авторство
О чём код?
// Copyright (c) Ivan Bondarev, Stanislav Mikhalkovich (for details please see \doc\copyright.txt) // This code is distributed under the GNU LGPL (for details please see \doc\license.txt) ///Модуль реализует векторные графические объекты с возможностью масштабирования, наложения друг на друга, ///создания составных графических объектов и многократного их вложения друг в друга. ///Каждый векторный графический объект перерисовывает себя при перемещении, изменении размеров ///и частичном перекрытии другими объектами. unit ABCObjects; //{$apptype windows} {$reference '%GAC%\System.Windows.Forms.dll'} {$reference '%GAC%\System.Drawing.dll'} interface uses System.Drawing, GraphABC; type Color = GraphABC.Color; GColor = GraphABC.Color; ContainerABC = class; GRectangle = System.Drawing.Rectangle; /// Базовый класс для всех графических объектов ObjectABC = class private fx,fy: integer; fw,fh: integer; col,fcol: GColor; vis,txtvis: boolean; txt,fname: string; fstyle: FontStyleType; txtscale: real; ow: ContainerABC; _dx,_dy: integer; procedure SetCoords(x,y: integer); protected // InternalDraw: низкоуровневая процедура (не вызывается пользователем). Просто вызывает Draw(fx,fy) procedure InternalDraw; procedure SetVis(v: boolean); procedure SetColor(cl: GColor); procedure SetOwner(o: ContainerABC); procedure SetX(x: integer); procedure SetY(y: integer); procedure ObjectABCSetSize(Width,Height: integer); // internal procedure SetWidth(Width: integer); virtual; procedure SetHeight(Height: integer); virtual; procedure SetText(t: string); virtual; procedure SetTxtVis(b: boolean); procedure SetTextScale(r: real); procedure SetFontName(name: string); procedure SetFontStyle(fs: FontStyleType); procedure SetFontColor(fc: GColor); procedure SetNum(n: integer); function GetNum: integer; procedure SetRealNum(r: real); function GetRealNum: real; procedure SetCenter(p: Point); function GetCenter: Point; procedure SetPosition(p: Point); function GetPosition: Point; procedure CalcOwnerOffset(var l,t: integer); procedure DrawAfterChangeBounds(oldBounds,newBounds: GRectangle); procedure DrawText(x,y: integer; g: Graphics); procedure Init(x,y,w,h: integer; cl: GColor); procedure InitBy(g: ObjectABC); // Draw: переопределяется в подклассах. Рисует объект на текущей канве procedure Draw(x,y: integer; g: Graphics); virtual; begin end; procedure Draw(x,y: integer); public /// Создает графический объект размера (w,h) цвета cl с координатами левого верхнего угла (x,y) constructor Create(x,y,w,h: integer; cl: GColor := clWhite); /// Создает графический объект - копию объекта g constructor Create(g: ObjectABC); /// Уничтожает графический объект destructor Destroy; // Redraw: низкоуровневая процедура (не вызывается пользователем). // Обновляет изображение объекта на экране, вызывая drawRect(Bounds). // Вызывается в ситуациях, когда границы объекта не изменяются (напр., смена цвета) // или увеличиваются (добавление нового объекта к фигуре) procedure Redraw; // RedrawNow - вызывает перерисовку объекта, несмотря на LockDrawing procedure RedrawNow; /// Перемещает левый верхний угол графического объекта к точке (x,y) procedure MoveTo(x,y: integer); /// Перемещает графический объект на вектор (a,b) procedure MoveOn(a,b: integer); /// Перемещает графический объект на вектор, задаваемый свойствами dx,dy procedure Move; virtual; /// Масштабирует графический объект в f раз (f>1 - увеличение, 0<f<1 - уменьшение) procedure Scale(f: real); virtual; /// Переносит графический объект на передний план procedure ToFront; /// Переносит графический объект на задний план procedure ToBack; /// Возвращает прямоугольник, определяющий границы графического объекта function Bounds: GRectangle; /// Возвращает True, если точка (x,y) находится внутри графического объекта, и False в противном случае function PtInside(x,y: integer): boolean; virtual; /// Возвращает True, если изображение данного графического объекта пересекается с изображением ///графического объекта g, и False в противном случае. Белый цвет считается прозрачным и не принадлежащим объекту function Intersect(g: ObjectABC): boolean; /// Возвращает True, если прямоугольник графического объекта пересекается прямоугольником r, и False в противном случае function IntersectRect(r: GRectangle): boolean; /// Отступ графического объекта от левого края property Left: integer read fx write SetX; /// Отступ графического объекта от верхнего края property Top: integer read fy write SetY; /// Ширина графического объекта property Width: integer read fw write SetWidth; /// Высота графического объекта property Height: integer read fh write SetHeight; ///x-координата вектора перемещения объекта при вызове метода Move. ///По умолчанию установлено в 0. Для неподвижных объектов может быть использовано ///для хранения любой дополнительной информации, связанной с объектом property dx: integer read _dx write _dx; /// y-координата вектора перемещения объекта при вызове метода Move. ///По умолчанию установлено в 0. Для неподвижных объектов может быть использовано ///для хранения любой дополнительной информации, связанной с объектом property dy: integer read _dy write _dy; /// Центр графического объекта property Center: Point read GetCenter write SetCenter; /// Левый верхний угол графического объекта property Position: Point read GetPosition write SetPosition; /// Видим ли графический объект property Visible: boolean read vis write SetVis; /// Цвет графического объекта property Color: GColor read col write SetColor; /// Цвет шрифта графического объекта property FontColor: GColor read fcol write SetFontColor; /// Текст внутри графического объекта property Text: string read txt write SetText; /// Видимость текста внутри графического объекта property TextVisible: boolean read txtvis write SetTxtVis; /// Масштаб текста относительно размеров графического объекта, 0<=TextScale<=1. ///При TextScale=1 текст занимает всю ширину или высоту объекта. По умолчанию TextScale=0.8 property TextScale: real read txtscale write SetTextScale; /// Имя шрифта для вывода свойства Text property FontName: string read fname write SetFontName; /// Стиль шрифта для вывода свойства Text property FontStyle: FontStyleType read fstyle write SetFontStyle; /// Целое число, выводимое в центре графического объекта. Для вывода используется свойство Text property Number: integer read GetNum write SetNum; /// Вещественное число, выводимое в центре графического объекта. Для вывода используется свойство Text. ///Вещественное число выводится с одним знаком после десятичной точки property RealNumber: real read GetRealNum write SetRealNum; ///Владелец графического объекта, ответственный также за перерисовку графического объекта внутри себя (по умолчанию nil) property Owner: ContainerABC read ow write SetOwner; /// Возвращает клон графического объекта function Clone0: ObjectABC; virtual; begin Result := nil end; /// Возвращает клон графического объекта function Clone: ObjectABC; begin Result := Clone0 end; end; /// Базовый класс для всех замкнутых графических объектов BoundedObjectABC = class(ObjectABC) private bcol: GColor; bw: integer; fil,bor: boolean; procedure SetBColor(cl: GColor); procedure SetBW(w: integer); function GetBW: integer; procedure SetFilled(f: boolean); procedure SetBordered(b: boolean); protected procedure Init(x,y,w,h: integer; cl: GColor); procedure InitBy(g: BoundedObjectABC); /// Устанавливает атрибуты пера и кисти перед рисованием procedure SetDrawSettings; public /// Создает замкнутый графический объект размера (w,h) цвета cl с координатами левого верхнего угла (x,y) constructor Create(x,y,w,h: integer; cl: GColor := clWhite); /// Создает замкнутый графический объект - копию объекта g constructor Create(g: BoundedObjectABC); /// Цвет границы property BorderColor: GColor read bcol write SetBColor; /// Ширина границы property BorderWidth: integer read GetBW write SetBW; // ширина границы при рисовании уходит внутрь, т.е. при ее изменении не меняются размеры объекта /// Заполнена ли внутренность объекта (по умолчанию True) property Filled: boolean read fil write SetFilled; /// Имеет ли объект границу (по умолчанию True) property Bordered: boolean read bor write SetBordered; end; /// Класс графических объектов "Прямоугольник" RectangleABC = class(BoundedObjectABC) protected procedure Draw(x,y: integer; g: Graphics); override; public /// Создает прямоугольник размера (w,h) цвета cl с координатами левого верхнего угла (x,y) constructor Create(x,y,w,h: integer; cl: GColor := clWhite); /// Создает прямоугольник - копию прямоугольника g constructor Create(g: RectangleABC); /// Возвращает клон прямоугольника function Clone0: ObjectABC; override; /// Возвращает клон прямоугольника function Clone: RectangleABC; end; /// Класс графических объектов "Квадрат" SquareABC = class(RectangleABC) protected procedure SetWidth(Width: integer); override; procedure SetHeight(Height: integer); override; public /// Создает квадрат размера w цвета cl с координатами левого верхнего угла (x,y) constructor Create(x,y,w: integer; cl: GColor := clWhite); /// Создает квадрат - копию квадрата g constructor Create(g: SquareABC); /// Масштабирует квадрат в f раз (f>1 - увеличение, 0<f<1 - уменьшение) procedure Scale(f: real); override; /// Возвращает клон квадрата function Clone0: ObjectABC; override; /// Возвращает клон квадрата function Clone: SquareABC; end; /// Класс графических объектов "Эллипс" EllipseABC = class(BoundedObjectABC) protected procedure Draw(x,y: integer; g: Graphics); override; public /// Создает эллипс размера (w,h) цвета cl с координатами левого верхнего угла (x,y) constructor Create(x,y,w,h: integer; cl: GColor := clWhite); /// Создает эллипс - копию эллипса g constructor Create(g: EllipseABC); /// Возвращает клон эллипса function Clone0: ObjectABC; override; /// Возвращает клон эллипса function Clone: EllipseABC; end; /// Класс графических объектов "Круг" CircleABC = class(EllipseABC) protected procedure SetWidth(Width: integer); override; procedure SetHeight(Height: integer); override; procedure SetRadius(r: integer); function GetRadius: integer; public /// Создает круг радиуса r цвета cl с координатами центра (x,y) constructor Create(x,y,r: integer; cl: GColor := clWhite); /// Создает круг - копию круга g constructor Create(g: CircleABC); /// Масштабирует круг в f раз (f>1 - увеличение, 0<f<1 - уменьшение) procedure Scale(f: real); override; /// Возвращает клон круга function Clone0: ObjectABC; override; /// Возвращает клон круга function Clone: CircleABC; /// Радиус круга property Radius: integer read GetRadius write SetRadius; end; /// Класс графических объектов "Прямоугольник со скругленными краями" RoundRectABC = class(BoundedObjectABC) private r: integer; procedure SetRadius(rr: integer); protected procedure Draw(x,y: integer; g: Graphics); override; procedure Init(x,y,w,h,rr: integer; cl: GColor); procedure InitBy(g: RoundRectABC); public /// Создает прямоугольник со скругленными краями размера (w,h), цветом cl, радиусом скругления r и координатами левого верхнего угла (x,y) constructor Create(x,y,w,h,rr: integer; cl: GColor := clWhite); /// Создает прямоугольник со скругленными краями - копию прямоугольника со скругленными краями g constructor Create(g: RoundRectABC); /// Радиус скругления углов property Radius: integer read r write SetRadius; /// Возвращает клон прямоугольника со скругленными краями function Clone0: ObjectABC; override; /// Возвращает клон прямоугольника со скругленными краями function Clone: RoundRectABC; end; /// Класс графических объектов "Квадрат со скругленными краями" RoundSquareABC = class(RoundRectABC) protected procedure SetWidth(Width: integer); override; procedure SetHeight(Height: integer); override; public /// Создает квадрат со скругленными краями размера w, цвета cl с радиусом скругления r и координатами левого верхнего угла (x,y) constructor Create(x,y,w,r: integer; cl: GColor := clWhite); /// Создает квадрат со скругленными краями - копию квадрата со скругленными краями g constructor Create(g: RoundSquareABC); /// Масштабирует квадрат в f раз (f>1 - увеличение, 0<f<1 - уменьшение) procedure Scale(f: real); override; /// Возвращает клон квадрата со скругленными краями function Clone0: ObjectABC; override; /// Возвращает клон квадрата со скругленными краями function Clone: RoundSquareABC; end; /// Класс графических объектов "Текст" TextABC = class(ObjectABC) private pointsz: integer; tb: boolean; bc: GColor; protected procedure SetFSize(sz: integer); procedure SetTB(b: boolean); procedure SetBC(c: GColor); procedure SetText(t: string); override; procedure Init(x,y,pt: integer; cl: GColor; txt: string); procedure InitBy(g: TextABC); procedure Draw(x,y: integer; g: Graphics); override; public /// Создает текстовый объект с текстом txt размера pt пунктов, цветом cl и координатами левого верхнего угла (x,y) constructor Create(x,y,pt: integer; txt: string; cl: GColor := clBlack); /// Создает текстовый объект - копию текстового объекта g constructor Create(g: TextABC); /// Размер шрифта в пунктах property FontSize: integer read pointsz write SetFSize; /// Прозрачен ли фон текстового объекта property TransparentBackground: boolean read tb write SetTB; /// Цвет фона текстового объекта property BackgroundColor: GColor read bc write SetBC; /// Возвращает клон текстового объекта function Clone0: ObjectABC; override; /// Возвращает клон текстового объекта function Clone: TextABC; end; /// Класс графических объектов "Правильный многоугольник" RegularPolygonABC = class(BoundedObjectABC) private n: integer; angl: real; a: array of Point; protected procedure SetWidth(Width: integer); override; procedure SetHeight(Height: integer); override; function GetCount: integer; virtual; procedure SetCount(c: integer); virtual; procedure SetAngle(a: real); procedure SetRadius(r: integer); function GetRadius: integer; procedure Init(x,y,r,nn: integer; cl: GColor); procedure InitBy(g: RegularPolygonABC); procedure Draw(x,y: integer; g: Graphics); override; public /// Создает правильный многоугольник с nn вершинами, радиусом r, цветом cl и координатами центра (x,y) constructor Create(x,y,r,nn: integer; cl: GColor := clWhite); /// Создает правильный многоугольник - копию правильного многоугольника g constructor Create(g: RegularPolygonABC); /// Находится ли точка (x,y) внутри правильного многоугольника function PtInside(x,y: integer): boolean; override; /// Количество вершин правильного многоугольника property Count: integer read GetCount write SetCount; /// Радиус правильного многоугольника property Radius: integer read GetRadius write SetRadius; /// Угол поворота (в градусах) property Angle: real read angl write SetAngle; /// Масштабирует правильный многоугольник в f раз (f>1 - увеличение, 0<f<1 - уменьшение) procedure Scale(f: real); override; /// Возвращает клон правильного многоугольника function Clone0: ObjectABC; override; /// Возвращает клон правильного многоугольника function Clone: RegularPolygonABC; end; /// Класс графических объектов "Звезда" StarABC=class(RegularPolygonABC) private r_rr: real; protected function GetRR: integer; procedure SetRR(r1: integer); function GetCount: integer; override; procedure SetCount(c: integer); override; procedure Draw(x,y: integer; g: Graphics); override; procedure Init(x,y,r,r1,nn: integer; cl: GColor); procedure InitBy(g: StarABC); public /// Создает звезду с nn вершинами, радиусом r, внутренним радиусом r1, цветом cl и координатами центра (x,y) constructor Create(x,y,r,r1,nn: integer; cl: GColor := clWhite); /// Создает звезду - копию звезды g constructor Create(g: StarABC); /// Внутренний радиус property InternalRadius: integer read GetRR write SetRR; /// Принадлежит ли точка внутренности объекта function PtInside(x,y: integer): boolean; override; /// Масштабирует звезду в f раз (f>1 - увеличение, 0<f<1 - уменьшение) procedure Scale(f: real); override; /// Возвращает клон звезды function Clone0: ObjectABC; override; /// Возвращает клон звезды function Clone: StarABC; end; /// Класс графических объектов "Рисунок" PictureABC = class(ObjectABC) protected p: Picture; sx,sy: real; // масштаб картинки по осям OX и OY; 1 - истинный размер; -1 - зеркальное отображение protected procedure SetWidth(Width: integer); override; procedure SetHeight(Height: integer); override; procedure SetTransparent(tt: boolean); function GetTransparent: boolean; procedure SetTransparentColor(c: GColor); function GetTransparentColor: GColor; procedure SetScaleX(ssx: real); procedure SetScaleY(ssy: real); procedure DrawAfterChangePicture(var oldRect: GRectangle); procedure Draw(x,y: integer; g: Graphics); override; procedure Init(x,y: integer; fname: string); procedure Init(x,y: integer; p: Picture); procedure InitBy(g: PictureABC); public /// Создает рисунок с координатами левого верхнего угла (x,y), считывая его из файла fname constructor Create(x,y: integer; fname: string); /// Создает рисунок с координатами левого верхнего угла (x,y), считывая его из объекта p constructor Create(x,y: integer; p: Picture); /// Создает рисунок - копию рисунка g constructor Create(g: PictureABC); /// Меняет изображение рисунка, считывая его из файла fname procedure ChangePicture(fname: string); /// Меняет изображение рисунка, считывая его из объекта p procedure ChangePicture(p: Picture); /// Сохраняет рисунок в файл fname procedure Save(fname: string); /// Зеркально отображает рисунок относительно вертикальной оси procedure FlipVertical; /// Зеркально отображает рисунок относительно горизонтальной оси procedure FlipHorizontal; /// Прозрачен ли рисунок property Transparent: boolean read GetTransparent write SetTransparent; /// Цвет, считающийся прозрачным property TransparentColor: GColor read GetTransparentColor write SetTransparentColor; /// Масштаб рисунка по оси X относительно исходного изображения. При отрицательных значениях ///происходит зеркальное отражение относительно вертикальной оси property ScaleX: real read sx write SetScaleX; /// Масштаб рисунка по оси Y относительно исходного изображения. При отрицательных значениях ///происходит зеркальное отражение относительно вертикальной оси property ScaleY: real read sy write SetScaleY; /// Возвращает клон рисунка function Clone0: ObjectABC; override; /// Возвращает клон рисунка function Clone: PictureABC; end; /// Класс графических объектов "Набор рисунков" MultiPictureABC = class(PictureABC) protected cur,cnt: integer; procedure SetCurrentPicture(i: integer); procedure Init(x,y: integer; fname: string); procedure Init(x,y: integer; p: Picture); procedure Init(x,y,w: integer; fname: string); procedure Init(x,y,w: integer; p: Picture); procedure InitBy(g: MultiPictureABC); procedure Draw(x,y: integer; g: Graphics); override; public /// Создает набор рисунков, состоящий из одного рисунка, загружая его из файла с именем fname. ///После создания рисунок отображается на экране в позиции (x,y). Остальные рисунки добавляются методом Add constructor Create(x,y: integer; fname: string); /// Создает набор рисунков, состоящий из одного рисунка, хранящегося в переменной p ///После создания рисунок отображается на экране в позиции (x,y). Остальные рисунки добавляются методом Add constructor Create(x,y: integer; p: Picture); /// Создает набор рисунков из объекта p типа Picture. Объект p должен хранить ///последовательность изображений одного размера, расположенных по горизонтали. ///Каждое изображение считается имеющим ширину w. Если ширина рисунка в объекте p не кратна w, ///то возникает исключение. После создания первый рисунок из набора отображается на экране в позиции (x,y) constructor Create(x,y,w: integer; p: Picture); /// Создает набор рисунков, загружая его из файла fname. Файл должен хранить ///последовательность изображений одного размера, расположенных по горизонтали. ///Каждое изображение считается имеющим ширину w. Если ширина рисунка в файле fname не кратна w, ///то возникает исключение. После создания первый рисунок из набора отображается на экране в позиции (x,y) constructor Create(x,y,w: integer; fname: string); /// Создает набор рисунков - копию набора рисунков g constructor Create(g: MultiPictureABC); /// Добавляет рисунок к набору, загружая его из файла fname. /// Рисунок должен иметь те же размеры, что и все рисунки из набора procedure Add(fname: string); /// Меняет набор рисунков на набор, состоящий из одного рисунка, загружая его из файла с именем fname procedure ChangePicture(fname: string); /// Меняет набор рисунков на набор, загружая его из файла с именем fname. ///Файл должен хранить последовательность изображений одного размера, ///расположенных по горизонтали. Каждое изображение считается имеющим ширину w procedure ChangePicture(w: integer; fname: string); ///Циклически переходит к следующему рисунку из набора procedure NextPicture; ///Циклически переходит к предыдующему рисунку из набора procedure PrevPicture; ///Номер текущего рисунка (нумерация с 1) property CurrentPicture: integer read cur write SetCurrentPicture; ///Количество рисунков в наборе property Count: integer read cnt; /// Возвращает клон набора рисунков function Clone0: ObjectABC; override; /// Возвращает клон набора рисунков function Clone: MultiPictureABC; end; /// Контейнер графических объектов. Сам является графическим объектом ContainerABC = class(ObjectABC) protected l: System.Collections.ArrayList; procedure SetWidth(Width: integer); override; procedure SetHeight(Height: integer); override; function GetCount: integer; procedure Init(x,y: integer); procedure InitBy(g: ContainerABC); procedure Draw(x,y: integer; g: Graphics); override; private procedure SetItem(i: integer; o: ObjectABC); function GetItem(i: integer): ObjectABC; procedure RecalcBounds; public ///Создает пустой контейнер графических объектов в позиции (x,y) ///Для его наполнения следует использовать метод Add. Координаты всех помещаемых ///в него графических объектов пересчитываются относительно точки (x,y) constructor Create(x,y: integer); ///Создает контейнер графических объектов - копию контейнера графических объектов g constructor Create(g: ContainerABC); ///Добавляет в контейнер графический объект g procedure Add(g: ObjectABC); ///Удаляет из контейнера графический объект g procedure Remove(g: ObjectABC); ///Отсоединяет от контейнера графический объект g. ///Объект g перестает иметь владельца и продолжает отображаться на экране в той же позиции procedure UnLink(g: ObjectABC); ///Принадлежит ли точка внутренности одного из графических объектов в контейнере function PtInside(x,y: integer): boolean; override; /// Количество графических объектов в контейнере property Count: integer read GetCount; /// Массив графических объектов в контейнере property Objects[i: integer]: ObjectABC read GetItem write SetItem; default; /// Возвращает клон контейнера графических объектов function Clone0: ObjectABC; override; /// Возвращает клон контейнера графических объектов function Clone: ContainerABC; end; /// Класс графических объектов "Доска" BoardABC = class(BoundedObjectABC) private nx,ny,szx,szy: integer; protected procedure Init(x,y,nx,ny,sszx,sszy: integer; cl: GColor := clWhite); procedure InitBy(g: BoardABC); procedure SetNX(nnx: integer); procedure SetNY(nny: integer); procedure SetSzX(sszx: integer); procedure SetSzY(sszy: integer); procedure Draw(x,y: integer; g: Graphics); override; public ///Создает доску nx на ny клеток цвета cl с размером клетки (ssxx,ssyy) в позиции (x,y). constructor Create(x,y,nx,ny,sszx,sszy: integer; cl: GColor := clWhite); ///Создает доску - копию доски g constructor Create(g: BoardABC); ///Количество клеток доски по горизонтали property DimX: integer read nx write SetNX; ///Количество клеток доски по вертикали property DimY: integer read ny write SetNY; ///Размер клетки по горизонтали property CellSizeX: integer read szx write SetSzX; ///Размер клетки по вертикали property CellSizeY: integer read szy write SetSzY; /// Возвращает клон доски function Clone0: ObjectABC; override; /// Возвращает клон доски function Clone: BoardABC; end; /// Класс графических объектов "Доска с объектами" ObjectBoardABC = class(BoardABC) private ar: array of ObjectABC; protected procedure Init(x,y,nn,mm,sszx,sszy: integer; cl: GColor); procedure InitBy(g: ObjectBoardABC); procedure SetObject(x,y: integer; ob: ObjectABC); function GetObject(x,y: integer): ObjectABC; public ///Создает доску с объектами nx на ny клеток цвета cl с размером клетки (ssxx,ssyy) в позиции (x,y). constructor Create(x,y,nn,mm,sszx,sszy: integer; cl: GColor := clWhite); ///Создает доску с объектами - копию доски g constructor Create(g: ObjectBoardABC); /// Удаляет объект в клетке с координатами (x,y) procedure DestroyObject(x,y: integer); procedure CreateRectangleABC(x,y,w,h: integer; c: GColor); function GetRectangle(x,y: integer): RectangleABC; /// Объект в клетке с координатами (x,y) property Items[x,y: integer]: ObjectABC read GetObject write SetObject; default; /// Меняет местами объекты в клетках с координатами (x1,y1) и (x2,y2) procedure SwapObjects(x1,y1,x2,y2: integer); /// Возвращает клон доски с объектами function Clone0: ObjectABC; override; /// Возвращает клон доски с объектами function Clone: ObjectBoardABC; end; /// Тип элемента управления ABCObject UIElementABC=class(RectangleABC) end; /// Тип массива графических объектов ObjectsABCArray = class private l: System.Collections.ArrayList; function GetCount: integer; public constructor Create(ll: System.Collections.ArrayList); procedure SetItem(i: integer; o: ObjectABC); function GetItem(i: integer): ObjectABC; /// i-тый графический объект на экране property Items[i: integer]: ObjectABC read GetItem write SetItem; default; /// Количество графических объектов на экране property Count: integer read GetCount; end; /// Блокирует рисование графических объектов. Возможна лишь перерисовка ///всего экрана вместе со всеми графическими объектами на нем вызовом RedrawObjects procedure LockDrawingObjects; /// Разблокирует рисование графических объектов procedure UnLockDrawingObjects; /// Перерисовывает все графическое окно вместе со всеми графическими объектами на нем procedure RedrawObjects; /// Переносит графический объект g на передний план procedure ToFront(grobj: ObjectABC); /// Переносит графический объект g на задний план procedure ToBack(grobj: ObjectABC); /// Количество графических объектов function ObjectsCount: integer; /// Графический объект под точкой (x,y) function ObjectUnderPoint(x,y: integer): ObjectABC; /// Графический объект под точкой p function ObjectUnderPoint(p: Point): ObjectABC; /// Поменять позиции графических объектов o1 и o2 procedure SwapPositions(o1,o2: ObjectABC); /// Элемент управления ABCObject под точкой (x,y) function UIElementUnderPoint(x,y: integer): UIElementABC; var /// Массив графических объектов Objects: ObjectsABCArray; ///-- procedure __InitModule__; implementation uses GraphABC, GraphABCHelper; var __l: System.Collections.ArrayList; __lUI: System.Collections.ArrayList; // элементы пользовательского интерфейса __LockDrawingObjects: boolean; tempbmp: Bitmap; procedure drawRect(r: GRectangle); // Низкоуровневая процедура (не вызывается пользователем). Вызывает безусловную перерисовку прямоугольника. var rr,rtmp: System.Drawing.Rectangle; begin LockGraphics; // ToDo Сделать то же самое при выходе за границу справа и внизу!!! if r.X<0 then r.X := 0; if r.Width<=0 then r.Width := 1; if r.Y<0 then r.Y := 0; if r.Height<=0 then r.Height := 1; var bmp := GraphBufferBitmap; rr := new System.Drawing.Rectangle(r.Left,r.Top,r.Right-r.Left,r.Bottom-r.Top); rtmp := new System.Drawing.Rectangle(0,0,r.Right-r.Left,r.Bottom-r.Top); //tb := new Bitmap(r.Right-r.Left,r.Bottom-r.Top); var tb := GetView(tempbmp,rtmp); var gb := System.Drawing.Graphics.FromImage(tb); gb.SmoothingMode := GraphWindowGraphics.SmoothingMode; // gb.TextRenderingHint := System.Drawing.Text.TextRenderingHint.AntiAlias; var bmp1 := GetView(bmp,rr); gb.DrawImageUnscaled(bmp1,0,0); //gb.Transform := GraphWindowGraphics.Transform; // ??? bmp1.Dispose; bmp1 := nil; for var i:=0 to __l.Count-1 do begin var g := ObjectABC(__l[i]); if g.Visible and g.IntersectRect(r) then g.Draw(g.Left-r.Left,g.Top-r.Top,gb); end; for var i:=0 to __lUI.Count-1 do begin var g := ObjectABC(__lUI[i]); if g.Visible and g.IntersectRect(r) then g.Draw(g.Left-r.Left,g.Top-r.Top,gb); end; //var db := DrawInBuffer; //DrawInBuffer := False; // if not __LockDrawingObjects then //var m := GraphWindowGraphics.Transform; // ??? //GraphWindowGraphics.ResetTransform; // ??? GraphWindowGraphics.DrawImage(tb,r.Left,r.Top); //GraphWindowGraphics.Transform := m; // ??? /// b.Draw(r.Left,r.Top); //DrawInBuffer := db; tb.Dispose; tb := nil; gb.Dispose; gb := nil; UnLockGraphics; end; procedure ABCRedrawProc; begin {if __LockDrawingObjects then Redraw else }RedrawObjects; end; procedure RedrawObjects; begin drawRect(new GRectangle(0,0,WindowWidth,WindowHeight)); end; procedure LockDrawingObjects; begin __LockDrawingObjects:=True; end; procedure UnLockDrawingObjects; begin __LockDrawingObjects:=False; RedrawObjects; end; procedure ToFront(grobj: ObjectABC); var ind: integer; begin // if grobj is UIElementABC then exit; if grobj=nil then exit; ind:=__l.IndexOf(grobj); if ind=__l.Count-1 then Exit; if ind=-1 then Exit; // __l.OwnsObjects:=False; __l.RemoveAt(ind); __l.Add(grobj); // __l.OwnsObjects:=True; grobj.Redraw; end; procedure ToBack(grobj: ObjectABC); var ind: integer; begin // if grobj is UIElementABC then exit; if grobj=nil then exit; ind:=__l.IndexOf(grobj); if ind=0 then Exit; if ind=-1 then Exit; // __l.OwnsObjects:=False; __l.RemoveAt(ind); __l.Insert(0,grobj); // __l.OwnsObjects:=True; grobj.Redraw; end; function ObjectsCount: integer; begin Result:=__l.Count; end; function ObjectUnderPoint(x,y: integer): ObjectABC; begin Result:=nil; for var i := Objects.Count-1 downto 0 do begin var g := Objects[i]; if g.PtInside(x,y) then begin Result:=g; Exit end; end; end; function ObjectUnderPoint(p: Point): ObjectABC; begin Result:=ObjectUnderPoint(p.x,p.y); end; procedure SwapPositions(o1,o2: ObjectABC); var p: Point; begin p := o1.Position; o1.Position := o2.Position; o2.Position := p; end; function UIElementUnderPoint(x,y: integer): UIElementABC; begin Result:=nil; for var i:=__lUI.Count-1 downto 0 do begin var g := UIElementABC(__lUI[i]); if g.PtInside(x,y) then begin Result := g; Exit end; end; end; //------ ObjectABC ------ procedure ObjectABC.Init(x,y,w,h: integer; cl: GColor); begin fx := x; fy := y; if w<1 then w := 1; if h<1 then h := 1; fw := w; fh := h; col := cl; vis := True; txt := ''; txtvis := true; txtscale := 0.8; fcol := clBlack; fname := 'Arial'; fstyle := fsNormal; if Self is UIElementABC then __lUI.Add(Self) else __l.Add(Self); Owner := nil; end; procedure ObjectABC.InitBy(g: ObjectABC); begin fx := g.fx; fy := g.fy; fw := g.fw; fh := g.fh; _dx := g._dx; _dy := g._dy; col := g.col; vis := g.Visible; txt := g.Text; txtvis := g.TextVisible; txtscale := g.TextScale; fname := g.fname; fstyle := g.fstyle; if Self is UIElementABC then __lUI.Add(Self) else __l.Add(Self); Owner := g.Owner; end; constructor ObjectABC.Create(x,y,w,h: integer; cl: GColor); begin Init(x,y,w,h,cl); end; constructor ObjectABC.Create(g: ObjectABC); begin InitBy(g); end; destructor ObjectABC.Destroy; begin Visible:=False; if Owner<>nil then Exit; if Self is UIElementABC then __lUI.Remove(Self) else __l.Remove(Self); end; procedure ObjectABC.DrawAfterChangeBounds(oldBounds,newBounds: GRectangle); // Низкоуровневая процедура (не вызывается пользователем). Вызывает перерисовку после изменения объектом своих границ. var l,t: integer; r: GRectangle; begin if __LockDrawingObjects then Exit; l:=0; t:=0; if Owner<>nil then begin CalcOwnerOffset(l,t); Owner.RecalcBounds; end; oldBounds.Offset(l,t); newBounds.Offset(l,t); if oldBounds.IntersectsWith(newBounds) then begin // Грубое решение проблемы неотрисовки части изображения var rDiff := newBounds.Right - oldBounds.Right; if rDiff > 0 then newBounds.Width += rDiff; var bDiff := newBounds.Bottom - oldBounds.Bottom; if bDiff > 0 then newBounds.Height += bDiff; var xDiff := oldBounds.X - newBounds.X; if xDiff > 0 then begin newBounds.X -= xDiff; newBounds.Width += xDiff; end; var yDiff := oldBounds.Y - newBounds.Y; if yDiff > 0 then begin newBounds.y -= yDiff; newBounds.Height += yDiff; end; r := GRectangle.Union(oldBounds,newBounds); //DrawRectangle(r.X,r.Y,r.Right,r.Bottom); //TextOut(0,0,r.ToString); //r.Width := r.Width + 5; drawRect(r); end else begin drawRect(newBounds); drawRect(oldBounds) end; end; procedure ObjectABC.DrawText(x,y: integer; g: Graphics); var tw,th,fs,d: integer; m: real; bs: BrushStyleType; begin if not TextVisible or (txt='') then exit; bs := BrushStyle; SetBrushStyle(bsClear); // ToDo очень много выделений памяти! GraphABC.SetFontColor(fcol); GraphABC.SetFontName(fname); GraphABC.SetFontStyle(fstyle); SetFontSize(100); tw := TextWidth(txt); th := TextHeight(txt); m := max(tw/Width,th/Height); // m:=th/Height; fs := round(txtscale/m*100); if fs<1 then fs := 1; SetFontSize(fs); tw := TextWidth(txt); th := TextHeight(txt); { if fw>50 then d:=10 else if fw>20 then d:=5 else d:=0;} if tw > Width-d then begin fs := round(fs*(Width-(Height-th)*2)/tw); SetFontSize(fs); tw := TextWidth(txt); th := TextHeight(txt); end; //DrawRectangle(x+(Width-tw) div 2,y+(Height-th) div 2,x+(Width-tw) div 2 + tw,y+(Height-th) div 2 + th,g); TextOut(x+(Width-tw) div 2,y+(Height-th) div 2,txt,g); SetBrushStyle(bs); end; procedure ObjectABC.Draw(x,y: integer); begin Draw(x,y,GraphWindowGraphics); end; procedure ObjectABC.SetCenter(p: Point); begin MoveTo(p.x-fw div 2,p.y-fh div 2); end; function ObjectABC.GetCenter: Point; begin Result.x := fx + fw div 2; Result.y := fy + fh div 2; end; procedure ObjectABC.SetPosition(p: Point); begin MoveTo(p.x,p.y); end; function ObjectABC.GetPosition: Point; begin Result.x := fx; Result.y := fy; end; procedure ObjectABC.SetX(x: integer); begin moveto(x,fy); end; procedure ObjectABC.SetY(y: integer); begin moveto(fx,y); end; procedure ObjectABC.SetVis(v: boolean); begin if vis=v then Exit; vis := v; Redraw; end; procedure ObjectABC.SetFontName(name: string); begin if name = fname then Exit; fname := name; Redraw; end; procedure ObjectABC.SetFontColor(fc: GColor); begin if fcol = fc then Exit; fcol := fc; Redraw; end; procedure ObjectABC.SetFontStyle(fs: FontStyleType); begin if fs = fstyle then Exit; fstyle := fs; Redraw; end; procedure ObjectABC.ObjectABCSetSize(Width,Height: integer); var r: GRectangle; begin if Width<1 then Exit; if Height<1 then Exit; if (fw=Width) and (fh=Height) then Exit; r := Bounds; fw := Width; fh := Height; if not __LockDrawingObjects then DrawAfterChangeBounds(r,Bounds); end; procedure ObjectABC.SetWidth(Width: integer); begin ObjectABCSetSize(Width,Height); end; procedure ObjectABC.SetHeight(Height: integer); var r: GRectangle; begin if Height<1 then Exit; if fh=Height then Exit; r := Bounds; fh := Height; if not __LockDrawingObjects then DrawAfterChangeBounds(r,Bounds) end; procedure ObjectABC.SetTxtVis(b: boolean); begin if txtvis=b then Exit; txtvis := b; Redraw; end; procedure ObjectABC.SetNum(n: integer); begin Text := IntToStr(n); end; procedure ObjectABC.SetRealNum(r: real); begin Text := string.Format('{0:f1}',r).Replace(',','.'); end; function ObjectABC.GetNum: integer; var err: integer; begin Val(Text,Result,err); if err<>0 then Result:=0; end; function ObjectABC.GetRealNum: real; var err: integer; begin Val(Text,Result,err); if err<>0 then Result:=0; end; procedure ObjectABC.SetTextScale(r: real); begin if txtscale=r then Exit; if r<0.01 then r := 0.01 else if r>1 then r := 1; txtscale := r; Redraw; end; procedure ObjectABC.SetOwner(o: ContainerABC); begin if ow<>nil then ow.Unlink(Self); ow := nil; if o<>nil then o.Add(Self) end; procedure ObjectABC.SetColor(cl: GColor); begin if col=cl then Exit; col := cl; Redraw; end; procedure ObjectABC.SetText(t: string); begin if txt=t then exit; txt := t; Redraw; end; procedure ObjectABC.InternalDraw; var b: boolean; begin b := DrawInBuffer; DrawInBuffer := False; if not __LockDrawingObjects then Draw(fx,fy); DrawInBuffer := b; end; procedure ObjectABC.CalcOwnerOffset(var l,t: integer); var o: ContainerABC; begin l:=0; t:=0; o:=Owner; while o<>nil do begin l := l + o.Left; t := t + o.Top; o:=o.Owner; end; end; procedure ObjectABC.Redraw; var l,t: integer; r: GRectangle; begin if not __LockDrawingObjects then begin CalcOwnerOffset(l,t); r := Bounds; r.Offset(l,t); drawRect(r); end; end; procedure ObjectABC.RedrawNow; var l,t: integer; r: GRectangle; begin CalcOwnerOffset(l,t); r := Bounds; r.Offset(l,t); drawRect(r); end; procedure ObjectABC.MoveTo(x,y: integer); var r,r1: GRectangle; begin if (fx=x) and (fy=y) then Exit; r := Bounds; setCoords(x,y); r1 := Bounds; DrawAfterChangeBounds(r,r1) end; procedure ObjectABC.MoveOn(a,b: integer); begin MoveTo(fx+a,fy+b); end; procedure ObjectABC.Move; begin MoveOn(dx,dy); end; procedure ObjectABC.SetCoords(x,y: integer); begin fx := x; fy := y; end; procedure ObjectABC.Scale(f: real); begin // Assert(f>0,'масштабный коэффициент<0'); Width := round(Width*f); Height := round(Height*f); end; procedure ObjectABC.ToFront; begin ABCObjects.ToFront(Self); end; procedure ObjectABC.ToBack; begin ABCObjects.ToBack(Self); end; function ObjectABC.Bounds: GRectangle; begin Result := new GRectangle(fx,fy,fw,fh); end; function ObjectABC.Intersect(g: ObjectABC): boolean; var r: GRectangle; b1,b2: Bitmap; gb1,gb2: Graphics; begin { Result := IntersectRect(g.Bounds); if Result=False then exit;} r := GRectangle.Intersect(Bounds,g.Bounds); if (r.Width<=0) or (r.Height<=0) then begin Result := False; exit; end; //write(r.Width,' ',r.Height,' '); b1 := new Bitmap(r.Width,r.Height); gb1 := Graphics.FromImage(b1); gb1.FillRectangle(Brushes.White,0,0,r.Width,r.Height); Draw(Left-r.Left,Top-r.Top,gb1); //GraphWindowGraphics.DrawImage(b1,400,0); b2 := new Bitmap(r.Width,r.Height); gb2 := Graphics.FromImage(b2); GraphABC.Brush.Color := clWhite; gb2.FillRectangle(Brushes.White,0,0,r.Width,r.Height); g.Draw(g.Left-r.Left,g.Top-r.Top,gb2); //GraphWindowGraphics.DrawImage(b2,450,0); Result := ImageIntersect(b1,b2); end; function ObjectABC.IntersectRect(r: GRectangle): boolean; begin Result := r.IntersectsWith(Bounds); end; function ObjectABC.PtInside(x,y: integer): boolean; begin Result := Bounds.Contains(x,y); end; //------ BoundedObjectABC ------- constructor BoundedObjectABC.Create(x,y,w,h: integer; cl: GColor); begin // А нужно ли это? Init(x,y,w,h,cl); end; constructor BoundedObjectABC.Create(g: BoundedObjectABC); begin InitBy(g); end; procedure BoundedObjectABC.Init(x,y,w,h: integer; cl: GColor); begin inherited Init(x,y,w,h,cl); bcol := clBlack; bw := 1; fil := True; bor := True; end; procedure BoundedObjectABC.InitBy(g: BoundedObjectABC); begin inherited InitBy(g); bcol := g.bcol; bw := g.bw; fil := g.fil; bor := g.bor; end; procedure BoundedObjectABC.SetBColor(cl: GColor); begin if bcol=cl then Exit; bcol:=cl; Redraw; end; procedure BoundedObjectABC.SetBW(w: integer); begin if bw=w then Exit; bw:=w; Redraw; end; function BoundedObjectABC.GetBW: integer; begin Result := bw; end; procedure BoundedObjectABC.SetFilled(f: boolean); begin if fil=f then Exit; fil := f; Redraw; end; procedure BoundedObjectABC.SetBordered(b: boolean); begin if bor=b then Exit; bor := b; Redraw; end; procedure BoundedObjectABC.SetDrawSettings; begin SetBrushColor(Color); if Fil then SetBrushStyle(bsSolid) else SetBrushStyle(bsClear); if Bor then SetPenStyle(psSolid) else SetPenStyle(psClear); SetPenColor(BCol); SetPenWidth(bw); end; //------ RectangleABC ------- constructor RectangleABC.Create(x,y,w,h: integer; cl: GColor); begin inherited Init(x,y,w,h,cl); InternalDraw; end; constructor RectangleABC.Create(g: RectangleABC); begin inherited InitBy(g); end; procedure RectangleABC.Draw(x,y: integer; g: Graphics); var z,z1: integer; begin SetDrawSettings; z := BorderWidth div 2; z1 := (BorderWidth-1) div 2; LockGraphics; GraphABCHelper.Rectangle(x+z,y+z,x+Width-z1,y+Height-z1,g); DrawText(x,y,g); UnLockGraphics; end; function RectangleABC.Clone0: ObjectABC; begin Result := new RectangleABC(Self); end; function RectangleABC.Clone: RectangleABC; begin Result := new RectangleABC(Self); end; //------ SquareABC ------- constructor SquareABC.Create(x,y,w: integer; cl: GColor); begin inherited Create(x,y,w,w,cl); end; constructor SquareABC.Create(g: SquareABC); begin inherited Create(g); end; procedure SquareABC.SetWidth(Width: integer); begin ObjectABCSetSize(Width,Width); end; procedure SquareABC.SetHeight(Height: integer); begin SetWidth(Height); end; procedure SquareABC.Scale(f: real); begin Width := round(Width*f); end; function SquareABC.Clone0: ObjectABC; begin Result := SquareABC.Create(Self); end; function SquareABC.Clone: SquareABC; begin Result := SquareABC.Create(Self); end; //------ EllipseABC ------- constructor EllipseABC.Create(x,y,w,h: integer; cl: GColor); begin inherited Init(x,y,w,h,cl); InternalDraw; end; constructor EllipseABC.Create(g: EllipseABC); begin inherited InitBy(g); end; procedure EllipseABC.Draw(x,y: integer; g: Graphics); var z,z1: integer; begin SetDrawSettings; z := BorderWidth div 2; z1 := (BorderWidth-1) div 2; LockGraphics; Ellipse(x+z,y+z,x+Width-z1,y+Height-z1,g); DrawText(x,y,g); UnLockGraphics; end; function EllipseABC.Clone0: ObjectABC; begin Result := new EllipseABC(Self); end; function EllipseABC.Clone: EllipseABC; begin Result := new EllipseABC(Self); end; //------ CircleABC ------- constructor CircleABC.Create(x,y,r: integer; cl: GColor); begin inherited Create(x-r,y-r,2*r+1,2*r+1,cl); end; constructor CircleABC.Create(g: CircleABC); begin inherited Create(g); end; procedure CircleABC.scale(f: real); begin Width := round(Width*f); end; procedure CircleABC.SetWidth(Width: integer); begin if Width mod 2 = 0 then Width := Width - 1; ObjectABCSetSize(Width,Width); end; procedure CircleABC.SetHeight(Height: integer); begin SetWidth(Height); end; function CircleABC.Clone0: ObjectABC; begin Result := new CircleABC(Self); end; function CircleABC.Clone: CircleABC; begin Result := new CircleABC(Self); end; procedure CircleABC.SetRadius(r: integer); begin if Width = 2*r+1 then Exit; MoveOn(Width div 2-r, Width div 2-r); Width := 2*r+1; end; function CircleABC.GetRadius: integer; begin Result := Width div 2; end; //------ RoundRectABC ------- constructor RoundRectABC.Create(x,y,w,h,rr: integer; cl: GColor); begin Init(x,y,w,h,rr,cl); InternalDraw; end; constructor RoundRectABC.Create(g: RoundRectABC); begin InitBy(g); end; procedure RoundRectABC.SetRadius(rr: integer); begin if r=rr then Exit; if rr > Width div 2 then rr := Width div 2; if rr > Height div 2 then rr := Height div 2; r := rr; Redraw; end; procedure RoundRectABC.Draw(x,y: integer; g: Graphics); var z,z1: integer; begin SetDrawSettings; z := BorderWidth div 2; z1 := (BorderWidth-1) div 2; LockGraphics; RoundRect(x+z,y+z,x+Width-z1,y+Height-z1,2*r,2*r,g); DrawText(x,y,g); UnLockGraphics; end; procedure RoundRectABC.Init(x,y,w,h,rr: integer; cl: GColor); begin inherited Init(x,y,w,h,cl); r := rr; end; procedure RoundRectABC.InitBy(g: RoundRectABC); begin inherited InitBy(g); r := g.r; end; function RoundRectABC.Clone0: ObjectABC; begin Result := new RoundRectABC(Self); end; function RoundRectABC.Clone: RoundRectABC; begin Result := new RoundRectABC(Self); end; //------ RoundSquareABC ------- constructor RoundSquareABC.Create(x,y,w,r: integer; cl: GColor); begin inherited Create(x,y,w,w,r,cl); end; constructor RoundSquareABC.Create(g: RoundSquareABC); begin inherited Create(g); end; procedure RoundSquareABC.SetWidth(Width: integer); begin ObjectABCSetSize(Width,Width); end; procedure RoundSquareABC.SetHeight(Height: integer); begin ObjectABCSetSize(Height,Height); end; procedure RoundSquareABC.Scale(f: real); begin Width := round(Width*f); end; function RoundSquareABC.Clone0: ObjectABC; begin Result := new RoundSquareABC(Self); end; function RoundSquareABC.Clone: RoundSquareABC; begin Result := new RoundSquareABC(Self); end; //------ TextABC ------- procedure TextABC.Init(x,y,pt: integer; cl: GColor; txt: string); var w,h: integer; begin SetFontName(fname); SetFontSize(pt); w := TextWidth(txt); h := TextHeight(txt); inherited Init(x,y,w,h,cl); tb := True; bc := clWhite; pointsz := pt; Self.txt := txt; end; procedure TextABC.InitBy(g: TextABC); begin inherited InitBy(g); tb := g.tb; bc := g.bc; pointsz := g.pointsz; txt := g.txt; end; constructor TextABC.Create(x,y,pt: integer; txt: string; cl: GColor); begin Init(x,y,pt,cl,txt); InternalDraw; end; constructor TextABC.Create(g: TextABC); begin InitBy(g); InternalDraw; end; procedure TextABC.Draw(x,y: integer; g: Graphics); var bs: BrushStyleType; begin SetBrushColor(bc); if tb then begin bs := BrushStyle; SetBrushStyle(bsClear); end else SetBrushStyle(bsSolid); SetFontName(fname); SetFontSize(pointsz); GraphABC.SetFontColor(Color); LockGraphics; TextOut(x,y,Text,g); UnLockGraphics; if tb then SetBrushStyle(bs); end; procedure TextABC.SetText(t: string); var r: GRectangle; begin if Text=t then exit; r := Bounds; txt := t; LockGraphics; fw := TextWidth(t); fh := TextHeight(t); UnLockGraphics; if not __LockDrawingObjects then DrawAfterChangeBounds(r,Bounds) end; {procedure TextABC.SetFName(fn: string); begin if fname=fn then exit; fname:=fn; SetFontName(fname); SetFontSize(pointsz); Width:=TextWidth(Text); Height:=TextHeight(Text); Redraw; end;} procedure TextABC.SetFSize(sz: integer); var r: GRectangle; begin if pointsz = sz then Exit; pointsz := sz; r := Bounds; SetFontName(fname); SetFontSize(pointsz); fw := TextWidth(Text); fh := TextHeight(Text); if not __LockDrawingObjects then DrawAfterChangeBounds(r,Bounds) // Redraw; // это неверно! end; procedure TextABC.SetTB(b: boolean); begin if tb=b then Exit; tb := b; Redraw; end; procedure TextABC.SetBC(c: GColor); begin if bc=c then Exit; bc := c; Redraw; end; function TextABC.Clone0: ObjectABC; begin Result := TextABC.Create(Self); end; function TextABC.Clone: TextABC; begin Result := TextABC.Create(Self); end; //------ RegularPolygonABC ------ procedure RegularPolygonABC.Init(x,y,r,nn: integer; cl: GColor); begin inherited Init(x-r,y-r,2*r+1,2*r+1,cl); n := nn; SetLength(a,nn); angl := 0; end; procedure RegularPolygonABC.InitBy(g: RegularPolygonABC); begin inherited InitBy(g); n := g.n; SetLength(a,n); angl := g.angl; end; constructor RegularPolygonABC.Create(x,y,r,nn: integer; cl: GColor); begin Init(x,y,r,nn,cl); InternalDraw; end; constructor RegularPolygonABC.Create(g: RegularPolygonABC); begin InitBy(g); end; procedure RegularPolygonABC.Draw(x,y: integer; g: Graphics); begin SetDrawSettings; var phi := -90 + Angle; var z := BorderWidth div 2; var r := Width div 2; r := r - z; var x0 := x + Width div 2; var y0 := y + Width div 2; for var i:=0 to n-1 do begin a[i].x := round(r*cos(phi*Pi/180)) + x0; a[i].y := round(r*sin(phi*Pi/180)) + y0; phi := phi+360/n; end; LockGraphics; Polygon(a,g); DrawText(x,y,g); UnLockGraphics; end; function RegularPolygonABC.PtInside(x,y:integer): boolean; var a,x0,y0,dx,dy,pz: integer; phi: real; part: real; begin part := 360/n; a := Width div 2 + 1; x0 := Left + Width div 2; y0 := Top + Width div 2; dx := x - x0; dy := y - y0; if dx=0 then begin if dy<0 then phi := 0 else phi := 180; end else begin phi := 90 + arctan(dy/dx)*180/Pi; if dx<0 then phi := phi + 180; end; pz := trunc(phi/part); phi := phi - pz*part; if phi>part/2 then phi := part - phi; Phi := part/2-Phi; Result := sqrt(dx*dx+dy*dy) < a*cos(part/2/180*Pi)/cos(phi/180*Pi); end; procedure RegularPolygonABC.SetAngle(a: real); begin if angl=a then Exit; angl := a; Redraw; end; procedure RegularPolygonABC.SetWidth(Width: integer); begin if Width mod 2 = 0 then Width := Width - 1; // Ширина и высота должны быть нечетными ObjectABCSetSize(Width,Width); end; procedure RegularPolygonABC.SetHeight(Height: integer); begin SetWidth(Height); end; procedure RegularPolygonABC.SetCount(c: integer); begin if c<3 then c := 3; if c>500 then c := 500; if n=c then Exit; n := c; SetLength(a,n); Redraw; end; function RegularPolygonABC.GetCount: integer; begin Result := n; end; procedure RegularPolygonABC.SetRadius(r: integer); begin if Width = 2*r+1 then Exit; MoveOn(Width div 2-r, Width div 2-r); Width := 2*r+1; end; function RegularPolygonABC.GetRadius: integer; begin Result := Width div 2; end; procedure RegularPolygonABC.Scale(f: real); begin Width := round(Width*f); end; function RegularPolygonABC.Clone0: ObjectABC; begin Result := RegularPolygonABC.Create(Self); end; function RegularPolygonABC.Clone: RegularPolygonABC; begin Result := RegularPolygonABC.Create(Self); end; //------ StarABC ------ procedure StarABC.Init(x,y,r,r1,nn: integer; cl: GColor); var rr: integer; begin if r<r1 then begin rr := r; r := r1; r1 := rr; end; r_rr := r/r1; inherited Init(x,y,r,2*nn,cl); end; procedure StarABC.InitBy(g: StarABC); begin r_rr := g.r_rr; inherited InitBy(g); end; constructor StarABC.Create(x,y,r,r1,nn: integer; cl: GColor); begin Init(x,y,r,r1,nn,cl); InternalDraw; end; constructor StarABC.Create(g: StarABC); begin InitBy(g); end; procedure StarABC.Scale(f: real); begin Width := round(Width*f); end; function StarABC.Clone0: ObjectABC; begin Result := StarABC.Create(Self); end; function StarABC.Clone: StarABC; begin Result := StarABC.Create(Self); end; function StarABC.GetCount: integer; begin Result := inherited GetCount div 2; end; procedure StarABC.SetCount(c: integer); begin inherited SetCount(c*2); end; function StarABC.GetRR: integer; begin Result := round(Radius/r_rr); end; procedure StarABC.SetRR(r1: integer); begin if r1>Radius then Exit; if r_rr = Radius/r1 then Exit; r_rr := Radius/r1; Redraw; end; procedure StarABC.Draw(x,y: integer; g: Graphics); var r,rr,z,x0,y0: integer; phi: real; begin SetDrawSettings; phi := -90 + Angle; z := BorderWidth; r := Width div 2; r := r - z; x0 := x + Width div 2; y0 := y + Width div 2; rr := round(r/r_rr); for var i:=0 to Count*2-1 do begin if i mod 2 = 0 then begin a[i].x := round(r*cos(phi*Pi/180)) + x0; a[i].y := round(r*sin(phi*Pi/180)) + y0; end else begin a[i].x := round(rr*cos(phi*Pi/180)) + x0; a[i].y := round(rr*sin(phi*Pi/180)) + y0; end; phi := phi + 360/Count/2; end; LockGraphics; Polygon(a,g); DrawText(x,y,g); UnLockGraphics; end; function StarABC.PtInside(x,y: integer): boolean; var a,x0,y0,pz: integer; phi: real; part,dx,dy,b,c,r: real; begin part := 360/Count; a := Width div 2 + 1; x0 := Left + Width div 2; y0 := Top + Width div 2; dx := x - x0; dy := y - y0; if dx=0 then begin if dy<0 then phi := 0 else phi := 180; end else begin phi := 90 + arctan(dy/dx)*180/Pi; if dx<0 then phi := phi + 180; end; pz := trunc(phi/part); phi := phi - pz*part; if phi>part/2 then phi := part - phi; b := (InternalRadius+1)*cos(part/2*Pi/180); c := (InternalRadius+1)*sin(part/2*Pi/180); r := sqrt(dx*dx+dy*dy); dx := r * cos(phi*Pi/180); dy := r * sin(phi*Pi/180); Result := c*(dx-a) < dy*(b-a); end; //------ PictureABC ------ procedure PictureABC.Init(x,y: integer; fname: string); begin sx := 1; sy := 1; p := Picture.Create(fname); p.Transparent := False; inherited Init(x,y,p.Width,p.Height,clBlack); end; procedure PictureABC.Init(x,y: integer; p: Picture); begin sx := 1; sy := 1; Self.p := p; inherited Init(x,y,p.Width,p.Height,clBlack); end; procedure PictureABC.InitBy(g: PictureABC); begin inherited InitBy(g); sx := g.sx; sy := g.sy; p := g.p; end; constructor PictureABC.Create(x,y: integer; fname: string); begin Init(x,y,fname); InternalDraw; end; constructor PictureABC.Create(g: PictureABC); begin InitBy(g); end; constructor PictureABC.Create(x,y: integer; p: Picture); begin sx := 1; sy := 1; Self.p := p; inherited Init(x,y,p.Width,p.Height,clBlack); InternalDraw; end; procedure PictureABC.DrawAfterChangePicture(var oldRect: GRectangle); begin fw := round(abs(sx)*p.Width) + 1; fh := round(abs(sy)*p.Height) + 1; if not __LockDrawingObjects then DrawAfterChangeBounds(oldRect,Bounds) end; procedure PictureABC.ChangePicture(fname: string); var r: GRectangle; begin r := Bounds; p.Load(fname); p.Transparent := False; DrawAfterChangePicture(r); end; procedure PictureABC.ChangePicture(p: Picture); var r: GRectangle; begin r := Bounds; Self.p := p; p.Transparent := False; DrawAfterChangePicture(r); end; procedure PictureABC.Draw(x,y: integer; g: Graphics); var bw,bh: integer; begin LockGraphics; if (sx=1) and (sy=1) then p.Draw(x,y,g) else begin bw := p.Width; bh := p.Height; if sx<0 then x := x - round(bw*sx); if sy<0 then y := y - round(bh*sy); p.Draw(x,y,round(bw*sx),round(bh*sy),g); end; DrawText(x,y,g); UnLockGraphics; end; procedure PictureABC.SetWidth(Width: integer); begin if Width<=0 then exit; if sx>0 then sx := Width/p.Width else sx := -Width/p.Width; inherited SetWidth(Width); end; procedure PictureABC.SetHeight(Height: integer); begin if Height<=0 then exit; if sy>0 then sy := Height/p.Height else sy := -Height/p.Height; inherited SetHeight(Height); end; procedure PictureABC.SetTransparent(tt: boolean); begin if p.Transparent = tt then Exit; p.Transparent := tt; Redraw; end; function PictureABC.GetTransparent: boolean; begin Result := p.Transparent; end; procedure PictureABC.SetTransparentColor(c: GColor); begin if p.TransparentColor = c then Exit; p.TransparentColor := c; Redraw; end; function PictureABC.GetTransparentColor: GColor; begin Result := p.TransparentColor; end; procedure PictureABC.SetScaleX(ssx: real); var r: GRectangle; begin if sx=ssx then exit; r := Bounds; fw := round(abs(ssx)*p.Width)+1; sx := ssx; if not __LockDrawingObjects then DrawAfterChangeBounds(r,Bounds) end; procedure PictureABC.SetScaleY(ssy: real); var r: GRectangle; begin if sy=ssy then exit; r := Bounds; fh := round(abs(ssy)*p.Height)+1; sy := ssy; if not __LockDrawingObjects then DrawAfterChangeBounds(r,Bounds) end; procedure PictureABC.Save(fname: string); begin p.Save(fname); end; procedure PictureABC.FlipVertical; begin p.FlipVertical; Redraw; end; procedure PictureABC.FlipHorizontal; begin p.FlipHorizontal; Redraw; end; function PictureABC.Clone0: ObjectABC; begin Result := new PictureABC(Self) end; function PictureABC.Clone: PictureABC; begin Result := new PictureABC(Self) end; //------ MultiPictureABC ------ procedure MultiPictureABC.Init(x,y: integer; fname: string); begin cur := 1; cnt := 1; inherited Init(x,y,fname); end; procedure MultiPictureABC.Init(x,y: integer; p: Picture); begin cur := 1; cnt := 1; inherited Init(x,y,p); end; procedure MultiPictureABC.Init(x,y,w: integer; fname: string); begin p := Picture.Create(fname); p.Transparent := True; if p.Width mod w <> 0 then raise Exception.Create('Неверно задана ширина картинки'); cur := 1; cnt := p.Width div w; inherited Init(x,y,p); fw := w; end; procedure MultiPictureABC.Init(x,y,w: integer; p: Picture); begin Self.p := p; if p.Width mod w <> 0 then raise Exception.Create('Неверно задана ширина картинки'); cur := 1; cnt := p.Width div w; inherited Init(x,y,p); fw := w; end; procedure MultiPictureABC.InitBy(g: MultiPictureABC); begin inherited InitBy(g); cur := g.cur; cnt := g.cnt; end; constructor MultiPictureABC.Create(x,y: integer; fname: string); begin Init(x,y,fname); InternalDraw; end; constructor MultiPictureABC.Create(x,y: integer; p: Picture); begin Init(x,y,p); InternalDraw; end; constructor MultiPictureABC.Create(x,y,w: integer; fname: string); begin Init(x,y,w,fname); InternalDraw; end; constructor MultiPictureABC.Create(x,y,w: integer; p: Picture); begin Init(x,y,w,p); InternalDraw; end; constructor MultiPictureABC.Create(g: MultiPictureABC); begin InitBy(g); end; procedure MultiPictureABC.Draw(x,y: integer; g: Graphics); begin LockGraphics; p.Draw(x,y,new System.Drawing.Rectangle((cur-1)*Width,0,Width,Height),g); UnLockGraphics; end; procedure MultiPictureABC.ChangePicture(fname: string); begin p.Load(fname); cur := 1; cnt := 1; Width := p.Width; Height := p.Height; Redraw; end; procedure MultiPictureABC.ChangePicture(w: integer; fname: string); begin p.Load(fname); if p.Width mod w <> 0 then raise Exception.Create('Неверно задана ширина картинки'); cur := 1; cnt := p.Width div w; Width := w; Height := p.Height; Redraw; end; procedure MultiPictureABC.Add(fname: string); var p1: Picture; r,r1: System.Drawing.Rectangle; begin Inc(cnt); p1 := Picture.Create(fname); if (p1.Width<>Width) or (p1.Height<>Height) then raise Exception.Create('Размеры картинки в файле '+fname+' отличаются от размеров MultiPictureABC'); p1.Transparent := Transparent; p.Width := p.Width + Width; r1 := new System.Drawing.Rectangle(0,0,Width,Height); r := new System.Drawing.Rectangle((cnt-1)*Width,0,Width,Height); p.CopyRect(r,p1,r1); end; procedure MultiPictureABC.SetCurrentPicture(i: integer); begin if (i<1) or (i>Count) then raise Exception.Create('Номер картинки '+IntToStr(i)+' находится вне диапазона '+IntToStr(i)+'..'+IntToStr(Count)); cur := i; Redraw; end; procedure MultiPictureABC.NextPicture; begin if cur>=cnt then CurrentPicture:=1 else CurrentPicture:=cur+1 end; procedure MultiPictureABC.PrevPicture; begin if cur=1 then CurrentPicture:=cnt else CurrentPicture:=cur-1 end; function MultiPictureABC.Clone0: ObjectABC; begin Result := new MultiPictureABC(Self); end; function MultiPictureABC.Clone: MultiPictureABC; begin Result := new MultiPictureABC(Self); end; //------ ContainerABC ------ procedure ContainerABC.Init(x,y: integer); begin l := new System.Collections.ArrayList; inherited Init(x,y,0,0,clWhite); end; procedure ContainerABC.InitBy(g: ContainerABC); begin l := new System.Collections.ArrayList; inherited InitBy(g); for var i:=0 to g.Count-1 do begin var ob := g[i].Clone0; ob.Owner := Self; end; end; constructor ContainerABC.Create(x,y: integer); begin Init(x,y); end; constructor ContainerABC.Create(g: ContainerABC); begin InitBy(g); end; procedure ContainerABC.SetItem(i: integer; o: ObjectABC); begin l[i] := o; end; function ContainerABC.GetItem(i: integer): ObjectABC; begin Result := ObjectABC(l[i]) end; procedure ContainerABC.Add(g: ObjectABC); var b: boolean; begin { if Self is UIElementABC then exit;} b := g.Visible; g.Visible := False; __l.Remove(g); l.Add(g); g.ow := Self; g.Visible := b; RecalcBounds; Redraw; end; procedure ContainerABC.Remove(g: ObjectABC); begin l.Remove(g); end; procedure ContainerABC.Draw(x,y: integer; g: Graphics); begin LockGraphics; for var i:=0 to l.Count-1 do begin var ob := ObjectABC(l[i]); if ob.Visible then ob.Draw(x+ob.Left,y+ob.Top,g); end; UnLockGraphics; end; function ContainerABC.PtInside(x,y:integer): boolean; begin Result:=False; for var i:=0 to l.Count-1 do begin var g := ObjectABC(l[i]); if g.PtInside(x-Left,y-Top) then begin Result := True; Exit; end; end; end; procedure ContainerABC.SetWidth(Width: integer); begin if Self.Width = 0 then Exit; var scale := Width/Self.Width; for var i:=0 to l.Count-1 do begin var g := ObjectABC(l[i]); g.Left := round(g.Left*scale); g.Width := round(g.Width*scale); end; inherited SetWidth(Width); end; procedure ContainerABC.SetHeight(Height: integer); begin if Self.Height=0 then Exit; var scale:=Height/Self.Height; for var i:=1 to l.Count do begin var g := ObjectABC(l[i]); g.Top := round(g.Top*scale); g.Height := round(g.Height*scale); end; inherited SetHeight(Height); end; procedure ContainerABC.RecalcBounds; begin if Count=0 then Exit; var r := ObjectABC(l[0]).Bounds; for var i:=1 to l.Count-1 do r := GRectangle.Union(r,ObjectABC(l[i]).Bounds); fx := fx + r.Left; fy := fy + r.Top; fw := r.Right - r.Left; fh := r.Bottom - r.Top; for var i:=0 to l.Count-1 do ObjectABC(l[i]).SetCoords(ObjectABC(l[i]).Left-r.Left,ObjectABC(l[i]).Top-r.Top); end; procedure ContainerABC.UnLink(g: ObjectABC); begin l.Remove(g); Redraw; RecalcBounds; end; function ContainerABC.Clone0: ObjectABC; begin Result := new ContainerABC(Self); end; function ContainerABC.Clone: ContainerABC; begin Result := new ContainerABC(Self); end; function ContainerABC.GetCount: integer; begin Result := l.Count; end; //------ BoardABC ------ procedure BoardABC.Init(x,y,nx,ny,sszx,sszy: integer; cl: GColor); begin Self.nx := nx; Self.ny := ny; szx := sszx; szy := sszy; inherited Init(x,y,nx*szx+1,ny*szy+1,cl); end; procedure BoardABC.InitBy(g: BoardABC); begin nx := g.nx; ny := g.ny; szx := g.szx; szy := g.szy; inherited InitBy(g); end; constructor BoardABC.Create(x,y,nx,ny,sszx,sszy: integer; cl: GColor); begin Init(x,y,nx,ny,sszx,sszy,cl); InternalDraw; end; constructor BoardABC.Create(g: BoardABC); begin InitBy(g); end; procedure BoardABC.SetNX(nnx: integer); var r: GRectangle; begin if nx = nnx then Exit; r := Bounds; nx := nnx; if not __LockDrawingObjects then DrawAfterChangeBounds(r,Bounds) end; procedure BoardABC.SetNY(nny: integer); var r: GRectangle; begin if ny = nny then Exit; r := Bounds; ny := nny; if not __LockDrawingObjects then DrawAfterChangeBounds(r,Bounds) end; procedure BoardABC.SetSzX(sszx: integer); var r: GRectangle; begin if szx = sszx then Exit; r := Bounds; szx := sszx; if not __LockDrawingObjects then DrawAfterChangeBounds(r,Bounds) end; procedure BoardABC.SetSzY(sszy: integer); var r: GRectangle; begin if szy = sszy then Exit; r := Bounds; szy := sszy; if not __LockDrawingObjects then DrawAfterChangeBounds(r,Bounds) end; procedure BoardABC.Draw(x,y: integer; g: Graphics); begin SetDrawSettings; LockGraphics; FillRectangle(x,y,x+Width,y+Height,g); for var i:=0 to nx do Line(x+i*szx,y,x+i*szx,y+Height-1,g); for var i:=0 to ny do Line(x,y+i*szy,x+Width-1,y+i*szy,g); UnLockGraphics; end; function BoardABC.Clone0: ObjectABC; begin Result := new BoardABC(Self); end; function BoardABC.Clone: BoardABC; begin Result := new BoardABC(Self); end; //------ ObjectBoardABC ------ procedure ObjectBoardABC.Init(x,y,nn,mm,sszx,sszy: integer; cl: GColor); begin inherited Init(x,y,nn,mm,sszx,sszy,cl); SetLength(ar,nn*mm); for var i:=0 to nn*mm-1 do ar[i] := nil; end; procedure ObjectBoardABC.InitBy(g: ObjectBoardABC); begin inherited InitBy(g); SetLength(ar,g.ar.Length); for var i:=0 to g.ar.Length-1 do ar[i] := g.ar[i].Clone; end; constructor ObjectBoardABC.Create(x,y,nn,mm,sszx,sszy: integer; cl: GColor); begin Init(x,y,nn,mm,sszx,sszy,cl); InternalDraw; end; constructor ObjectBoardABC.Create(g: ObjectBoardABC); begin InitBy(g); end; procedure ObjectBoardABC.CreateRectangleABC(x,y,w,h: integer; c: GColor); begin SetObject(x,y,new RectangleABC(0,0,w,h,c)); end; procedure ObjectBoardABC.DestroyObject(x,y: integer); begin if Self[x,y]<>nil then begin Self[x,y].Destroy; Self[x,y] := nil; end; end; procedure ObjectBoardABC.SetObject(x,y: integer; ob: ObjectABC); begin ar[(y-1)*DimX + x - 1] := ob; if ob=nil then Exit; ob.dx := x; ob.dy := y; // использую dx и dy для задания клеточных координат на доске ob.Center := new Point(Left+CellSizeX*(x-1)+CellSizeX div 2,Top+CellSizeY*(y-1)+CellSizeY div 2); end; function ObjectBoardABC.GetObject(x,y: integer): ObjectABC; begin Result := ar[(y-1)*DimX + x - 1]; end; function ObjectBoardABC.GetRectangle(x,y: integer): RectangleABC; begin Result := RectangleABC(ar[(y-1)*DimX + x - 1]); end; procedure ObjectBoardABC.SwapObjects(x1,y1,x2,y2: integer); var ob1,ob2: ObjectABC; csx,csy: integer; begin ob1 := Self[x1,y1]; ob2 := Self[x2,y2]; Self[x1,y1] := ob2; Self[x2,y2] := ob1; csx := CellSizeX; csy := CellSizeY; if ob1<>nil then begin ob1.dx := x2; ob1.dy := y2; ob1.Center := new Point(Left+csx*(x2-1)+csx div 2,Top+csy*(y2-1)+csy div 2); end; if ob2<>nil then begin ob2.dx := x1; ob2.dy := y1; ob2.Center := new Point(Left+csx*(x1-1)+csx div 2,Top+csy*(y1-1)+csy div 2); end; end; function ObjectBoardABC.Clone0: ObjectABC; begin Result := new ObjectBoardABC(Self); end; function ObjectBoardABC.Clone: ObjectBoardABC; begin Result := new ObjectBoardABC(Self); end; //------ ObjectsABCArray ------ constructor ObjectsABCArray.Create(ll: System.Collections.ArrayList); begin l := ll; end; function ObjectsABCArray.GetCount: integer; begin Result := l.Count; end; procedure ObjectsABCArray.SetItem(i: integer; o: ObjectABC); begin l[i] := o; end; function ObjectsABCArray.GetItem(i: integer): ObjectABC; begin Result := ObjectABC(l[i]) end; var __initialized := false; procedure __InitModule; begin __l := new System.Collections.ArrayList; __lUI := new System.Collections.ArrayList; Objects := new ObjectsABCArray(__l); tempbmp := new Bitmap(System.Windows.Forms.Screen.PrimaryScreen.Bounds.Width,System.Windows.Forms.Screen.PrimaryScreen.Bounds.Height); SetWindowTitle('ABC Objects'); RedrawProc := ABCRedrawProc; end; procedure __InitModule__; begin if not __initialized then begin __initialized := true; GraphABC.__InitModule__; __InitModule; end; end; initialization __InitModule; end.