diff --git a/Configuration/GlobalAssemblyInfo.cs b/Configuration/GlobalAssemblyInfo.cs
index c9c13b1ce..b7a9941ab 100644
--- a/Configuration/GlobalAssemblyInfo.cs
+++ b/Configuration/GlobalAssemblyInfo.cs
@@ -15,7 +15,7 @@ internal static class RevisionClass
public const string Major = "3";
public const string Minor = "4";
public const string Build = "2";
- public const string Revision = "1857";
+ public const string Revision = "1859";
public const string MainVersion = Major + "." + Minor;
public const string FullVersion = Major + "." + Minor + "." + Build + "." + Revision;
diff --git a/Configuration/Version.defs b/Configuration/Version.defs
index c7fed2a4e..d46493bbb 100644
--- a/Configuration/Version.defs
+++ b/Configuration/Version.defs
@@ -1,4 +1,4 @@
%COREVERSION%=2
-%REVISION%=1857
+%REVISION%=1859
%MINOR%=4
%MAJOR%=3
diff --git a/ReleaseGenerators/PascalABCNET_version.nsh b/ReleaseGenerators/PascalABCNET_version.nsh
index 0bb02d3a3..29dcdf331 100644
--- a/ReleaseGenerators/PascalABCNET_version.nsh
+++ b/ReleaseGenerators/PascalABCNET_version.nsh
@@ -1 +1 @@
-!define VERSION '3.4.2.1857'
+!define VERSION '3.4.2.1859'
diff --git a/SyntaxTree/tree/Tree.cs b/SyntaxTree/tree/Tree.cs
index 3bc6046ae..6a4daa023 100644
--- a/SyntaxTree/tree/Tree.cs
+++ b/SyntaxTree/tree/Tree.cs
@@ -3600,7 +3600,7 @@ namespace PascalABCCompiler.SyntaxTree
///
- ///Описание переменных одной строкой. Не содержит var, т.к. встречается исключительно внутри другой конструкции.Может встречаться как до beginа (внутри variable_definitions), так и как внутриблочное описание (внутри var_statement).
+ ///Описание переменных одной строкой. Не содержит var, т.к. встречается исключительно внутри другой конструкции. Может встречаться как до beginа (внутри variable_definitions), так и как внутриблочное описание (внутри var_statement).
///
[Serializable]
diff --git a/SyntaxTree/tree/tree.xml b/SyntaxTree/tree/tree.xml
index 07315f2e5..462da26c5 100644
--- a/SyntaxTree/tree/tree.xml
+++ b/SyntaxTree/tree/tree.xml
@@ -4525,7 +4525,7 @@
-
+
diff --git a/SyntaxTreeConverters/StandardSyntaxConverter.cs b/SyntaxTreeConverters/StandardSyntaxConverter.cs
index 5a78a2cee..c37ce721a 100644
--- a/SyntaxTreeConverters/StandardSyntaxConverter.cs
+++ b/SyntaxTreeConverters/StandardSyntaxConverter.cs
@@ -66,11 +66,11 @@ namespace PascalABCCompiler.SyntaxTreeConverters
//new SimplePrettyPrinterVisitor("D:\\Tree.txt").ProcessNode(root);
//FillParentNodeVisitor.New.ProcessNode(root);
-
+
/*var cv = CollectLightSymInfoVisitor.New;
cv.ProcessNode(root);
cv.Output(@"Light1.txt");*/
-
+
/*try
{
//root.visit(new SimplePrettyPrinterVisitor(@"d:\\zzz4.txt"));
@@ -80,7 +80,7 @@ namespace PascalABCCompiler.SyntaxTreeConverters
System.IO.File.AppendAllText(@"d:\\zzz4.txt",e.Message);
}*/
-
+
#endif
return root;
diff --git a/SyntaxVisitors/YieldVisitors/RenameSameBlockLocalVarsVisitor.cs b/SyntaxVisitors/YieldVisitors/RenameSameBlockLocalVarsVisitor.cs
index 98b1d1dc8..f59a73517 100644
--- a/SyntaxVisitors/YieldVisitors/RenameSameBlockLocalVarsVisitor.cs
+++ b/SyntaxVisitors/YieldVisitors/RenameSameBlockLocalVarsVisitor.cs
@@ -105,7 +105,36 @@ namespace SyntaxVisitors
--CurrentLevel;
}
- public override void visit(var_statement vs)
+ public override void visit(var_def_statement var_def)
+ {
+ if (var_def.vars.idents.Any(id => id.name.StartsWith("$")))
+ {
+ base.visit(var_def); // SSM 17/07/16 исправление ошибки - не обходилось выражение-инициализатор
+ return;
+ }
+
+ var newLocalNames = var_def.vars.idents.Select(id =>
+ {
+ var low = id.name
+ //.ToLower()
+ ;
+
+ var newName = this.CreateNewVariableName(low);
+ //BlockNamesStack[CurrentLevel].Add(low, newName);
+ BlockNamesStack[CurrentLevel][low] = newName;
+ return new ident(newName, id.source_context);
+ });
+
+ var newVS = new var_def_statement(new ident_list(newLocalNames.ToArray()),
+ var_def.vars_type,
+ var_def.inital_value);
+
+ Replace(var_def, newVS);
+ listNodes[listNodes.Count - 1] = newVS; //SSM 8.11.18
+ base.visit(newVS);
+ }
+
+ /*public override void visit(var_statement vs)
{
if (vs.var_def.vars.idents.Any(id => id.name.StartsWith("$")))
{
@@ -113,15 +142,17 @@ namespace SyntaxVisitors
return;
}
- var newLocalNames = vs.var_def.vars.idents.Select(id =>
- {
- var low = id.name/*.ToLower()*/;
+ var newLocalNames = vs.var_def.vars.idents.Select(id =>
+ {
+ var low = id.name
+ //.ToLower()
+ ;
- var newName = this.CreateNewVariableName(low);
- //BlockNamesStack[CurrentLevel].Add(low, newName);
- BlockNamesStack[CurrentLevel][low] = newName;
- return new ident(newName, id.source_context);
- });
+ var newName = this.CreateNewVariableName(low);
+ //BlockNamesStack[CurrentLevel].Add(low, newName);
+ BlockNamesStack[CurrentLevel][low] = newName;
+ return new ident(newName, id.source_context);
+ });
var newVS = new var_statement(new var_def_statement(new ident_list(newLocalNames.ToArray()),
vs.var_def.vars_type,
@@ -130,7 +161,7 @@ namespace SyntaxVisitors
Replace(vs, newVS);
base.visit(newVS);
- }
+ }/* */
public override void visit(variable_definitions vd)
{
diff --git a/TestSuite/CompilationSamples/ABCDatabases.pas b/TestSuite/CompilationSamples/ABCDatabases.pas
new file mode 100644
index 000000000..81f85be7e
--- /dev/null
+++ b/TestSuite/CompilationSamples/ABCDatabases.pas
@@ -0,0 +1,471 @@
+unit ABCDatabases;
+//uses PrintAttributeUnit;
+
+function PrintAttributeString(a: object): string; forward;
+function PrintAttributeString(a: object; fProvider: System.IFormatProvider): string; forward;
+
+type
+ Country = auto class
+ _name, _capital: string;
+ _population: integer;
+ _continent: string;
+ public
+ [PrintAttribute(0, -32)]
+ property Название: string read _name;
+ [PrintAttribute(0, -32)]
+ property Name: string read _name;
+ [PrintAttribute(' ', 1, -19)]
+ property Столица: string read _capital;
+ [PrintAttribute(' ', 1, -19)]
+ property Capital: string read _capital;
+ [PrintAttribute(3, 13, 'd')]
+ property Население: integer read _population;
+ [PrintAttribute(3, 13, 'd')]
+ property Population: integer read _population;
+ [PrintAttribute(' ', 2, -9)]
+ property Континент: string read _continent;
+ [PrintAttribute(' ', 2, -9)]
+ property Continent: string read _continent;
+ end;
+
+ ТипПола = (Муж, Жен);
+
+ Pupil = auto class
+ _name: string;
+ _gender: boolean;
+ _height: integer;
+ _cls: integer;
+ _inSunSchool: boolean;
+ function getGender: ТипПола := _gender ? Муж : Жен;
+ public
+ [PrintAttribute(0, -16)]
+ property Name: string read _name;
+ [PrintAttribute(0, -16)]
+ property Фамилия: string read _name;
+ [PrintAttribute(' ', 1, -3)]
+ property Gender: ТипПола read getGender;
+ [PrintAttribute(' ', 1, -3)]
+ property Пол: ТипПола read getGender;
+ [PrintAttribute(' ', 2, 3, 'd')]
+ property Height: integer read _height;
+ [PrintAttribute(' ', 2, 3, 'd')]
+ property Рост: integer read _height;
+ [PrintAttribute(' ',3, 2, 'd')]
+ property Cls: integer read _cls;
+ [PrintAttribute(' ',3, 2, 'd')]
+ property Класс: integer read _cls;
+ [PrintAttribute(' ', 4, -5)]
+ property InSunSchool: boolean read _inSunSchool;
+ [PrintAttribute(' ', 4, -5)]
+ property УчитсяВКШ: boolean read _inSunSchool;
+
+ end;
+
+function GenderToBoolean(a: string): boolean := a = 'Муж';
+function InSunSchoolToBoolean(a: string): boolean := a = 'Да';
+
+type
+ Fitness = auto class
+ private
+ _code, _year, _month, _time: integer;
+ public
+ [PrintAttribute('( Code = ', 0, 2)]
+ property Код: integer read _code;
+ [PrintAttribute('( Code = ', 0, 2)]
+ property Code: integer read _code;
+ [PrintAttribute(' , Year = ', 1, 4)]
+ property Год: integer read _year;
+ [PrintAttribute(' , Year = ', 1, 4)]
+ property Year: integer read _year;
+ [PrintAttribute(' , Month = ', 2, 2)]
+ property Месяц: integer read _month;
+ [PrintAttribute(' , Month = ', 2, 2)]
+ property Month: integer read _month;
+ [PrintAttribute(' , Time = ', 3, 2)]
+ property Время: integer read _time;
+ [PrintAttribute(' , Time = ', 3, 2)]
+ property Time: integer read _time;
+ function ToString: string; override;
+ begin
+ result := PrintAttributeString(self);
+ end;
+ end;
+
+ Abitur = auto class
+ private
+ _name: string;
+ _year: integer;
+ _school: integer;
+ public
+ [PrintAttribute('( Name = ', 0, -11)]
+ property Фамилия: string read _name;
+ [PrintAttribute('( Name = ', 0, -11)]
+ property Name: string read _name;
+ [PrintAttribute(', Year = ', 1, 4)]
+ property Год: integer read _year;
+ [PrintAttribute(', Year = ', 1, 4)]
+ property Year: integer read _year;
+ [PrintAttribute(' , School = ', 2, 2)]
+ property Школа: integer read _school;
+ [PrintAttribute(' , School = ', 2, 2)]
+ property School: integer read _school;
+ function ToString: string; override;
+ begin
+ result := PrintAttributeString(self);
+ end;
+ end;
+
+ Debtor = auto class
+ private
+ _name: string;
+ _flat: integer;
+ _debt: real;
+ public
+ [PrintAttribute('( Name = ', 0, -11)]
+ property Фамилия: string read _name;
+ [PrintAttribute('( Name = ', 0, -11)]
+ property Name: string read _name;
+ [PrintAttribute(', Flat = ', 1, 3)]
+ property Квартира: integer read _flat;
+ [PrintAttribute(', Flat = ', 1, 3)]
+ property Flat: integer read _flat;
+ [PrintAttribute(' , Debt = ', 2, 7, 'f2')]
+ property Долг: real read _debt;
+ [PrintAttribute(' , Debt = ', 2, 7, 'f2')]
+ property Debt: real read _debt;
+ [PrintAttribute(' , Entrance = ', 3, 1)]
+ property Подъезд: integer read (_flat - 1) div 36 + 1;
+ [PrintAttribute(' , Entrance = ', 3, 1)]
+ property Entrance: integer read (_flat - 1) div 36 + 1;
+ [PrintAttribute(' , Floor = ', 4, 1)]
+ property Этаж: integer read (_flat - 1) mod 36 div 4 + 1;
+ [PrintAttribute(' , Floor = ', 4, 1)]
+ property Floor: integer read (_flat - 1) mod 36 div 4 + 1;
+ function ToString: string; override;
+ begin
+ result := PrintAttributeString(self);
+ end;
+ end;
+
+FuelStation = auto class
+ private
+ _brand, _price: integer;
+ _company, _street: string;
+ public
+ [PrintAttribute('( Brand = ', 0, 2)]
+ property Марка: integer read _brand;
+ [PrintAttribute('( Brand = ', 0, 2)]
+ property Brand: integer read _brand;
+ [PrintAttribute(', Price = ', 1, 4)]
+ property Цена: integer read _price;
+ [PrintAttribute(', Price = ', 1, 4)]
+ property Price: integer read _price;
+ [PrintAttribute(', Company = ', 2, -12)]
+ property Компания: string read _company;
+ [PrintAttribute(', Company = ', 2, -12)]
+ property Company: string read _company;
+ [PrintAttribute(', Street = ', 3, -15)]
+ property Улица: string read _street;
+ [PrintAttribute(', Street = ', 3, -15)]
+ property Street: string read _street;
+ function ToString: string; override;
+ begin
+ result := PrintAttributeString(self);
+ end;
+ end;
+
+PupilExam = auto class
+ private
+ _name: string;
+ _school, _point0, _point1, _point2: integer;
+ [PrintAttribute(' , Point : ', 2, 3)]
+ property Балл0: integer read _point0;
+ [PrintAttribute(' , Point : ', 2, 3)]
+ property Point0: integer read _point0;
+ [PrintAttribute(' , ', 3, 3)]
+ property Балл1: integer read _point1;
+ [PrintAttribute(' , ', 3, 3)]
+ property Point1: integer read _point1;
+ [PrintAttribute(' , ', 4, 3)]
+ property Балл2: integer read _point2;
+ [PrintAttribute(' , ', 4, 3)]
+ property Point2: integer read _point2;
+ public
+ [PrintAttribute('( Name = ', 0, -16)]
+ property ФИО: string read _name;
+ [PrintAttribute('( Name = ', 0, -16)]
+ property Name: string read _name;
+ [PrintAttribute(', School = ', 1, 2)]
+ property Школа: integer read _school;
+ [PrintAttribute(', School = ', 1, 2)]
+ property School: integer read _school;
+ property Балл: array of integer read Arr(_point0, _point1, _point2);
+ property Point: array of integer read Arr(_point0, _point1, _point2);
+ function ToString: string; override;
+ begin
+ result := PrintAttributeString(self);
+ end;
+ end;
+
+PupilMark = auto class
+ private
+ _name: string;
+ _cls: integer;
+ _subject: string;
+ _mark: integer;
+ public
+ [PrintAttribute('( Name = ', 0, -16)]
+ property ФИО: string read _name;
+ [PrintAttribute('( Name = ', 0, -16)]
+ property Name: string read _name;
+ [PrintAttribute(', Cls = ', 1, 2)]
+ property Класс: integer read _cls;
+ [PrintAttribute(', Cls = ', 1, 2)]
+ property Cls: integer read _cls;
+ [PrintAttribute(' , Subject = ', 2, -11)]
+ property Предмет: string read _subject;
+ [PrintAttribute(' , Subject = ', 2, -11)]
+ property Subject: string read _subject;
+ [PrintAttribute(' , Mark = ', 3, 1)]
+ property Оценка: integer read _mark;
+ [PrintAttribute(' , Mark = ', 3, 1)]
+ property Mark: integer read _mark;
+ function ToString: string; override;
+ begin
+ result := PrintAttributeString(self);
+ end;
+ end;
+
+function ЗаполнитьМассивСтран: array of Country;
+begin
+ var fname := 'c:\Program files (x86)\PascalABC.NET\Files\Databases\Страны.csv';
+ if fname = '' then
+ raise new System.ApplicationException('Не найден массив стран Databases\Страны.csv');
+ Result := ReadLines(fname)
+ .Select(s->s.ToWords(';'))
+ .Select(w->new Country(w[0],w[1],w[2].ToInteger,w[3])).ToArray;
+end;
+
+function GetCountries: array of Country := ЗаполнитьМассивСтран;
+
+function ЗаполнитьМассивУчеников: array of Pupil;
+begin
+ var fname := 'c:\Program files (x86)\PascalABC.NET\Files\Databases\Ученики.csv';
+ if fname = '' then
+ raise new System.ApplicationException('Не найден массив учеников Databases\Ученики.csv');
+ Result := ReadLines(fname)
+ .Select(s->s.ToWords(';'))
+ .Select(w->new Pupil(w[0],GenderToBoolean(w[2]),w[4].ToInteger,w[1].ToInteger,
+ InSunschoolToBoolean(w[3]))).ToArray;
+end;
+
+function GetPupils: array of Pupil := ЗаполнитьМассивУчеников;
+
+function GetFitness: array of Fitness;
+begin
+ var fname := 'Fitness.tst';
+ if not FileExists(fname) then
+ begin
+ fname := 'Fitness.txt';
+ if not FileExists(fname) then
+ raise new System.IO.FileNotFoundException('Не найден файл-источник для массива объектов Fitness');
+ end;
+ try
+ Result := ReadLines(fname)
+ .Select(s->s.ToWords(','))
+ .Select(w->new Fitness(w[0].ToInteger,w[1].ToInteger,w[2].ToInteger,w[3].ToInteger)).ToArray;
+ except
+ raise new System.FormatException('Файл-источник для массива объектов Fitness содержит неверные данные');
+ end;
+end;
+
+function GetAbiturs: array of Abitur;
+begin
+ var fname := 'Abitur.tst';
+ if not FileExists(fname) then
+ begin
+ fname := 'Abitur.txt';
+ if not FileExists(fname) then
+ raise new System.IO.FileNotFoundException('Не найден файл-источник для массива объектов Abitur');
+ end;
+ try
+ Result := ReadLines(fname)
+ .Select(s->s.ToWords(','))
+ .Select(w->new Abitur(w[0],w[1].ToInteger,w[2].ToInteger)).ToArray;
+ except
+ raise new System.FormatException('Файл-источник для массива объектов Abitur содержит неверные данные');
+ end;
+end;
+
+function GetDebtors: array of Debtor;
+begin
+ var fname := 'Debtor.tst';
+ if not FileExists(fname) then
+ begin
+ fname := 'Debtor.txt';
+ if not FileExists(fname) then
+ raise new System.IO.FileNotFoundException('Не найден файл-источник для массива объектов Debtor');
+ end;
+ try
+ Result := ReadLines(fname)
+ .Select(s->s.ToWords(','))
+ .Select(w->new Debtor(w[0],w[1].ToInteger,w[2].ToReal)).ToArray;
+ except
+ raise new System.FormatException('Файл-источник для массива объектов Debtor содержит неверные данные');
+ end;
+end;
+
+function GetFuelStations: array of FuelStation;
+begin
+ var fname := 'FuelStation.tst';
+ if not FileExists(fname) then
+ begin
+ fname := 'FuelStation.txt';
+ if not FileExists(fname) then
+ raise new System.IO.FileNotFoundException('Не найден файл-источник для массива объектов FuelStation');
+ end;
+ try
+ Result := ReadLines(fname)
+ .Select(s->s.ToWords(','))
+ .Select(w->new FuelStation(w[0].ToInteger,w[1].ToInteger,w[2],w[3])).ToArray;
+ except
+ raise new System.FormatException('Файл-источник для массива объектов FuelStation содержит неверные данные');
+ end;
+end;
+
+function GetPupilExams: array of PupilExam;
+begin
+ var fname := 'PupilExam.tst';
+ if not FileExists(fname) then
+ begin
+ fname := 'PupilExam.txt';
+ if not FileExists(fname) then
+ raise new System.IO.FileNotFoundException('Не найден файл-источник для массива объектов PupilExam');
+ end;
+ try
+ Result := ReadLines(fname)
+ .Select(s->s.ToWords(','))
+ .Select(w->new PupilExam(w[0],w[1].ToInteger,w[2].ToInteger,w[3].ToInteger,w[4].ToInteger)).ToArray;
+ except
+ raise new System.FormatException('Файл-источник для массива объектов PupilExam содержит неверные данные');
+ end;
+end;
+
+function GetPupilMarks: array of PupilMark;
+begin
+ var fname := 'PupilMark.tst';
+ if not FileExists(fname) then
+ begin
+ fname := 'PupilMark.txt';
+ if not FileExists(fname) then
+ raise new System.IO.FileNotFoundException('Не найден файл-источник для массива объектов PupilMark');
+ end;
+ try
+ Result := ReadLines(fname)
+ .Select(s->s.ToWords(','))
+ .Select(w->new PupilMark(w[0],w[1].ToInteger,w[2],w[3].ToInteger)).ToArray;
+ except
+ raise new System.FormatException('Файл-источник для массива объектов PupilMark содержит неверные данные');
+ end;
+end;
+
+function PrintAttributeString(a: object; fProvider: System.IFormatProvider): string;
+begin
+ var t := a.GetType();
+ var res := new Dictionary();
+ foreach var p in t.GetProperties(System.Reflection.BindingFlags.Public
+ or System.Reflection.BindingFlags.NonPublic or System.Reflection.BindingFlags.Instance) do
+ begin
+ var att := p.GetCustomAttribute(typeof(PrintAttribute), false) as PrintAttribute;
+ if att = nil then
+ continue;
+ var (c, n, w, f) := (att.Comment, att.Num, att.Width, att.Fmt);
+ var val := '';
+ var o := p.GetValue(a, nil);
+ if (f <> '') and (o is System.IFormattable) then
+ begin
+ val := System.IFormattable(o).ToString(f, fProvider);
+ end
+ else
+ begin
+ val := o.ToString;
+ end;
+ if w > 0 then
+ val := val.PadLeft(w)
+ else if w < 0 then
+ val := val.PadRight(-w);
+ res[n] := c + val;
+ end;
+ result := nil;
+ if res.Keys.Count = 0 then
+ exit;
+ result := '';
+ foreach var k in res.Keys.OrderBy(e -> e) do
+ begin
+ result += res[k];
+ end;
+ var delim := Copy(result, 2, 1);
+ if result.StartsWith('{') then
+ result += (delim = ' ') ? ' }' : '}'
+ else if result.StartsWith('[') then
+ result += (delim = ' ') ? ' ]' : ']'
+ else if result.StartsWith('(') then
+ result += (delim = ' ') ? ' )' : ')'
+ else if result.StartsWith('''') then
+ result += (delim = ' ') ? ' ''' : ''''
+ else if result.StartsWith('"') then
+ result += (delim = ' ') ? ' "' : '"';
+end;
+
+function PrintAttributeString(a: object): string;
+begin
+ result := PrintAttributeString(a, nil);
+end;
+
+function ToStr(params a: array of object): string;
+begin
+ result := '';
+ var b := false;
+ foreach var e in a do
+ begin
+ if b then
+ result += ' '
+ else
+ b := true;
+ if e is real then
+ result += real(e).ToString(2)
+ else if e is string then
+ result += e.ToString()
+ else if e.GetType.FullName.StartsWith('System.Tuple') then
+ begin
+ var b1 := false;
+ foreach var e1 in e.GetType.GetProperties do
+ begin
+ if b1 then
+ result += ' '
+ else
+ b1 := true;
+ result += ToStr(Arr(e1.GetValue(e,nil)));
+ end;
+ end
+ else if e is System.Collections.IEnumerable then
+ begin
+ var b1 := false;
+ var e1 := (e as System.Collections.IEnumerable).GetEnumerator;
+ while e1.MoveNext do
+ begin
+ if b1 then
+ result += ' '
+ else
+ b1 := true;
+ result += ToStr(Arr(e1.Current));
+ end;
+ end
+ else
+ result += e.ToString();
+ end;
+end;
+
+begin
+
+end.
\ No newline at end of file
diff --git a/TestSuite/CompilationSamples/BlockFileOfT.pas b/TestSuite/CompilationSamples/BlockFileOfT.pas
new file mode 100644
index 000000000..fa7dc444a
--- /dev/null
+++ b/TestSuite/CompilationSamples/BlockFileOfT.pas
@@ -0,0 +1,783 @@
+(************************************************************************************)
+// Copyright (©) Cergey Latchenko ( github.com/SunSerega | forum.mmcs.sfedu.ru/u/sun_serega )
+// This code is distributed under the Unlicense
+// For details please see LICENSE.md or here:
+// https://github.com/SunSerega/PascalABC.Net-BlockFileOfT/blob/master/LICENSE.md
+(************************************************************************************)
+// Copyright (©) Сергей латченко ( github.com/SunSerega | forum.mmcs.sfedu.ru/u/sun_serega )
+// Этот код распространяется под Unlicense
+// Для деталей смотрите в файл LICENSE.md или сюда:
+// https://github.com/SunSerega/PascalABC.Net-BlockFileOfT/blob/master/LICENSE.md
+(************************************************************************************)
+
+///Модуль содержащий тип BlockFileOf
+///Этот тип - альтернатива стандартному file of T
+///Основное преимущество - скорость работы
+unit BlockFileOfT;
+
+interface
+
+uses System.Runtime.InteropServices;
+uses System.IO;
+
+type
+ ///--
+ BlockFileBase = abstract class
+
+ protected fi:FileInfo;
+ protected _offset:int64;
+ protected str:FileStream;
+ protected bw:BinaryWriter;
+ protected br:BinaryReader;
+
+ protected linked := new List;
+
+ protected procedure Link(f:BlockFileBase);
+
+ protected procedure UnLink;
+
+ private class function MessageBox(wnd: System.IntPtr; message, caption: string; flags: cardinal):integer;
+ external 'User32.dll';
+
+ end;
+
+ ///Тип, записывающий данные в файл по принципу схожему с "file of "
+ ///Но в отличии от "file of " - данный тип сохраняет всю запись одним блоком,
+ ///так, как она записа в памяти.
+ ///Это даёт значительное преимущество по скорости, но ограничевает,
+ ///типы, которые могут быть использованы в виде полей
+ ///
+ ///Ожидается, что в видет шаблонного параметра будет передана запись,
+ ///не содержащая динамичных полей.
+ ///Иначе целостность данных будет терятся
+ ///Это значит, что поля записи T и всех вложенных записей - НЕ могут быть:
+ /// -Указатели
+ /// -Ссылочных типов (то есть классами)
+ /// -Особых типов, которые .Net считает "опасными". Как char или System.DateTime
+ ///Но эти ограничения можно обойти, про это в справке
+ BlockFileOf=class(BlockFileBase)
+
+ private class sz: integer;
+
+ private class procedure TestForRefT(tt: System.Type);
+ begin
+ if tt.IsClass then
+ begin
+ MessageBox(new System.IntPtr(nil),
+ $'Тип {tt} ссылочный.{#10}Ссылочные типы нельзя сохранять в типизированный файл.{#10}Нажмите OK для выхода.',
+ $'Тип T из BlockFileOf содержет ссылочные типы',
+ $10
+ );
+ Halt(-1);
+ end;
+ foreach var fi in
+ tt.GetFields(
+ System.Reflection.BindingFlags.GetField or
+ System.Reflection.BindingFlags.Instance or
+ System.Reflection.BindingFlags.Public or
+ System.Reflection.BindingFlags.NonPublic
+ ) do
+ if not fi.IsLiteral then
+ if fi.FieldType <> tt then//integer имеет поле типа integer, без этой строчки StackOwerflow
+ TestForRefT(fi.FieldType);
+ end;
+
+ private class constructor :=
+ try
+ TestForRefT(typeof(T));
+
+ (*
+ try
+ var a := new T[0];
+ GCHandle.Alloc(a,GCHandleType.Pinned).Free;
+ except
+ on e: System.ArgumentException do
+ begin
+ MessageBox(new System.IntPtr(nil),
+ $'.Net не принимает какой то из типов полей записи, для которой вы создали BlockFileOf{#10}Говорит - его нельзя превратить в набор байт{#10}Нажмите OK для выхода.',
+ $'Тип T содержет ссылочные типы',
+ $10
+ );
+ Halt(-1);
+ end;
+ end;
+ (**)
+
+ sz := Marshal.SizeOf(typeof(T));
+ except
+ on e:Exception do
+ begin
+ MessageBox(new System.IntPtr(nil),
+ e.ToString,
+ $'При инициализации BlockFileOf<{typeof(T)}> произошла ошибка',
+ $10
+ );
+ Halt(-1);
+ end;
+ end;
+
+ private function GetName:string;
+ private function GetFullName:string;
+
+ private function GetExists:boolean;
+
+ private function GetFileSize:int64 := (GetByteFileSize - _offset) div sz;
+ private procedure SetFileSize(size:int64) := SetByteFileSize(_offset + size*sz);
+
+ private function GetByteFileSize:int64;
+ private procedure SetByteFileSize(size:int64);
+
+ private function GetPos:int64 := (GetPosByte-_offset) div sz;
+ private procedure SetPos(pos:int64) := SetPosByte(_offset + pos*sz);
+ private function GetPosByte:int64;
+ private procedure SetPosByte(pos:int64);
+
+ private function InternalReadLazy(c:integer; start_pos:int64):sequence of T;
+
+ ///Инициализирует переменную файла, не привязывая её к файлу на диске
+ public constructor := exit;
+ ///Инициализирует переменную файла, привязывая её к файлу fname
+ public constructor(fname:string) :=
+ Assign(fname);
+ ///Инициализирует переменную файла, привязывая её к файлу fname
+ ///А так же устанавливая значение смещени от начала в байтах на offset
+ public constructor(fname:string; offset:int64) :=
+ Assign(fname, offset);
+ ///- constructor BlockFileOf<>(f:BlockFileOf<>);
+ ///Инициализирует новую переменную, создавая связку данной переменной
+ ///После вызова этого конструктора - переданная и созданная переменная будут
+ ///использовать общий файловый поток, но записывать разные типы данных (у них может быть разный T)
+ ///Это значит, что переменная которую передали в конструктор должно уже иметь открытый файловый поток
+ ///Метод Close разрывает эту связь.
+ public constructor(f: BlockFileBase) :=
+ Link(f);
+
+
+ ///Размер блока из одного элемента типа T, в байтах
+ ///Хоть это свойство и можно перезаписывать, но это не рекомендуется
+ ///Если перезаписать на число, большее чем было - в файл будет сохранять лишние нули
+ ///А если на меньшее - получите неопределённое поведение (скорее всего вылет, но далеко не сразу)
+ public property TSize:integer read integer(sz) write sz := value;
+
+ ///Смещение от начала файла до начала элементов (в байтах)
+ public property Offset:int64 read _offset write _offset;
+ ///Количество сохранённых в файл элементов типа T
+ ///Чтоб установить длину файла - надо открыть файл. Но прочитать длину можно не открывая
+ public property Size:int64 read GetFileSize write SetFileSize;
+ ///Полный размер файла, в байтах
+ ///Чтоб установить длину файла - надо открыть файл. Но прочитать длину можно не открывая
+ public property ByteSize:int64 read GetByteFileSize write SetByteFileSize;
+ ///Имя файла (только имя самого файла, без имени папки)
+ public property Name:string read GetName;
+ ///Полное имя файла (вместе с именами всех под-папок, вплодь до корня диска)
+ public property FullName:string read GetFullName;
+ ///Существует ли файл
+ public property Exists:boolean read GetExists;
+
+ ///Номер текущего элемета типа T в файле (нумеруя с 0)
+ public property Pos:int64 read GetPos write SetPos;
+ ///Номер текущего байта от начала файла (нумеруя с 0)
+ public property PosByte:int64 read GetPosByte write SetPosByte;
+ ///Привязана ли переменная к файлу
+ public property Assigned:boolean read fi <> nil;
+ ///Открыт ли файл
+ public property Opened:boolean read str <> nil;
+ ///Достигнут ли конец файла
+ public property EOF:boolean read ByteSize-PosByte < sz;
+ ///Основной поток открытого файла (или nil если файл не открыт)
+ ///Внимание! Любое действие которое изменит этот поток - приведёт к неожиданным последствиям, используйте его только если знаете что делаете
+ public property BaseStream:FileStream read str;
+ ///Переменная, которая записывает данные в основной поток (или nil если файл не открыт)
+ ///Внимание! Любое действие которое изменит основной поток файла - приведёт к неожиданным последствиям, используйте его только если знаете что делаете
+ public property BinWriter:BinaryWriter read bw;
+ ///Переменная, которая читает данные из основного потока (или nil если файл не открыт)
+ ///Внимание! Любое действие которое изменит основной поток файла - приведёт к неожиданным последствиям, используйте его только если знаете что делаете
+ public property BinReader:BinaryReader read br;
+ ///Переменная, показывающая данные о файле (или nil, если переменная не привязана к файлу)
+ public property FileInfo:System.IO.FileInfo read fi;
+
+
+
+ ///Привязывает данную переменную к файлу {fname}
+ ///Привязывать можно и к не существующим файлам, при откритии определёнными способами (как Rewrite) новый файл будет создан
+ public procedure Assign(fname:string);
+ ///Привязывает данную переменную к файлу {fname}
+ ///А так же устанавливая значение смещени от начала в байтах на offset
+ ///Привязывать можно и к не существующим файлам, при откритии определёнными способами (как Rewrite) новый файл будет создан
+ public procedure Assign(fname:string; offset:int64);
+ ///Убирает свять переменной и файла, если связь есть
+ public procedure UnAssign;
+ ///Открывает файл, способом описанным в переменной mode
+ ///Чтоб получить переменную этого типа - пишите System.IO.FileMode.<способ_открытия_файла>
+ public procedure Open(mode:FileMode);
+ ///Удаляет связаный файл, если он существует
+ public procedure Delete;
+ ///Переименовывает файл
+ ///Если указать другое расположение - файл будет перемещён
+ public procedure Rename(NewName:string);
+
+ ///Создает (или обнуляет) привязаный файл
+ public procedure Rewrite;
+ ///Привязывает данную переменную к файлу {fname} и создает (или обнуляет) этот файл
+ public procedure Rewrite(fname:string);
+ ///Привязывает данную переменную к файлу {fname} и создает (или обнуляет) этот файл
+ ///А так же устанавливая значение смещени от начала в байтах на offset
+ public procedure Rewrite(fname:string; offset:int64);
+
+ ///Открывает файл (ожидается, что он уже существует) и устанавливает позицию на начало файла
+ public procedure Reset;
+ ///Привязывает данную переменную к файлу {fname}, открывает этот файл (ожидается, что файл уже существует) и устанавливает позицию на начало файла
+ public procedure Reset(fname:string);
+ ///Привязывает данную переменную к файлу {fname}, открывает этот файл (ожидается, что файл уже существует) и устанавливает позицию на начало файла
+ ///А так же устанавливая значение смещени от начала в байтах на offset
+ public procedure Reset(fname:string; offset:int64);
+
+ ///Открывает файл (ожидается, что он уже существует) и устанавливает позицию в конце файла
+ public procedure Append;
+ ///Привязывает данную переменную к файлу {fname}, открывает этот файл (ожидается, что файл уже существует) и устанавливает позицию в конце файла
+ public procedure Append(fname:string);
+ ///Привязывает данную переменную к файлу {fname}, открывает этот файл (ожидается, что файл уже существует) и устанавливает позицию в конце файла
+ ///А так же устанавливая значение смещени от начала в байтах на offset
+ public procedure Append(fname:string; offset:int64);
+
+ ///Переставляет позицию в файле на элемент #pos (нумеруя с 0)
+ public procedure Seek(pos:int64) := self.Pos := pos;
+ ///Переставляет файловый курсор на байт #pos (нумеруя с 0) от начала файла
+ public procedure SeekByte(pos:int64) := self.PosByte := pos;
+
+ ///Записывает все изменения в файл и отчищает внутренние буферы
+ ///До вызова Flush или Close - все изменения и кеш хранятся в оперативной памяти
+ ///Поэтому, если вы записываете/читаете много (сотни мегабайт) - лучше вызывать Flush время от времени
+ public procedure Flush;
+ ///Сохраняет и закрывает файл, если он открыт
+ public procedure Close;
+
+
+ ///Записывает один элемент одним блоком в файл
+ ///И переставляет файловый курсор на 1 элемет вперёд
+ public procedure Write(o: T);
+ ///Записывает массив элементов одним блоком в файл
+ ///И переставляет файловый курсор на o.Length элеметов вперёд
+ public procedure Write(params o:array of T);
+ ///Записывает последовательность элементов, у которой можно узнать длину, одним блоком в файл
+ ///И переставляет файловый курсор на o.Count элеметов вперёд
+ public procedure Write(o:ICollection);
+ ///Записывает последовательность элементов, у которой нельзя узнать длину, по 1 элементу типа T в файл
+ ///И переставляет файловый курсор на o.Count элеметов вперёд
+ public procedure Write(o:sequence of T);
+ ///Записывает count элементов массива, начиная с элемента #from, одним блоком в файл
+ ///И переставляет файловый курсор на сount элеметов вперёд
+ public procedure Write(o:array of T; from,count:integer);
+ ///Записывает count элементов последовательности, у которой можно узнать длину, начиная с элемента #from, одним блоком в файл
+ ///И переставляет файловый курсор на сount элеметов вперёд
+ public procedure Write(o:ICollection; from,count:integer);
+ ///Записывает count элементов последовательности, у которой нельзя узнать длину, начиная с элемента #from, одним блоком в файл
+ ///И после каждого элемента переставляет файловый курсор на 1 элемет вперёд
+ public procedure Write(o:sequence of T; from,count:integer);
+
+ ///Читает один элемент из файла одним блоком
+ ///И переставляет файловый курсор на 1 элемет вперёд
+ public function Read:T;
+ ///Читает массив из count одним блоком
+ ///И переставляет файловый курсор на count элеметов вперёд
+ public function Read(count:integer):array of T;
+ ///Читает массив из count элементов одним блоком, начиная с элемента #start_elm
+ ///И переставляет файловый курсор на count элеметов вперёд
+ public function Read(start_elm, count:integer):array of T;
+ ///Возвращает ленивую последовательность из count элементов
+ ///После завершения чтения - курсор окажется на эдлементе #(start_elm+count)
+ ///Каждый раз читать будет начиная с элемента, на котором сейчас стоит файловый курсор
+ public function ReadLazy(count:integer):sequence of T := InternalReadLazy(count, PosByte);
+ ///Возвращает ленивую последовательность из count элементов, начиная с элемента #start_elm
+ ///После прочтения i элементов последовательности - позиция в файле будет передвигаться на элемент #(start_elm+i)
+ ///Каждый раз читать будет начиная с элемента #start_elm
+ public function ReadLazy(start_elm, count:integer):sequence of T := InternalReadLazy(count, _offset + start_elm*sz);
+ ///Возвращает ленивую последовательность из блоков-массивов с элементами типа T
+ ///Каждый блок хранит столько элементов - чтоб не превышать объём в 4096 байт (4КБ)
+ ///После прочтения каждого блока - файловый корсор будет переставлен на его конец
+ public function ToSeqBlocks:sequence of array of T := ToSeqBlocks(4096);
+ ///Возвращает ленивую последовательность из блоков-массивов с элементами типа T
+ ///Каждый блок хранит столько элементов - чтоб не превышать объём в последовательность байт
+ ///После прочтения каждого блока - файловый корсор будет переставлен на его конец
+ public function ToSeqBlocks(blocks_size:integer):sequence of array of T;
+ ///Возвращает ленивую последовательность из всех элементов хранящихся в файле
+ ///После прочтения i элементов последовательности - позиция в файле будет передвигаться на элемент #i
+ public function ToSeq:sequence of T;
+
+ protected procedure Finalize; override;
+ begin
+ Close;
+ end;
+
+ end;
+
+{$region Exception's}
+
+type
+ FileNotAssignedException = class(Exception)
+ constructor :=
+ inherited Create($'Данная переменная не была привязана к файлу{10}Используйте метод Assign');
+ end;
+ FileNotOpenedException = class(Exception)
+ constructor(fname:string) :=
+ inherited Create($'Файл {fname} ещё не открыт, откройте его с помощью Open, Reset, Append или Rewrite');
+ end;
+ FileNotClosedException = class(Exception)
+ constructor(fname:string) :=
+ inherited Create($'Файл {fname} ещё открыт, закройте его методом Close перед тем как продолжать');
+ end;
+ CannotReadAfterEOF = class(Exception)
+ constructor :=
+ inherited Create($'Нельзя читать за пределами файла. Можно только записывать');
+ end;
+
+{$endregion Exception's}
+
+implementation
+
+{$region Linking}
+
+procedure BlockFileBase.Link(f:BlockFileBase);
+begin
+
+ if f.str = nil then raise new FileNotOpenedException($'{f.fi.FullName}, чью переменную передали в конструктор BlockFileOf,');
+
+ foreach var l in f.linked + f do
+ begin
+ self.linked.Add(l);
+ l.linked.Add(self);
+ end;
+
+ self.str := f.str;
+ self.br := f.br;
+ self.bw := f.bw;
+ self.fi := new FileInfo(f.fi.FullName);
+
+end;
+
+procedure BlockFileBase.UnLink;
+begin
+
+ foreach var l in self.linked do
+ l.linked.Remove(self);
+
+ self.linked.Clear;
+
+end;
+
+{$endregion Linking}
+
+{$region property implementation}
+
+function BlockFileOf.GetName:string;
+begin
+ if fi = nil then raise new FileNotAssignedException;
+ fi.Refresh;
+ Result := fi.Name;
+end;
+
+function BlockFileOf.GetFullName:string;
+begin
+ if fi = nil then raise new FileNotAssignedException;
+ //fi.Refresh;//А тут не надо
+ Result := fi.FullName;
+end;
+
+
+
+function BlockFileOf.GetByteFileSize:int64;
+begin
+ if fi = nil then raise new FileNotAssignedException;
+ if str <> nil then
+ begin
+ Result := str.Length;
+ exit;
+ end;
+ fi.Refresh;
+ Result := fi.Length;
+end;
+
+procedure BlockFileOf.SetByteFileSize(size:int64);
+begin
+ if fi = nil then raise new FileNotAssignedException;
+ if str = nil then raise new FileNotOpenedException(fi.FullName);
+ str.SetLength(size);
+end;
+
+
+
+function BlockFileOf.GetPosByte:int64;
+begin
+ if fi = nil then raise new FileNotAssignedException;
+ if str = nil then raise new FileNotOpenedException(fi.FullName);
+ Result := str.Position;
+end;
+
+procedure BlockFileOf.SetPosByte(pos:int64);
+begin
+ if fi = nil then raise new FileNotAssignedException;
+ if str = nil then raise new FileNotOpenedException(fi.FullName);
+ str.Position := pos;
+end;
+
+{$endregion property implementation}
+
+{$region Setup IO}
+
+{$region Basic}
+
+procedure BlockFileOf.Assign(fname:string);
+begin
+ if str <> nil then raise new FileNotClosedException(fi.FullName);
+ fi := new System.IO.FileInfo(fname);
+end;
+
+procedure BlockFileOf.Assign(fname:string; offset:int64);
+begin
+ Assign(fname);
+ _offset := offset;
+end;
+
+procedure BlockFileOf.UnAssign;
+begin
+ if str <> nil then raise new FileNotClosedException(fi.FullName);
+ fi := nil;
+end;
+
+procedure BlockFileOf.Open(mode:FileMode);
+begin
+ if fi = nil then raise new FileNotAssignedException;
+ if str <> nil then raise new FileNotClosedException(fi.FullName);
+ str := fi.Open(mode);
+ bw := new BinaryWriter(str);
+ br := new BinaryReader(str);
+end;
+
+procedure BlockFileOf.Delete;
+begin
+ if fi = nil then raise new FileNotAssignedException;
+ fi.Delete;
+end;
+
+function BlockFileOf.GetExists:boolean;
+begin
+ if fi = nil then raise new FileNotAssignedException;
+ fi.Refresh;
+ Result := fi.Exists;
+end;
+
+procedure BlockFileOf.Rename(NewName:string);
+begin
+ if fi = nil then raise new FileNotAssignedException;
+ if str <> nil then raise new FileNotClosedException(fi.FullName);
+ fi.MoveTo(NewName);
+end;
+
+{$endregion Assign}
+
+{$region Rewrite}
+
+procedure BlockFileOf.Rewrite :=
+Open(FileMode.Create);
+
+procedure BlockFileOf.Rewrite(fname:string);
+begin
+ Assign(fname);
+ Rewrite;
+end;
+
+procedure BlockFileOf.Rewrite(fname:string; offset:int64);
+begin
+ Assign(fname, offset);
+ Rewrite;
+end;
+
+{$endregion Rewrite}
+
+{$region Reset}
+
+procedure BlockFileOf.Reset :=
+Open(FileMode.Open);
+
+procedure BlockFileOf.Reset(fname:string);
+begin
+ Assign(fname);
+ Reset;
+end;
+
+procedure BlockFileOf.Reset(fname:string; offset:int64);
+begin
+ Assign(fname, offset);
+ Reset;
+end;
+
+{$endregion Reset}
+
+{$region Append}
+
+procedure BlockFileOf.Append :=
+Open(FileMode.Append);
+
+procedure BlockFileOf.Append(fname:string);
+begin
+ Assign(fname);
+ Append;
+end;
+
+procedure BlockFileOf.Append(fname:string; offset:int64);
+begin
+ Assign(fname, offset);
+ Append;
+end;
+
+{$endregion Append}
+
+{$region Closing}
+
+procedure BlockFileOf.Flush;
+begin
+ if fi = nil then raise new FileNotAssignedException;
+ if str = nil then raise new FileNotOpenedException(fi.FullName);
+ str.Flush;
+end;
+
+procedure BlockFileOf.Close;
+begin
+ if str <> nil then
+ begin
+ if linked.Count <> 0 then
+ UnLink else
+ str.Close;
+ str := nil;
+ br := nil;
+ bw := nil;
+ end;
+end;
+
+{$endregion Closing}
+
+{$endregion Setup IO}
+
+{$region Write}
+
+procedure BlockFileOf.Write(o: T);
+begin
+ if fi = nil then raise new FileNotAssignedException;
+ if str = nil then raise new FileNotOpenedException(fi.FullName);
+ var a := new byte[sz];
+ var gc_hnd := GCHandle.Alloc(a, GCHandleType.Pinned);
+ System.Buffer.MemoryCopy(
+ @o,
+ gc_hnd.AddrOfPinnedObject.ToPointer,
+ sz,sz
+ );
+ gc_hnd.Free;
+ bw.Write(a);
+end;
+
+procedure BlockFileOf.Write(params o:array of T);
+begin
+ if fi = nil then raise new FileNotAssignedException;
+ if str = nil then raise new FileNotOpenedException(fi.FullName);
+
+ var bl := sz*o.Length;
+ var a := new byte[bl];
+ var gc_hnd1 := GCHandle.Alloc(o, GCHandleType.Pinned);
+ var gc_hnd2 := GCHandle.Alloc(a, GCHandleType.Pinned);
+ System.Buffer.MemoryCopy(
+ gc_hnd1.AddrOfPinnedObject.ToPointer,
+ gc_hnd2.AddrOfPinnedObject.ToPointer,
+ bl,bl
+ );
+ gc_hnd1.Free;
+ gc_hnd2.Free;
+ bw.Write(a);
+end;
+
+procedure BlockFileOf.Write(o:ICollection);
+type TArr = array of T;
+begin
+ if o is TArr(var a) then
+ begin
+ Write(a);
+ exit;
+ end;
+
+ if fi = nil then raise new FileNotAssignedException;
+ if str = nil then raise new FileNotOpenedException(fi.FullName);
+
+ var a := new byte[sz*o.Count];
+ var gc_hnd := GCHandle.Alloc(a, GCHandleType.Pinned);
+ var hnd := gc_hnd.AddrOfPinnedObject;
+ foreach var el in o do
+ begin
+ System.Buffer.MemoryCopy(
+ @el,
+ hnd.ToPointer,
+ sz,sz
+ );
+ System.IntPtr.Add(hnd, sz);
+ end;
+ gc_hnd.Free;
+ bw.Write(a);
+end;
+
+procedure BlockFileOf.Write(o:sequence of T) :=
+if o is ICollection(var c) then
+ Write(c) else
+foreach var el in o do
+ Write(el);
+
+procedure BlockFileOf.Write(o:array of T; from,count:integer);
+begin
+ if fi = nil then raise new FileNotAssignedException;
+ if str = nil then raise new FileNotOpenedException(fi.FullName);
+
+ var bl := sz*count;
+ var a := new byte[bl];
+ var gc_hnd1 := GCHandle.Alloc(o, GCHandleType.Pinned);
+ var gc_hnd2 := GCHandle.Alloc(a, GCHandleType.Pinned);
+ System.Buffer.MemoryCopy(
+ System.IntPtr.Add(gc_hnd1.AddrOfPinnedObject, from * sz).ToPointer,
+ gc_hnd2.AddrOfPinnedObject.ToPointer,
+ bl,bl
+ );
+ gc_hnd1.Free;
+ gc_hnd2.Free;
+ bw.Write(a);
+end;
+
+procedure BlockFileOf.Write(o:ICollection; from,count:integer);
+type TArr = array of T;
+begin
+ if o is TArr(var a) then
+ begin
+ Write(a, from, count);
+ exit;
+ end;
+
+ if fi = nil then raise new FileNotAssignedException;
+ if str = nil then raise new FileNotOpenedException(fi.FullName);
+
+ var a := new byte[sz*o.Count];
+ var gc_hnd := GCHandle.Alloc(a, GCHandleType.Pinned);
+ var hnd := gc_hnd.AddrOfPinnedObject;
+ foreach var el in o do
+ if from > 0 then from -= 1 else
+ if count > 0 then
+ begin
+ System.Buffer.MemoryCopy(
+ @el,
+ hnd.ToPointer,
+ sz,sz
+ );
+ hnd := System.IntPtr.Add(hnd, sz);
+ count -= 1;
+ end;
+ gc_hnd.Free;
+ bw.Write(a);
+end;
+
+procedure BlockFileOf.Write(o:sequence of T; from,count:integer) :=
+if o is ICollection(var c) then
+ Write(c,from,count) else
+ Write(o.Skip(from).Take(count));
+
+{$endregion Write}
+
+{$region Read}
+
+function BlockFileOf.Read:T;
+begin
+ if fi = nil then raise new FileNotAssignedException;
+ if str = nil then raise new FileNotOpenedException(fi.FullName);
+ if str.Length - str.Position < sz then raise new CannotReadAfterEOF;
+
+ var a := br.ReadBytes(sz);
+ var gc_hnd := GCHandle.Alloc(a, GCHandleType.Pinned);
+ System.Buffer.MemoryCopy(
+ gc_hnd.AddrOfPinnedObject.ToPointer,
+ @Result,
+ sz,sz
+ );
+ gc_hnd.Free;
+end;
+
+function BlockFileOf.Read(count:integer):array of T;
+begin
+ if fi = nil then raise new FileNotAssignedException;
+ if str = nil then raise new FileNotOpenedException(fi.FullName);
+ if str.Length - str.Position < sz*count then raise new CannotReadAfterEOF;
+
+ var bl := sz*count;
+ var a := br.ReadBytes(bl);
+ Result := new T[count];
+ var gc_hnd1 := GCHandle.Alloc(a, GCHandleType.Pinned);
+ var gc_hnd2 := GCHandle.Alloc(Result, GCHandleType.Pinned);
+ System.Buffer.MemoryCopy(
+ gc_hnd1.AddrOfPinnedObject.ToPointer,
+ gc_hnd2.AddrOfPinnedObject.ToPointer,
+ bl,bl
+ );
+ gc_hnd1.Free;
+ gc_hnd2.Free;
+end;
+
+function BlockFileOf.Read(start_elm, count:integer):array of T;
+begin
+ Pos := start_elm;
+ Result := Read(count);
+end;
+
+function BlockFileOf.InternalReadLazy(c:integer; start_pos:int64):sequence of T;
+begin
+ if fi = nil then raise new FileNotAssignedException;
+ if str = nil then raise new FileNotOpenedException(fi.FullName);
+ if str.Length - start_pos < sz*c then raise new CannotReadAfterEOF;
+
+ for var i := 0 to c-1 do
+ begin
+ PosByte := start_pos + i*sz;
+ yield Read;
+ end;
+end;
+
+function BlockFileOf.ToSeqBlocks(blocks_size:integer):sequence of array of T;
+begin
+ var c := blocks_size div sz;
+ var i := 0;
+ while true do
+ begin
+ var left := Size - i;
+
+ if left < c then
+ begin
+ if left > 0 then
+ begin
+ Pos := i;
+ yield Read(left);
+ end;
+ exit;
+ end else
+ begin
+ Pos := i;
+ yield Read(c);
+ i += c;
+ end;
+ end;
+end;
+
+function BlockFileOf.ToSeq:sequence of T;
+begin
+ var i := 0;
+ while not EOF do
+ begin
+ Pos := i;
+ yield Read;
+ i += 1;
+ end;
+end;
+
+{$endregion Read}
+
+end.
\ No newline at end of file
diff --git a/TestSuite/CompilationSamples/Countries.pas b/TestSuite/CompilationSamples/Countries.pas
new file mode 100644
index 000000000..ba4edc02c
--- /dev/null
+++ b/TestSuite/CompilationSamples/Countries.pas
@@ -0,0 +1,36 @@
+unit Countries;
+
+type
+ Att = class(System.Attribute)
+ Num: integer;
+ constructor (n: integer) := Num := n;
+ end;
+
+ Country = auto class
+ nm,cap: string;
+ inh: integer;
+ cont: string;
+ public
+ [Att(1)]
+ property Название: string read nm;
+ [Att(2)]
+ property Столица: string read cap;
+ [Att(4)]
+ property Население: integer read inh;
+ [Att(3)]
+ property Континент: string read cont;
+ end;
+
+function ЗаполнитьМассивСтран: array of Country;
+begin
+ var fname := __FindFile('Databases\Страны.csv');
+ if fname = '' then
+ raise new System.ApplicationException('Не найден массив стран Databases\Страны.csv');
+ Result := ReadLines(fname)
+ .Select(s->s.ToWords(';'))
+ .Select(w->new Country(w[0],w[1],w[2].ToInteger,w[3])).ToArray;
+end;
+
+begin
+
+end.
\ No newline at end of file
diff --git a/TestSuite/CompilationSamples/PABCSystem.pas b/TestSuite/CompilationSamples/PABCSystem.pas
index 4533d382d..63a0a2b77 100644
--- a/TestSuite/CompilationSamples/PABCSystem.pas
+++ b/TestSuite/CompilationSamples/PABCSystem.pas
@@ -8690,7 +8690,7 @@ begin
yield func(x, y)
end;
-/// Разбивает последовательности на две в позиции ind
+/// Разбивает последовательность на две в позиции ind. Реализуется двухпроходным алгоритмом
function SplitAt(Self: sequence of T; ind: integer): (sequence of T, sequence of T); extensionmethod;
begin
Result := (Self.Take(ind), Self.Skip(ind));
@@ -8700,13 +8700,13 @@ end;
// ToDo: SequenceCompare
-/// Разделяет последовательности на две по заданному условию
+/// Разделяет последовательность на две по заданному условию. Реализуется двухпроходным алгоритмом
function Partition(Self: sequence of T; cond: T->boolean): (sequence of T, sequence of T); extensionmethod;
begin
Result := (Self.Where(cond), Self.Where(x -> not cond(x)));
end;
-/// Разделяет последовательности на две по заданному условию, в котором участвует индекс
+/// Разделяет последовательность на две по заданному условию, в котором участвует индекс. Реализуется двухпроходным алгоритмом
function Partition(Self: sequence of T; cond: (T,integer)->boolean): (sequence of T, sequence of T); extensionmethod;
begin
Result := (Self.Where(cond), Self.Where((x, i)-> not cond(x, i)));
@@ -8742,19 +8742,19 @@ begin
Result := Self.Zip(a, (x, y)-> (x, y)).Zip(b, (p, z)-> (p[0], p[1], z)).Zip(c, (p, z)-> (p[0], p[1], p[2], z));
end;
-/// Разъединяет последовательность двухэлементных кортежей на две последовательности
+/// Разъединяет последовательность двухэлементных кортежей на две последовательности. Реализуется двухпроходным алгоритмом
function UnZipTuple(Self: sequence of (T, T1)): (sequence of T, sequence of T1); extensionmethod;
begin
Result := (Self.Select(x -> x[0]), Self.Select(x -> x[1]))
end;
-/// Разъединяет последовательность трехэлементных кортежей на три последовательности
+/// Разъединяет последовательность трехэлементных кортежей на три последовательности. Реализуется многопроходным алгоритмом
function UnZipTuple(Self: sequence of (T, T1, T2)): (sequence of T, sequence of T1, sequence of T2); extensionmethod;
begin
Result := (Self.Select(x -> x[0]), Self.Select(x -> x[1]), Self.Select(x -> x[2]))
end;
-/// Разъединяет последовательность четырехэлементных кортежей на четыре последовательности
+/// Разъединяет последовательность четырехэлементных кортежей на четыре последовательности. Реализуется многопроходным алгоритмом
function UnZipTuple(Self: sequence of (T, T1, T2, T3)): (sequence of T, sequence of T1, sequence of T2, sequence of T3); extensionmethod;
begin
Result := (Self.Select(x -> x[0]), Self.Select(x -> x[1]), Self.Select(x -> x[2]), Self.Select(x -> x[3]))
diff --git a/TestSuite/CompilationSamples/WPFObjects.pas b/TestSuite/CompilationSamples/WPFObjects.pas
new file mode 100644
index 000000000..76fda792b
--- /dev/null
+++ b/TestSuite/CompilationSamples/WPFObjects.pas
@@ -0,0 +1,1367 @@
+// Copyright (©) Ivan Bondarev, Stanislav Mihalkovich (for details please see \doc\copyright.txt)
+// This code is distributed under the GNU LGPL (for details please see \doc\license.txt)
+///Модуль векторных графических объектов на основе WPF
+unit WPFObjects;
+
+interface
+
+uses GraphWPFBase;
+
+uses System.Windows;
+uses System.Windows.Controls;
+uses System.Windows.Controls.Primitives;
+uses System.Windows.Input;
+uses System.Windows.Media;
+uses System.Windows.Media.Animation;
+uses System.Windows.Media.Imaging;
+uses System.Windows.Data;
+uses System.Reflection;
+uses System.Collections.ObjectModel;
+uses System.Threading;
+uses System.Windows.Shapes;
+uses System.Windows.Threading;
+
+procedure SetLeft(Self: UIElement; l: integer);
+procedure SetTop(Self: UIElement; t: integer);
+
+//{{{doc: Начало секции 1 }}}
+
+type
+// -----------------------------------------------------
+//>> Типы модуля WPFObjects # WPFObjects types
+// -----------------------------------------------------
+ /// Тип клавиши
+ Key = System.Windows.Input.Key;
+ /// Цветовые константы
+ Colors = System.Windows.Media.Colors;
+ /// Тип цвета
+ Color = System.Windows.Media.Color;
+ /// Тип цвета
+ GColor = System.Windows.Media.Color;
+ /// Тип прямоугольника
+ GRect = System.Windows.Rect;
+ /// Тип окна
+ GWindow = System.Windows.Window;
+ /// Тип пера
+ GPen = System.Windows.Media.Pen;
+ /// Тип точки
+ GPoint = System.Windows.Point;
+ /// Тип кисти
+ GBrush = System.Windows.Media.Brush;
+ /// Тип стиля шрифта
+ FontStyle = (Normal,Bold,Italic,BoldItalic);
+
+var host: Canvas;
+
+// -----------------------------------------------------
+//>> Вспомогательные функции WPFObjects # WPFObjects functions 1
+// -----------------------------------------------------
+
+/// Возвращает цвет по красной, зеленой и синей составляющей (в диапазоне 0..255)
+function RGB(r,g,b: byte): Color;
+/// Возвращает цвет по красной, зеленой и синей составляющей и параметру прозрачности (в диапазоне 0..255)
+function ARGB(a,r,g,b: byte): Color;
+/// Возвращает случайный цвет
+function RandomColor: Color;
+/// Возвращает серый цвет с интенсивностью b
+function GrayColor(b: byte): Color;
+/// Возвращает полностью прозрачный цвет
+function EmptyColor: Color;
+/// Возвращает случайный цвет
+function clRandom: Color;
+/// Возвращает точку с координатами (x,y)
+function Pnt(x,y: real): GPoint;
+/// Возвращает прямоугольник с координатами угла (x,y), шириной w и высотой h
+function Rect(x,y,w,h: real): GRect;
+/// Возвращает однотонную цветную кисть, заданную цветом
+function ColorBrush(c: Color): GBrush;
+//{{{--doc: Конец секции 1 }}}
+
+//{{{doc: Начало секции 2 }}}
+type
+// -----------------------------------------------------
+//>> Класс графического окна # Class GraphWindowType
+// -----------------------------------------------------
+ /// Класс графического окна
+ GraphWindowType = class
+ private
+ function GetTop: real;
+ function GetLeft: real;
+ function GetWidth: real;
+ function GetHeight: real;
+ public
+ /// Отступ графического окна от левого края главного окна
+ property Left: real read GetLeft;
+ /// Отступ графического окна от верхнего края главного окна
+ property Top: real read GetTop;
+ /// Ширина графического окна
+ property Width: real read GetWidth;
+ /// Высота графического окна
+ property Height: real read GetHeight;
+ end;
+
+ ObjectWPF = class;
+// -----------------------------------------------------
+//>> Класс списка графических объектов # Class List of objects
+// -----------------------------------------------------
+ ///!#
+ /// Класс списка графических объектов
+ ObjectsType = class
+ private
+ l := new List;
+ d := new Dictionary;
+ procedure AddP(ob: ObjectWPF);
+ procedure DeleteP(ob: ObjectWPF);
+ procedure ToBackP(ob: ObjectWPF);
+ procedure ToFrontP(ob: ObjectWPF);
+ function GetItem(i: integer): ObjectWPF := l[i];
+ procedure SetItem(i: integer; value: ObjectWPF) := l[i] := value;
+ procedure Add(ob: ObjectWPF) := Invoke(AddP,ob);
+ procedure Destroy(ob: ObjectWPF) := Invoke(DeleteP,ob);
+ public
+ /// Перемещает объект на задний план
+ procedure ToBack(ob: ObjectWPF) := Invoke(ToBackP,ob);
+ /// Перемещает объект на передний план
+ procedure ToFront(ob: ObjectWPF) := Invoke(ToFrontP,ob);
+ /// Возвращает количество объектов ObjectWPF
+ property Count: integer read l.Count;
+ /// Возвращает или устанавливает i-тый объект ObjectWPF
+ property Items[i: integer]: ObjectWPF read GetItem write SetItem; default;
+ end;
+
+
+// -----------------------------------------------------
+//>> Класс ObjectWPF # Class ObjectWPF
+// -----------------------------------------------------
+ /// Перечислимый тип выравнивания текста в свойстве Text или Number
+ Alignment = (LeftTop,CenterTop,RightTop,LeftCenter,Center,RightCenter,LeftBottom,CenterBottom,RightBottom);
+ ///!#
+ /// Базовый класс графических объектов
+ ObjectWPF = class
+ private
+ can: Canvas;
+ ob: FrameworkElement;
+ gr: Grid; // Grid связан только с текстом
+ t: TextBlock;
+ r: RotateTransform;
+ _dx,_dy: real;
+
+ ChildrenWPF := new List;
+ procedure InitOb(x,y,w,h: real; o: FrameworkElement; SetWH: boolean := True);
+ public
+ /// Направление движения по оси X. Используется методом Move
+ property Dx: real read _dx write _dx;
+ /// Направление движения по оси Y. Используется методом Move
+ property Dy: real read _dy write _dy;
+ /// Отступ графического объекта от левого края
+ property Left: real read InvokeReal(()->Canvas.GetLeft(can)) write Invoke(procedure->Canvas.SetLeft(can,value));
+ /// Отступ графического объекта от верхнего края
+ property Top: real read InvokeReal(()->Canvas.GetTop(can)) write Invoke(procedure->Canvas.SetTop(can,value));
+ /// Ширина графического объекта
+ property Width: real read InvokeReal(()->gr.Width) write Invoke(procedure->begin gr.Width := value; ob.Width := value end); virtual;
+ /// Высота графического объекта
+ property Height: real read InvokeReal(()->gr.Height) write Invoke(procedure->begin gr.Height := value; ob.Height := value end); virtual;
+ /// Текст внутри графического объекта
+ property Text: string read InvokeString(()->t.Text) write Invoke(procedure->t.Text := value);
+ /// Целое число, выводимое в центре графического объекта. Используется свойство Text
+ property Number: integer read Text.ToInteger(0) write Text := Value.ToString;
+ private
+ procedure WTA(value: Alignment);
+ begin
+ case Value of
+ Alignment.LeftTop,Alignment.CenterTop,Alignment.RightTop: t.VerticalAlignment := VerticalAlignment.Top;
+ Alignment.LeftCenter,Alignment.Center,Alignment.RightCenter: t.VerticalAlignment := VerticalAlignment.Center;
+ Alignment.LeftBottom,Alignment.CenterBottom,Alignment.RightBottom: t.VerticalAlignment := VerticalAlignment.Bottom;
+ end;
+ case Value of
+ Alignment.LeftTop,Alignment.LeftCenter,Alignment.LeftBottom: t.HorizontalAlignment := HorizontalAlignment.Left;
+ Alignment.CenterTop,Alignment.Center,Alignment.CenterBottom: t.HorizontalAlignment := HorizontalAlignment.Center;
+ Alignment.RightTop,Alignment.RightCenter,Alignment.RightBottom: t.HorizontalAlignment := HorizontalAlignment.Right;
+ end;
+ end;
+ procedure AddChildP(ch: ObjectWPF);
+ procedure DeleteChildP(ch: ObjectWPF);
+ function GetInternalGeometry: Geometry; virtual := nil;
+ function GetGeometry: Geometry; virtual;
+ begin
+ Result := GetInternalGeometry;
+ var g := new TransformGroup();
+ g.Children.Add(r);
+ g.Children.Add(new TranslateTransform(Left,Top));
+ Result.Transform := g; // версия
+ end;
+ public
+ /// Выравнивание текста внутри графического объекта
+ property TextAlignment: Alignment write Invoke(WTA,Value);
+ /// Размер текста внутри графического объекта
+ property FontSize: real read InvokeReal(()->t.FontSize) write Invoke(procedure->t.FontSize := value);
+ /// Имя шрифта текста внутри графического объекта
+ property FontName: string write Invoke(procedure->t.FontFamily := new FontFamily(value));
+ /// Цвет шрифта текста внутри графического объекта
+ property FontColor: Color
+ read Invoke&(()->(t.Foreground as SolidColorBrush).Color)
+ write Invoke(procedure->t.Foreground := new SolidColorBrush(value));
+ /// Центр графического объекта
+ property Center: Point
+ read Pnt(Left + Width/2, Top + Height/2)
+ write MoveTo(Value.X - Width/2, Value.Y - Height/2);
+ /// Левый верхний угол графического объекта
+ property LeftTop: Point read Pnt(Left,Top);
+ /// Левый нижний угол графического объекта
+ property LeftBottom: Point read Pnt(Left,Top + Height);
+ /// Правый верхний угол графического объекта
+ property RightTop: Point read Pnt(Left + Height,Top);
+ /// Правый нижний угол графического объекта
+ property RightBottom: Point read Pnt(Left + Height,Top + Height);
+ /// Угол поворота графического объекта (по часовой стрелке)
+ property RotateAngle: real read InvokeReal(()->r.Angle) write Invoke(procedure->r.Angle := value);
+ /// Центр поворота графического объекта
+ property RotateCenter: Point
+ read Invoke&(()->new Point(r.CenterX,r.CenterY))
+ write Invoke(procedure->begin r.CenterX := value.X; r.CenterY := value.Y; end);
+ /// Цвет графического объекта
+ property Color: GColor
+ read RGB(0,0,0)
+ write begin end; virtual;
+
+ /// Перемещает левый верхний угол графического объекта к точке (x,y)
+ procedure MoveTo(x,y: real) := (Self.Left,Self.Top) := (x,y);
+ /// Перемещает графический объект в направлении RotateAngle (вверх при RotateAngle=0)
+ procedure MoveForward(r: real);
+ begin
+ Left := Left + r*Cos(Pi/180*(90-RotateAngle));
+ Top := Top - r*Sin(Pi/180*(90-RotateAngle));
+ end;
+ /// Перемещает графический объект на вектор (a,b)
+ procedure MoveOn(a,b: real) := MoveTo(Left+a,Top+b);
+ /// Перемещает графический объект на вектор (dx,dy)
+ procedure Move := MoveOn(dx,dy);
+ /// Поворачивает графический объект по часовой стрелке на угол da
+ procedure Rotate(da: real) := RotateAngle += da;
+ /// Добавляет к графическому объекту дочерний
+ procedure AddChild(ch: ObjectWPF) := Invoke(AddChildP,ch);
+ /// Удаляет из графического объекта дочерний
+ procedure DeleteChild(ch: ObjectWPF) := Invoke(DeleteChildP,ch);
+ /// Удаляет графический объект
+ procedure Destroy;
+ /// Переносит графический объект на передний план
+ procedure ToFront;
+ /// Переносит графический объект на задний план
+ procedure ToBack;
+ /// Декоратор текста объекта
+ function WithText(txt: string; size: real := 16; fontname: string := 'Arial'; c: GColor := Colors.Black): ObjectWPF;
+ begin
+ Text := txt;
+ FontSize := size;
+ Self.FontName := fontname;
+ Self.FontColor := c;
+ Result := Self;
+ end;
+ /// Декоратор поворота объекта
+ function WithRotate(da: real): ObjectWPF;
+ begin
+ Rotate(da);
+ Result := Self;
+ end;
+ end;
+
+// -----------------------------------------------------
+//>> Класс графических объектов с границей # Class BoundedObjectWPF
+// -----------------------------------------------------
+ /// Класс графических объектов с границей
+ BoundedObjectWPF = class(ObjectWPF)
+ private
+ function Element := ob as Shape;
+ procedure InitOb1(x,y,w,h: real; c: GColor; o: FrameworkElement; SetWH: boolean := True);
+ begin
+ InitOb(x,y,w,h,o,SetWH);
+ Color := c;
+ //BorderColor := Colors.Black;
+ end;
+ procedure EF(value: GColor) := Element.Fill := new SolidColorBrush(Value);
+ procedure ES(value: GColor) := Element.Stroke := new SolidColorBrush(Value);
+ procedure EST(value: real) := Element.StrokeThickness := Value;
+ function WithNoBorderP: BoundedObjectWPF;
+ begin
+ Element.Stroke := nil;
+ Result := Self;
+ end;
+ public
+ /// Цвет графического объекта
+ property Color: GColor
+ read Invoke&(()->(Element.Fill as SolidColorBrush).Color)
+ write Invoke(EF,value); override;
+ /// Цвет границы графического объекта
+ property BorderColor: GColor
+ read Invoke&(()->begin
+ var scb := Element.Stroke as SolidColorBrush;
+ Result := scb<>nil ? scb.Color : ARGB(255,0,0,0);
+ end)
+ write Invoke(ES,value);
+ /// Ширина границы графического объекта
+ property BorderWidth: real
+ read InvokeReal(()->Element.StrokeThickness)
+ write Invoke(EST,value);
+ /// Декоратор включения границы объекта
+ function WithBorder(w: real := -1): BoundedObjectWPF;
+ begin
+ BorderColor := BorderColor;
+ if (w>=0) then
+ BorderWidth := w;
+ Result := Self;
+ end;
+ /// Декоратор выключения границы объекта
+ function WithNoBorder: BoundedObjectWPF
+ := Invoke&(WithNoBorderP);
+ end;
+
+// -----------------------------------------------------
+//>> Класс EllipseWPF # Class EllipseWPF
+// -----------------------------------------------------
+ /// Класс графических объектов "Эллипс"
+ EllipseWPF = class(BoundedObjectWPF)
+ private
+ procedure InitOb2(x,y,w,h: real; c: GColor) := InitOb1(x,y,w,h,c,new System.Windows.Shapes.Ellipse());
+ function GetInternalGeometry: Geometry; override := (ob as Shape).RenderedGeometry;
+ public
+ /// Создает эллипс размера (w,h) заданного цвета с координатами левого верхнего угла (x,y)
+ constructor (x,y,w,h: real; c: GColor) := Invoke(InitOb2,x,y,w,h,c);
+ /// Создает эллипс размера (w,h) заданного цвета с координатами левого верхнего угла, задаваемыми точкой
+ constructor (p: Point; w,h: real; c: GColor) := Invoke(InitOb2,p.x,p.y,w,h,c);
+ /// Декоратор включения границы объекта
+ function WithBorder(w: real := -1) := inherited WithBorder(w) as EllipseWPF;
+ /// Декоратор выключения границы объекта
+ function WithNoBorder := inherited WithNoBorder as EllipseWPF;
+ /// Декоратор текста объекта
+ function WithText(txt: string; size: real := 16; fontname: string := 'Arial'; c: GColor := Colors.Black): EllipseWPF
+ := inherited WithText(txt,size,fontname,c) as EllipseWPF;
+ /// Декоратор поворота объекта
+ function WithRotate(da: real): EllipseWPF
+ := inherited WithRotate(da) as EllipseWPF;
+ end;
+
+// -----------------------------------------------------
+//>> Класс CircleWPF # Class CircleWPF
+// -----------------------------------------------------
+ /// Класс графических объектов "Окружность"
+ CircleWPF = class(BoundedObjectWPF)
+ private
+ procedure InitOb2(x,y,r: real; c: GColor) := InitOb1(x-r,y-r,2*r,2*r,c,new System.Windows.Shapes.Ellipse());
+ procedure WT(value: real) := (ob.Width,ob.Height) := (value,value);
+ procedure HT(value: real) := (ob.Width,ob.Height) := (value,value);
+ procedure Rad(value: real);
+ begin
+ //(ob as Ellipse).RenderedGeometry
+ Left -= value - ob.Width/2;
+ Top -= value - ob.Width/2;
+ (ob.Width,ob.Height) := (value*2,value*2);
+ end;
+ function GetInternalGeometry: Geometry; override := (ob as Shape).RenderedGeometry;
+ public
+ /// Создает круг радиуса r заданного цвета с координатами центра (x,y)
+ constructor (x,y,r: real; c: GColor) := Invoke(InitOb2,x,y,r,c);
+ /// Создает круг радиуса r заданного цвета с центром p
+ constructor (p: Point; r: real; c: GColor) := Invoke(InitOb2,p.x,p.y,r,c);
+ /// Ширина круга
+ property Width: real
+ read InvokeReal(()->ob.Width)
+ write Invoke(WT,Value); override;
+ /// Высота круга
+ property Height: real
+ read InvokeReal(()->ob.Height)
+ write Invoke(HT,Value); override;
+ /// Радиус круга
+ property Radius: real
+ read InvokeReal(()->ob.Height/2)
+ write Invoke(Rad,Value);
+ /// Декоратор включения границы объекта
+ function WithBorder(w: real := -1) := inherited WithBorder(w) as CircleWPF;
+ /// Декоратор выключения границы объекта
+ function WithNoBorder := inherited WithNoBorder as CircleWPF;
+ /// Декоратор текста объекта
+ function WithText(txt: string; size: real := 16; fontname: string := 'Arial'; c: GColor := Colors.Black): CircleWPF
+ := inherited WithText(txt,size,fontname,c) as CircleWPF;
+ /// Декоратор поворота объекта
+ function WithRotate(da: real): CircleWPF
+ := inherited WithRotate(da) as CircleWPF;
+ end;
+
+// -----------------------------------------------------
+//>> Класс RectangleWPF # Class RectangleWPF
+// -----------------------------------------------------
+ /// Класс графических объектов "Прямоугольник"
+ RectangleWPF = class(BoundedObjectWPF)
+ private
+ procedure InitOb2(x,y,w,h: real; c: GColor);
+ begin
+ var rr := new Rectangle();
+ InitOb1(x,y,w,h,c,rr);
+ end;
+ function GetInternalGeometry: Geometry; override := (ob as Shape).RenderedGeometry;
+ public
+ /// Создает прямоугольник размера (w,h) заданного цвета с координатами левого верхнего угла (x,y)
+ constructor (x,y,w,h: real; c: GColor) := Invoke(InitOb2,x,y,w,h,c);
+ /// Создает прямоугольник размера (w,h) заданного цвета с координатами левого верхнего угла, задаваемыми точкой
+ constructor (p: Point; w,h: real; c: GColor) := Invoke(InitOb2,p.x,p.y,w,h,c);
+ /// Декоратор включения границы объекта
+ function WithBorder(w: real := -1) := inherited WithBorder(w) as RectangleWPF;
+ /// Декоратор выключения границы объекта
+ function WithNoBorder := inherited WithNoBorder as RectangleWPF;
+ /// Декоратор текста объекта
+ function WithText(txt: string; size: real := 16; fontname: string := 'Arial'; c: GColor := Colors.Black): RectangleWPF
+ := inherited WithText(txt,size,fontname,c) as RectangleWPF;
+ /// Декоратор поворота объекта
+ function WithRotate(da: real): RectangleWPF
+ := inherited WithRotate(da) as RectangleWPF;
+ end;
+
+// -----------------------------------------------------
+//>> Класс SquareWPF # Class SquareWPF
+// -----------------------------------------------------
+ /// Класс графических объектов "Квадрат"
+ SquareWPF = class(CircleWPF)
+ private
+ procedure InitOb2(x,y,w: real; c: GColor) := InitOb1(x,y,w,w,c,new Rectangle());
+ function GetInternalGeometry: Geometry; override := (ob as Shape).RenderedGeometry;
+ public
+ /// Создает квадрат со стороной w заданного цвета с координатами левого верхнего угла (x,y)
+ constructor (x,y,w: real; c: GColor) := Invoke(InitOb2,x,y,w,c);
+ /// Создает квадрат со стороной w заданного цвета с координатами левого верхнего угла, задаваемыми точкой
+ constructor (p: Point; w: real; c: GColor) := Invoke(InitOb2,p.x,p.y,w,c);
+ /// Декоратор включения границы объекта
+ function WithBorder(w: real := -1) := inherited WithBorder(w) as SquareWPF;
+ /// Декоратор выключения границы объекта
+ function WithNoBorder := inherited WithNoBorder as SquareWPF;
+ /// Декоратор текста объекта
+ function WithText(txt: string; size: real := 16; fontname: string := 'Arial'; c: GColor := Colors.Black): SquareWPF
+ := inherited WithText(txt,size,fontname,c) as SquareWPF;
+ /// Декоратор поворота объекта
+ function WithRotate(da: real): SquareWPF
+ := inherited WithRotate(da) as SquareWPF;
+ end;
+
+// -----------------------------------------------------
+//>> Класс RoundRectWPF # Class RoundRectWPF
+// -----------------------------------------------------
+ /// Класс графических объектов "Прямоугольник со скругленными краями"
+ RoundRectWPF = class(BoundedObjectWPF)
+ procedure InitOb2(x,y,w,h,r: real; c: GColor);
+ begin
+ var rr := new Rectangle();
+ rr.RadiusX := r;
+ rr.RadiusY := r;
+ InitOb1(x,y,w,h,c,rr);
+ end;
+ function GetInternalGeometry: Geometry; override := (ob as Shape).RenderedGeometry;
+ public
+ /// Создает прямоугольник со скругленными краями размера (w,h) с радиусом скругления r заданного цвета с координатами левого верхнего угла (x,y)
+ constructor (x,y,w,h,r: real; c: GColor) := Invoke(InitOb2,x,y,w,h,r,c);
+ /// Создает прямоугольник со скругленными краями размера (w,h) с радиусом скругления r заданного цвета с координатами левого верхнего угла, задаваемыми точкой
+ constructor (p: Point; w,h,r: real; c: GColor) := Invoke(InitOb2,p.x,p.y,w,h,r,c);
+ /// Декоратор включения границы объекта
+ function WithBorder(w: real := -1) := inherited WithBorder(w) as RoundRectWPF;
+ /// Декоратор выключения границы объекта
+ function WithNoBorder := inherited WithNoBorder as RoundRectWPF;
+ /// Декоратор текста объекта
+ function WithText(txt: string; size: real := 16; fontname: string := 'Arial'; c: GColor := Colors.Black): RoundRectWPF
+ := inherited WithText(txt,size,fontname,c) as RoundRectWPF;
+ /// Декоратор поворота объекта
+ function WithRotate(da: real): RoundRectWPF
+ := inherited WithRotate(da) as RoundRectWPF;
+ /// Радиус скругления
+ property RoundRadius: real
+ read InvokeReal(()->(ob as Rectangle).RadiusX)
+ write begin
+ var ob1 := ob;
+ Invoke(procedure->begin var r := ob1 as Rectangle; r.RadiusX := value; r.Radiusy := value end);
+ end;
+ end;
+
+// -----------------------------------------------------
+//>> Класс графических объектов RoundSquareWPF # Class RoundSquareWPF
+// -----------------------------------------------------
+ /// Класс графических объектов "Квадрат со скругленными краями"
+ RoundSquareWPF = class(CircleWPF)
+ procedure InitOb2(x,y,w,r: real; c: GColor);
+ begin
+ var rr := new Rectangle();
+ rr.RadiusX := r;
+ rr.RadiusY := r;
+ InitOb1(x,y,w,w,c,rr);
+ end;
+ function GetInternalGeometry: Geometry; override := (ob as Shape).RenderedGeometry;
+ public
+ /// Создает квадрат со скругленными краями со стороной w с радиусом скругления r заданного цвета с координатами левого верхнего угла (x,y)
+ constructor (x,y,w,r: real; c: GColor) := Invoke(InitOb2,x,y,w,r,c);
+ /// Создает квадрат со скругленными краями со стороной w с радиусом скругления r заданного цвета с координатами левого верхнего угла, задаваемыми точкой
+ constructor (p: Point; w,r: real; c: GColor) := Invoke(InitOb2,p.x,p.y,w,r,c);
+ /// Декоратор включения границы объекта
+ function WithBorder(w: real := -1): RoundSquareWPF
+ := inherited WithBorder(w) as RoundSquareWPF;
+ /// Декоратор выключения границы объекта
+ function WithNoBorder: RoundSquareWPF
+ := inherited WithNoBorder as RoundSquareWPF;
+ /// Декоратор текста объекта
+ function WithText(txt: string; size: real := 16; fontname: string := 'Arial'; c: GColor := Colors.Black): RoundSquareWPF
+ := inherited WithText(txt,size,fontname,c) as RoundSquareWPF;
+ /// Декоратор поворота объекта
+ function WithRotate(da: real): RoundSquareWPF
+ := inherited WithRotate(da) as RoundSquareWPF;
+ end;
+
+// -----------------------------------------------------
+//>> Класс LineWPF # Class LineWPF
+// -----------------------------------------------------
+ /// Класс графических объектов "Отрезок"
+ LineWPF = class(ObjectWPF)
+ private
+ function Element := ob as System.Windows.Shapes.Line;
+ procedure InitOb2(x1,y1,x2,y2: real; c: GColor);
+ begin
+ var ll := new System.Windows.Shapes.Line();
+ InitOb(min(x1,x2),min(y1,y2),abs(x1-x2),abs(y1-y2),ll,False);
+ ll.X1 := x1-Left;
+ ll.Y1 := y1-Top;
+ ll.X2 := x2-Left;
+ ll.y2 := y2-Top;
+ Color := c;
+ end;
+ procedure RecalcXW(x1,x2: real) := (Left,Width) := (min(x1,x2),abs(x1-x2));
+ procedure RecalcYH(y1,y2: real) := (Top,Height) := (min(y1,y2),abs(y1-y2));
+ procedure ES(value: GColor) := Element.Stroke := new SolidColorBrush(Value);
+ procedure EST(value: real) := Element.StrokeThickness := Value;
+ procedure WX1(value: real);
+ begin
+ var xx2 := x2;
+ RecalcXW(value,xx2);
+ if valuexx1 then
+ (Element.X1,Element.X2) := (0,Width)
+ else (Element.X1,Element.X2) := (Width,0);
+ end;
+ {procedure WY1(value: real) := begin Element.Y1 := value - Top; end;
+ procedure WY2(value: real) := begin Element.Y2 := value - Top; end;}
+ procedure WY1(value: real);
+ begin
+ var yy2 := y2;
+ RecalcYH(value,yy2);
+ if valueyy1 then
+ (Element.Y1,Element.Y2) := (0,Height)
+ else (Element.Y1,Element.Y2) := (Height,0);
+ end;
+ function GetInternalGeometry: Geometry; override := (ob as Shape).RenderedGeometry;
+ public
+ /// Создает отрезок, соединяющий точки (x1,y1) и (x2,y2)
+ constructor (x1,y1,x2,y2: real; c: GColor) := Invoke(InitOb2,x1,y1,x2,y2,c);
+ /// Создает отрезок, соединяющий точки p1 и p2
+ constructor (p1,p2: Point; c: GColor) := Invoke(InitOb2,p1.x,p1.y,p2.x,p2.y,c);
+ /// Цвет отрезка
+ property Color: GColor
+ read Invoke&(()->(Element.Stroke as SolidColorBrush).Color)
+ write Invoke(ES,value); override;
+ /// Ширина линии отрезка
+ property LineWidth: real
+ read InvokeReal(()->Element.StrokeThickness)
+ write Invoke(EST,value);
+ /// Координата x начальной точки отрезка
+ property X1: real read InvokeReal(()->Element.X1 + Left) write Invoke(WX1,value);
+ /// Координата x конечной точки отрезка
+ property X2: real read InvokeReal(()->Element.X2 + Left) write Invoke(WX2,value);
+ /// Координата y начальной точки отрезка
+ property Y1: real read InvokeReal(()->Element.Y1 + Top) write Invoke(WY1,value);
+ /// Координата y конечной точки отрезка
+ property Y2: real read InvokeReal(()->Element.Y2 + Top) write Invoke(WY2,value);
+ /// Начальная точка отрезка
+ property P1: Point read Pnt(X1,Y1) write begin X1 := Value.X; Y1 := Value.Y end;
+ /// Конечная точка отрезка
+ property P2: Point read Pnt(X2,Y2) write begin X2 := Value.X; Y2 := Value.Y end;
+ /// Ширина отрезка
+ property Width: real
+ read InvokeReal(()->gr.Width)
+ write
+ begin
+ var gr1 := gr;
+ Invoke(procedure->begin gr1.Width := value; end);
+ end; override;
+ /// Высота отрезка
+ property Height: real
+ read InvokeReal(()->gr.Height)
+ write
+ begin
+ var gr1 := gr;
+ Invoke(procedure->begin gr1.Height := value; end);
+ end; override;
+ /// Декоратор текста объекта
+ function WithText(txt: string; size: real := 16; fontname: string := 'Arial'; c: GColor := Colors.Black): LineWPF
+ := inherited WithText(txt,size,fontname,c) as LineWPF;
+ /// Декоратор поворота объекта
+ function WithRotate(da: real): LineWPF
+ := inherited WithRotate(da) as LineWPF;
+ /// Декоратор ширины линии отрезка
+ function WithLineWidth(lw: real): LineWPF;
+ begin
+ LineWidth := lw;
+ Result := Self;
+ end;
+ end;
+
+// -----------------------------------------------------
+//>> Класс RegularPolygonWPF # Class RegularPolygonWPF
+// -----------------------------------------------------
+ /// Класс графических объектов "Правильный многоугольник"
+ RegularPolygonWPF = class(BoundedObjectWPF)
+ private
+ n: integer;
+ function Element: System.Windows.Shapes.Polygon := ob as System.Windows.Shapes.Polygon;
+ procedure InitOb2(x,y,r: real; n: integer; c: GColor);
+ begin
+ InitOb1(x-r,y-r,2*r,2*r,c,CreatePolygon(r,n),false);
+ (Self.Left,Self.Top,Self.n) := (x-r,y-r,n);
+ end;
+ function ChangePointCollection(r: real; n: integer): PointCollection;
+ begin
+ var pp := Partition(0,2*Pi,n).Select(phi->Pnt(r+r*cos(phi-Pi/2),r+r*sin(phi-Pi/2))).ToArray; Result := new PointCollection(pp);
+ end;
+ function CreatePolygon(r: real; n: integer): System.Windows.Shapes.Polygon;
+ begin
+ var p := new System.Windows.Shapes.Polygon();
+ p.Points := ChangePointCollection(r,n);
+ Result := p;
+ end;
+ procedure Rad(value: real);
+ begin
+ var delta := value - gr.Width/2;
+ Left -= delta;
+ Top -= delta;
+ (gr.Width,gr.Height) := (value*2,value*2);
+ Element.Points := ChangePointCollection(value,n);
+ end;
+ procedure Cnt(value: integer);
+ begin
+ n := value;
+ Element.Points := ChangePointCollection(Radius,value);
+ end;
+ function GetInternalGeometry: Geometry; override := new EllipseGeometry(Center,Width/2,Height/2);
+ public
+ /// Создает правильный многоугольник заданного цвета с координатами центра (x,y) и радиусом описанной окружности r
+ constructor (x,y,r: real; n: integer; c: GColor) := Invoke(InitOb2,x,y,r,n,c);
+ /// Создает правильный многоугольник заданного цвета с центром в заданной точке и радиусом описанной окружности r
+ constructor (p: Point; r: real; n: integer; c: GColor) := Create(p.X,p.Y,r,n,c);
+ /// Ширина объекта
+ property Width: real
+ read InvokeReal(()->gr.Width)
+ write begin end; override;
+ /// Высота объекта
+ property Height: real
+ read InvokeReal(()->gr.Height)
+ write begin end; override;
+ /// Радиус описанной окрежности
+ property Radius: real
+ read InvokeReal(()->gr.Height/2)
+ write Invoke(Rad,Value); virtual;
+ /// Количество вершин
+ property Count: integer
+ read InvokeInteger(()->n)
+ write Invoke(Cnt,Value);
+ /// Декоратор включения границы объекта
+ function WithBorder(w: real := -1): RegularPolygonWPF
+ := inherited WithBorder(w) as RegularPolygonWPF;
+ /// Декоратор выключения границы объекта
+ function WithNoBorder: RegularPolygonWPF
+ := inherited WithNoBorder as RegularPolygonWPF;
+ /// Декоратор текста объекта
+ function WithText(txt: string; size: real := 16; fontname: string := 'Arial'; c: GColor := Colors.Black): RegularPolygonWPF
+ := inherited WithText(txt,size,fontname,c) as RegularPolygonWPF;
+ /// Декоратор поворота объекта
+ function WithRotate(da: real): RegularPolygonWPF
+ := inherited WithRotate(da) as RegularPolygonWPF;
+ end;
+
+// -----------------------------------------------------
+//>> Класс StarWPF # Class StarWPF
+// -----------------------------------------------------
+ /// Класс графических объектов "Звезда"
+ StarWPF = class(RegularPolygonWPF)
+ private
+ rint: real;
+ procedure InitOb2(x,y,r,rint: real; n: integer; c: GColor);
+ begin
+ InitOb1(x-r,y-r,2*r,2*r,c,CreatePolygon(r,rint,n),false);
+ (Self.Left,Self.Top,Self.rint,Self.n) := (x-r,y-r,rint,n);
+ end;
+ function ChangePointCollection(r,rint: real; n: integer): PointCollection;
+ begin
+ var pp1 := Partition(0,2*Pi,n).Select(phi->Pnt(r+r*cos(phi-Pi/2),r+r*sin(phi-Pi/2)));
+ var pp2 := Partition(0+Pi/n,2*Pi+Pi/n,n).Select(phi->Pnt(r+rint*cos(phi-Pi/2),r+rint*sin(phi-Pi/2)));
+ Result := new PointCollection(pp1.Interleave(pp2).ToArray);
+ end;
+ function CreatePolygon(r,rint: real; n: integer): System.Windows.Shapes.Polygon;
+ begin
+ var p := new System.Windows.Shapes.Polygon();
+ p.Points := ChangePointCollection(r,rint,n);
+ Result := p;
+ end;
+ procedure Rad(value: real);
+ begin
+ var delta := value - gr.Width/2;
+ Left -= delta;
+ Top -= delta;
+ (gr.Width,gr.Height) := (value*2,value*2);
+ Element.Points := ChangePointCollection(value,rint,n);
+ end;
+ procedure IntRad(value: real);
+ begin
+ if value>Radius then
+ value := Radius;
+ Element.Points := ChangePointCollection(Radius,value,n);
+ end;
+ procedure Cnt(value: integer);
+ begin
+ n := value;
+ Element.Points := ChangePointCollection(Radius,rint,value);
+ end;
+ public
+ /// Создает звезду заданного цвета с координатами центра (x,y), радиусом описанной окружности r и внутренним радиусом rinternal
+ constructor (x,y,r,rinternal: real; n: integer; c: GColor);
+ begin
+ if rinternalgr.Height/2)
+ write Invoke(Rad,Value); override;
+ /// Внутренний радиус
+ property InternalRadius: real
+ read rint
+ write Invoke(IntRad,Value);
+ /// Декоратор включения границы объекта
+ function WithBorder(w: real := -1): StarWPF
+ := inherited WithBorder(w) as StarWPF;
+ /// Декоратор выключения границы объекта
+ function WithNoBorder: StarWPF
+ := inherited WithNoBorder as StarWPF;
+ /// Декоратор текста объекта
+ function WithText(txt: string; size: real := 16; fontname: string := 'Arial'; c: GColor := Colors.Black): StarWPF
+ := inherited WithText(txt,size,fontname,c) as StarWPF;
+ /// Декоратор поворота объекта
+ function WithRotate(da: real): StarWPF
+ := inherited WithRotate(da) as StarWPF;
+ end;
+
+ PointsArray = array of Point;
+
+// -----------------------------------------------------
+//>> Класс PolygonWPF # Class PolygonWPF
+// -----------------------------------------------------
+ /// Класс графических объектов "Многоугольник"
+ PolygonWPF = class(BoundedObjectWPF)
+ private
+ procedure InitOb2(pp: array of Point; c: GColor);
+ begin
+ var x1 := pp.Min(p->p.x);
+ var x2 := pp.Max(p->p.x);
+ var y1 := pp.Min(p->p.y);
+ var y2 := pp.Max(p->p.y);
+ var a := pp.Select(p->Pnt(p.x-x1,p.y-y1)).ToArray;
+ InitOb1(x1,y1,x2-x1,y2-y1,c,CreatePolygon(a),false);
+ end;
+ function CreatePolygon(pp: array of Point): System.Windows.Shapes.Polygon;
+ begin
+ var p := new System.Windows.Shapes.Polygon();
+ p.Points := new PointCollection(pp);
+ Result := p;
+ end;
+ function GetPointsArrayP: PointsArray;
+ begin
+ Result := (ob as System.Windows.Shapes.Polygon).Points.Select(p->p).ToArray;
+ end;
+ public
+ /// Создает многоугольник заданного цвета с координатами вершин, заданными массивом точек pp
+ constructor (pp: array of Point; c: GColor) := Invoke(InitOb2,pp,c);
+ /// Массив вершин
+ property Points: array of Point
+ read Invoke&(GetPointsArrayP)
+ write begin
+ var ob1 := ob as System.Windows.Shapes.Polygon;
+ var pp := value;
+ // ширина и высота будут некорректно. Надо переопределить на чтение
+ var x1 := pp.Min(p->p.x);
+ var x2 := pp.Max(p->p.x);
+ var y1 := pp.Min(p->p.y);
+ var y2 := pp.Max(p->p.y);
+ var a := pp.Select(p->Pnt(p.x-x1,p.y-y1)).ToArray;
+ MoveTo(x1,y1);
+ //(gr.Width,gr.Height) := (x2-x1,y2-y1);
+ Invoke(procedure -> ob1.Points := new PointCollection(a));
+ end;
+ /// Декоратор включения границы объекта
+ function WithBorder(w: real := -1): PolygonWPF
+ := inherited WithBorder(w) as PolygonWPF;
+ /// Декоратор выключения границы объекта
+ function WithNoBorder: PolygonWPF
+ := inherited WithNoBorder as PolygonWPF;
+ /// Декоратор текста объекта
+ function WithText(txt: string; size: real := 16; fontname: string := 'Arial'; c: GColor := Colors.Black): PolygonWPF
+ := inherited WithText(txt,size,fontname,c) as PolygonWPF;
+ /// Декоратор поворота объекта
+ function WithRotate(da: real): PolygonWPF
+ := inherited WithRotate(da) as PolygonWPF;
+ end;
+
+// -----------------------------------------------------
+//>> Класс PictureWPF # Class PictureWPF
+// -----------------------------------------------------
+ /// Класс графических объектов "Рисунок"
+ PictureWPF = class(ObjectWPF)
+ private
+ function CreateBitmapImage(fname: string) := new BitmapImage(new System.Uri(fname,System.UriKind.Relative));
+ procedure Rest(x,y,w,h: real; b: BitmapImage);
+ begin
+ var im := new System.Windows.Controls.Image();
+ im.Source := b;
+ im.Width := w;
+ im.Height := h;
+
+ InitOb(x,y,w,h,im);
+ end;
+ procedure InitOb3(x,y,w,h: real; fname: string);
+ begin
+ var b := CreateBitmapImage(fname);
+ Rest(x,y,w,h,b);
+ end;
+
+ procedure InitOb2(x,y: real; fname: string);
+ begin
+ var b := CreateBitmapImage(fname);
+ Rest(x,y,b.Width,b.Height,b);
+ end;
+ function GetInternalGeometry: Geometry; override := new RectangleGeometry(Rect(Left,Top,Width,Height));
+ public
+ /// Создает рисунок из файла fname с координатами левого верхнего угла (x,y)
+ constructor (x,y: real; fname: string) := Invoke(InitOb2,x,y,fname);
+ /// Создает рисунок из файла fname с координатами левого верхнего угла (x,y) и размерами (w,h)
+ constructor (x,y,w,h: real; fname: string) := Invoke(InitOb3,x,y,w,h,fname);
+ /// Создает рисунок из файла fname с координатой левого верхнего угла, заданной точкой p
+ constructor (p: Point; fname: string) := Invoke(InitOb2,p.x,p.y,fname);
+ /// Создает рисунок из файла fname с координатой левого верхнего угла, заданной точкой p, и размерами (w,h)
+ constructor (p: Point; w,h: real; fname: string) := Invoke(InitOb3,p.x,p.y,w,h,fname);
+ /// Декоратор текста объекта
+ function WithText(txt: string; size: real := 16; fontname: string := 'Arial'; c: GColor := Colors.Black): PictureWPF
+ := inherited WithText(txt,size,fontname,c) as PictureWPF;
+ /// Декоратор поворота объекта
+ function WithRotate(da: real): PictureWPF
+ := inherited WithRotate(da) as PictureWPF;
+ end;
+
+// -----------------------------------------------------
+//>> Переменные модуля WPFObjects# WPFObjects Variables
+// -----------------------------------------------------
+/// Главное окно
+var Window: WindowType;
+/// Графическое окно
+var GraphWindow: GraphWindowType;
+/// Список графических объектов
+var Objects: ObjectsType;
+
+var
+// -----------------------------------------------------
+//>> События модуля WPFObjects# WPFObjects events
+// -----------------------------------------------------
+ /// Событие нажатия на кнопку мыши. (x,y) - координаты курсора мыши в момент наступления события, mousebutton = 1, если нажата левая кнопка мыши, и 2, если нажата правая кнопка мыши
+ OnMouseDown: procedure(x, y: real; mousebutton: integer);
+ /// Событие отжатия кнопки мыши. (x,y) - координаты курсора мыши в момент наступления события, mousebutton = 1, если отжата левая кнопка мыши, и 2, если отжата правая кнопка мыши
+ OnMouseUp: procedure(x, y: real; mousebutton: integer);
+ /// Событие перемещения мыши. (x,y) - координаты курсора мыши в момент наступления события, mousebutton = 0, если кнопка мыши не нажата, 1, если нажата левая кнопка мыши, и 2, если нажата правая кнопка мыши
+ OnMouseMove: procedure(x, y: real; mousebutton: integer);
+ /// Событие нажатия клавиши
+ OnKeyDown: procedure(k: Key);
+ /// Событие отжатия клавиши
+ OnKeyUp: procedure(k: Key);
+ /// Событие нажатия символьной клавиши
+ OnKeyPress: procedure(ch: char);
+ /// Событие изменения размера графического окна
+ OnResize: procedure;
+
+// -----------------------------------------------------
+//>> Функции пересечения# Intersection functions
+// -----------------------------------------------------
+/// Возвращает графический объект под точкой с координатами (x,y) или nil
+function ObjectUnderPoint(x,y: real): ObjectWPF;
+/// Возвращает True если графические объекты пересекаются
+function ObjectsIntersect(o1,o2: ObjectWPF): boolean;
+
+///--
+procedure __InitModule__;
+///--
+procedure __FinalizeModule__;
+//{{{--doc: Конец секции 2 }}}
+
+implementation
+
+function RGB(r,g,b: byte) := Color.Fromrgb(r, g, b);
+function ARGB(a,r,g,b: byte) := Color.FromArgb(a, r, g, b);
+function RandomColor := RGB(PABCSystem.Random(256), PABCSystem.Random(256), PABCSystem.Random(256));
+function GrayColor(b: byte): Color := RGB(b,b,b);
+function EmptyColor := ARGB(0,0,0,0);
+function clRandom := RandomColor();
+function Pnt(x,y: real) := new Point(x,y);
+function Rect(x,y,w,h: real) := new System.Windows.Rect(x,y,w,h);
+function ColorBrush(c: Color) := new SolidColorBrush(c);
+
+procedure SetLeft(Self: UIElement; l: integer) := Self.SetLeft(l);
+procedure SetTop(Self: UIElement; t: integer) := Self.SetTop(t);
+
+
+{procedure MoveTo(Self: UIElement; l,t: integer); extensionmethod;
+begin
+ Canvas.SetLeft(Self,l);
+ Canvas.SetTop(Self,t);
+end;}
+
+procedure ObjectsType.AddP(ob: ObjectWPF);
+begin
+ l.Add(ob);
+ host.Children.Add(ob.can);
+ d.Add(ob.ob,ob);
+end;
+
+procedure ObjectsType.DeleteP(ob: ObjectWPF);
+begin
+ l.Remove(ob);
+ host.Children.Remove(ob.can);
+ d.Remove(ob.ob);
+end;
+
+procedure ObjectsType.ToBackP(ob: ObjectWPF);
+begin
+ l.Remove(ob);
+ l.Insert(0,ob);
+ host.Children.Remove(ob.can);
+ host.Children.Insert(0,ob.can)
+end;
+
+procedure ObjectsType.ToFrontP(ob: ObjectWPF);
+begin
+ l.Remove(ob);
+ l.Add(ob);
+ host.Children.Remove(ob.can);
+ host.Children.Add(ob.can)
+end;
+
+procedure ObjectWPF.InitOb(x,y,w,h: real; o: FrameworkElement; SetWH: boolean);
+begin
+ can := new Canvas;
+ gr := new Grid;
+ r := new RotateTransform(0);
+ r.CenterX := w / 2;
+ r.CenterY := h / 2;
+ can.RenderTransform := r;
+ ob := o;
+ if SetWH then
+ (ob.Width,ob.Height) := (w,h);
+ MoveTo(x,y);
+ //gr.Children.Add(ob);
+ can.Children.Add(ob);
+
+ (gr.Width,gr.Height) := (w,h);
+ t := new TextBlock();
+ t.VerticalAlignment := VerticalAlignment.Center;
+ t.HorizontalAlignment := HorizontalAlignment.Center;
+
+ gr.Children.Add(t);
+ can.Children.Add(gr);
+
+ Objects.Add(Self);
+ //host.Children.Add(can);
+
+ FontSize := 16;
+end;
+
+procedure ObjectWPF.AddChildP(ch: ObjectWPF);
+begin
+ ChildrenWPF.Add(ch);
+ //host.Children.Remove(ch.can);
+ Objects.Destroy(ch);
+ can.Children.Add(ch.can);
+end;
+
+procedure ObjectWPF.DeleteChildP(ch: ObjectWPF);
+begin
+ ChildrenWPF.Remove(ch);
+ //host.Children.Remove(ch.gr);
+end;
+
+procedure ObjectWPF.Destroy;
+begin
+ Objects.Destroy(Self);
+end;
+
+procedure ObjectWPF.ToFront;
+begin
+ Objects.ToFront(Self);
+end;
+
+procedure ObjectWPF.ToBack;
+begin
+ Objects.ToBack(Self);
+end;
+
+var hitResultsList := new List;
+
+function MyHitTestResult(res: HitTestResult): HitTestResultBehavior;
+begin
+ hitResultsList.Add(res.VisualHit);
+ Result := HitTestResultBehavior.Continue;
+end;
+
+function ObjectUnderPointP(x,y: real): ObjectWPF;
+begin
+ hitResultsList.Clear();
+
+ VisualTreeHelper.HitTest(host, nil,
+ MyHitTestResult,
+ new PointHitTestParameters(Pnt(x,y)));
+
+ //hitResultsList.Print;
+ foreach var a in hitResultsList do
+ foreach var b in Objects.l do
+ if b.ob=a then
+ begin
+ Result := b;
+ exit;
+ end;
+
+ Result := nil;
+end;
+
+type XYHelper = auto class
+ x,y: real;
+ function f: ObjectWPF := ObjectUnderPointP(x,y);
+end;
+
+function ObjectUnderPoint(x,y: real): ObjectWPF
+ := Invoke&(XYHelper.Create(x,y).f);
+
+
+function MyHitTestResult2(res: HitTestResult): HitTestResultBehavior;
+begin
+ var id := (res as GeometryHitTestResult).IntersectionDetail;
+
+ Result := HitTestResultBehavior.Stop;
+ case id of
+ IntersectionDetail.FullyContains,
+ IntersectionDetail.Intersects,
+ IntersectionDetail.FullyInside:
+ begin
+ hitResultsList.Add(res.VisualHit);
+ Result := HitTestResultBehavior.Continue;
+ end;
+ end;
+end;
+
+
+function ObjectsIntersectP(o1,o2: ObjectWPF): boolean;
+begin
+ hitResultsList.Clear();
+
+ VisualTreeHelper.HitTest(host, nil,
+ MyHitTestResult2,
+ new GeometryHitTestParameters(o2.GetGeometry));
+
+ Result := False;
+ foreach var a in hitResultsList do
+ if a=o1.ob then
+ begin
+ Result := True;
+ exit;
+ end;
+end;
+
+function ObjectsIntersectPL(o: ObjectWPF): List;
+begin
+ hitResultsList.Clear();
+
+ VisualTreeHelper.HitTest(host, nil,
+ MyHitTestResult2,
+ new GeometryHitTestParameters(o.GetGeometry));
+
+ Result := new List;
+ foreach var a in hitResultsList do
+ begin
+ var aa := a as FrameworkElement;
+ if (aa<>o.ob) and Objects.d.ContainsKey(aa) then
+ Result.Add(Objects.d[aa])
+ end;
+end;
+
+
+type ObHelper = auto class
+ o1,o2: ObjectWPF;
+ function f: boolean := ObjectsIntersectP(o1,o2);
+end;
+
+type OLHelper = auto class
+ o: ObjectWPF;
+ function f: List := ObjectsIntersectPL(o);
+end;
+
+
+function ObjectsIntersect(o1,o2: ObjectWPF)
+ := Invoke&(ObHelper.Create(o1,o2).f);
+
+function IntersectionList(Self: ObjectWPF): List; extensionmethod
+ := Invoke&>(OLHelper.Create(Self).f);
+
+//---------------------------------------------------------------------------
+function GraphWindowTypeGetLeftP: real;
+begin
+ Result := 0;
+ foreach var p in MainDockPanel.Children do
+ if (p is FrameworkElement) and (p<>host) then
+ begin
+ var d := DockPanel.GetDock(FrameworkElement(p));
+ if d=Dock.Left then
+ Result += FrameworkElement(p).Width;
+ end;
+end;
+
+function GraphWindowTypeGetTopP: real;
+begin
+ Result := 0;
+ foreach var p in MainDockPanel.Children do
+ if (p is FrameworkElement) and (p<>host) then
+ begin
+ var d := DockPanel.GetDock(FrameworkElement(p));
+ if d=Dock.Top then
+ Result += FrameworkElement(p).Height;
+ end;
+end;
+
+function GraphWindowType.GetLeft := InvokeReal(GraphWindowTypeGetLeftP);
+function GraphWindowType.GetTop := InvokeReal(GraphWindowTypeGetTopP);
+
+function GraphWindowTypeGetWidthP: real;
+begin
+ {if host.DataContext = nil then
+ Result := 0
+ else Result := Size(host.DataContext).Width;}
+ Result := Window.Width;
+ foreach var p in MainDockPanel.Children do
+ if (p is FrameworkElement) and (p<>host) then
+ begin
+ var d := DockPanel.GetDock(FrameworkElement(p));
+ if (d=Dock.Left) or (d=Dock.Right) then
+ Result -= FrameworkElement(p).Width;
+ end;
+end;
+function GraphWindowType.GetWidth := InvokeReal(GraphWindowTypeGetWidthP);
+
+function GraphWindowTypeGetHeightP: real;
+begin
+ {if host.DataContext = nil then
+ Result := 0
+ else Result := Size(host.DataContext).Height;}
+ Result := Window.Height;
+ foreach var p in MainDockPanel.Children do
+ if (p is FrameworkElement) and (p<>host) then
+ begin
+ var d := DockPanel.GetDock(FrameworkElement(p));
+ if (d=Dock.Top) or (d=Dock.Bottom) then
+ Result -= FrameworkElement(p).Height;
+ end;
+end;
+function GraphWindowType.GetHeight := InvokeReal(GraphWindowTypeGetHeightP);
+
+/// --- SystemMouseEvents
+procedure SystemOnMouseDown(sender: Object; e: MouseButtonEventArgs);
+begin
+ var mb := 0;
+ var p := e.GetPosition(host);
+ if e.LeftButton = MouseButtonState.Pressed then
+ mb := 1
+ else if e.RightButton = MouseButtonState.Pressed then
+ mb := 2;
+ if OnMouseDown <> nil then
+ OnMouseDown(p.x, p.y, mb);
+end;
+
+procedure SystemOnMouseUp(sender: Object; e: MouseButtonEventArgs);
+begin
+ var mb := 0;
+ var p := e.GetPosition(host);
+ if e.LeftButton = MouseButtonState.Pressed then
+ mb := 1
+ else if e.RightButton = MouseButtonState.Pressed then
+ mb := 2;
+ if OnMouseUp <> nil then
+ OnMouseUp(p.x, p.y, mb);
+end;
+
+procedure SystemOnMouseMove(sender: Object; e: MouseEventArgs);
+begin
+ var mb := 0;
+ var p := e.GetPosition(host);
+ if e.LeftButton = MouseButtonState.Pressed then
+ mb := 1
+ else if e.RightButton = MouseButtonState.Pressed then
+ mb := 2;
+ if OnMouseMove <> nil then
+ OnMouseMove(p.x, p.y, mb);
+end;
+
+/// --- SystemKeyEvents
+procedure SystemOnKeyDown(sender: Object; e: KeyEventArgs) :=
+ if OnKeyDown<>nil then
+ OnKeyDown(e.Key);
+
+procedure SystemOnKeyUp(sender: Object; e: KeyEventArgs) :=
+ if OnKeyUp<>nil then
+ OnKeyUp(e.Key);
+
+procedure SystemOnResize(sender: Object; e: SizeChangedEventArgs) :=
+ if OnResize<>nil then
+ OnResize();
+
+var mre := new ManualResetEvent(false);
+
+type
+GraphWPFWindow = class(GMainWindow)
+public
+ procedure InitMainGraphControl; override;
+ begin
+ host := new Canvas();
+ //host.ClipToBounds := True;
+ host.SizeChanged += (s,e) ->
+ begin
+ var sz := e.NewSize;
+ host.DataContext := sz;
+ end;
+ // Всегда последнее
+ var g := Content as DockPanel;
+ g.children.Add(host);
+ end;
+
+ procedure InitWindowProperties; override;
+ begin
+ Title := 'WPF объекты';
+ var (w,h) := (800,600);
+
+ (Width, Height) := (w + wplus, h + hplus);
+ WindowStartupLocation := System.Windows.WindowStartupLocation.CenterScreen;
+ end;
+
+ procedure InitGlobals; override;
+ begin
+ Window := new WindowType;
+ GraphWindow := new GraphWindowType;
+ Objects := new ObjectsType;
+ end;
+
+ procedure InitHandlers; override;
+ begin
+ Closed += procedure(sender,e) -> begin Halt; end;
+ MouseDown += SystemOnMouseDown;
+ MouseUp += SystemOnMouseUp;
+ MouseMove += SystemOnMouseMove;
+ KeyDown += SystemOnKeyDown;
+ KeyUp += SystemOnKeyUp;
+ SizeChanged += SystemOnResize;
+
+ Loaded += (o,e) -> mre.Set();
+
+ {PreviewMouseDown += (o,e) -> SystemOnMouseDown(o,e);
+ PreviewMouseUp += (o,e) -> SystemOnMouseUp(o,e);
+ PreviewMouseMove += (o,e) -> SystemOnMouseMove(o,e);
+
+ PreviewKeyDown += (o,e)-> SystemOnKeyDown(o,e);
+ PreviewKeyUp += (o,e)-> SystemOnKeyUp(o,e);
+
+ Closed += procedure(sender, e) -> begin Halt; end;}
+ end;
+
+end;
+
+procedure InitApp;
+begin
+ app := new Application;
+
+ app.Dispatcher.UnhandledException += (o, e) -> begin
+ Println(e.Exception.Message);
+ if e.Exception.InnerException<>nil then
+ Println(e.Exception.InnerException.Message);
+ halt;
+ end;
+
+ MainWindow := new GraphWPFWindow;
+
+ mre.Set();
+
+ app.Run(MainWindow);
+end;
+
+procedure InitMainThread;
+begin
+ var MainFormThread := new System.Threading.Thread(InitApp);
+ MainFormThread.SetApartmentState(ApartmentState.STA);
+ MainFormThread.Start;
+
+ mre.WaitOne; // Основная программа не начнется пока не будут инициализированы все компоненты приложения
+end;
+
+var
+ ///--
+ __initialized := false;
+
+var
+ ///--
+ __finalized := false;
+
+procedure __InitModule;
+begin
+ InitMainThread;
+end;
+
+///--
+procedure __InitModule__;
+begin
+ if not __initialized then
+ begin
+ __initialized := true;
+ GraphWPFBase.__InitModule__;
+ __InitModule;
+ end;
+end;
+
+///--
+procedure __FinalizeModule__;
+begin
+ if not __finalized then
+ begin
+ __finalized := true;
+ end;
+end;
+
+initialization
+ __InitModule;
+
+finalization
+end.
\ No newline at end of file
diff --git a/TestSuite/CompilationSamples/graph3d.pas b/TestSuite/CompilationSamples/graph3d.pas
new file mode 100644
index 000000000..f27e35646
--- /dev/null
+++ b/TestSuite/CompilationSamples/graph3d.pas
@@ -0,0 +1,3764 @@
+// Copyright (©) Ivan Bondarev, Stanislav Mihalkovich (for details please see \doc\copyright.txt)
+// This code is distributed under the GNU LGPL (for details please see \doc\license.txt)
+/// Модуль трёхмерной графики
+unit Graph3D;
+
+{$reference System.Xml.dll}
+{$reference HelixToolkit.Wpf.dll}
+
+interface
+
+uses GraphWPFBase;
+
+uses System.Windows;
+uses System.Windows.Controls;
+uses System.Windows.Shapes;
+uses System.Windows.Media;
+uses System.Windows.Media.Animation;
+uses System.Windows.Media.Media3D;
+
+uses System.Windows.Markup;
+uses System.XML;
+uses System.IO;
+uses System.Threading;
+uses System.Windows.Input;
+
+uses HelixToolkit.Wpf;
+//uses Petzold.Media3D;
+
+//{{{doc: Начало секции 1 }}}
+type
+// -----------------------------------------------------
+//>> Типы модуля Graph3D # Graph3D types
+// -----------------------------------------------------
+ /// Тип клавиши
+ Key = System.Windows.Input.Key;
+ /// Цветовые константы
+ Colors = System.Windows.Media.Colors;
+ /// Тип цвета
+ GColor = System.Windows.Media.Color;
+ /// Тип материала
+ GMaterial = System.Windows.Media.Media3D.Material;
+ /// Тип диффузного материала
+ GDiffuseMaterial = System.Windows.Media.Media3D.DiffuseMaterial;
+ /// Тип материала свечения
+ GEmissiveMaterial = System.Windows.Media.Media3D.EmissiveMaterial;
+ /// Тип камеры
+ GCamera = System.Windows.Media.Media3D.ProjectionCamera;
+ /// Тип прямоугольника
+ GRect = System.Windows.Rect;
+ /// Тип режима камеры
+ CameraMode = HelixToolkit.Wpf.CameraMode;
+ /// Тип предопределенных материалов
+ GMaterials=Helixtoolkit.Wpf.Materials;
+ /// Тип точки
+ Point = System.Windows.Point;
+ /// Тип 3D-точки
+ Point3D = System.Windows.Media.Media3D.Point3D;
+ /// Тип 3D-вектора
+ Vector3D = System.Windows.Media.Media3D.Vector3D;
+ /// Тип 3D-луча
+ Ray3D = HelixToolkit.Wpf.Ray3D;
+ /// Тип 3D-прямой
+ Line3D = class(Ray3D) end;
+ /// Тип плоскости
+ Plane3D = HelixToolkit.Wpf.Plane3D;
+ /// Тип 3D-матрицы
+ Matrix3D = System.Windows.Media.Media3D.Matrix3D;
+
+var
+ hvp: HelixViewport3D;
+ LightsGroup: Model3DGroup;
+ gvl: GridLinesVisual3D;
+
+// -----------------------------------------------------
+//>> Короткие функции модуля Graph3D # Graph3D short functions
+// -----------------------------------------------------
+
+/// Возвращает цвет по красной, зеленой и синей составляющей (в диапазоне 0..255)
+function RGB(r, g, b: byte): Color;
+/// Возвращает цвет по красной, зеленой и синей составляющей и параметру прозрачности (в диапазоне 0..255)
+function ARGB(a, r, g, b: byte): Color;
+/// Возвращает серый цвет с интенсивностью b
+function GrayColor(b: byte): Color;
+/// Возвращает случайный цвет
+function RandomColor: Color;
+/// Возвращает полностью прозрачный цвет
+function EmptyColor: Color;
+/// Возвращает точку с координатами (x,y)
+function Pnt(x, y: real): Point;
+/// Возвращает прямоугольник с координатами угла (x,y), шириной w и высотой h
+function Rect(x, y, w, h: real): GRect;
+/// Возвращает 3D-точку с координатами (x,y,z)
+function P3D(x, y, z: real): Point3D;
+/// Возвращает 3D-вектор с координатами (x,y,z)
+function V3D(x, y, z: real): Vector3D;
+/// Возвращает 3D-размер с координатами (x,y,z)
+function Sz3D(x, y, z: real): Size3D;
+
+// -----------------------------------------------------
+//>> Graph3D: функции для создания материалов Materials # Graph3D Materials functions
+// -----------------------------------------------------
+/// Диффузный материал
+function DiffuseMaterial(c: Color): Material;
+/// Зеркальный материал
+function SpecularMaterial(specularBrightness: byte; specularpower: real := 100): Material;
+/// Зеркальный материал
+function SpecularMaterial(c: Color; specularpower: real := 100): Material;
+/// Светящийся материал
+function EmissiveMaterial(c: Color): Material;
+/// Материал, формируемый на основе изображения. M,N - количество повторений изображения по ширине и высоте
+function ImageMaterial(fname: string; M: real := 1; N: real := 1): Material;
+/// Радужный материал
+function RainbowMaterial: Material;
+
+type
+// -----------------------------------------------------
+//>> Graph3D: класс Materials # Graph3D Materials class
+// -----------------------------------------------------
+ ///!#
+ /// Класс для создания материалов
+ Materials = class
+/// Диффузный материал
+ class function Diffuse(c: Color) := DiffuseMaterial(c);
+/// Зеркальный материал
+ class function Specular(specularBrightness: byte := 255; specularpower: real := 100) := SpecularMaterial(specularBrightness, specularpower);
+/// Зеркальный материал
+ class function Specular(c: Color; specularpower: real := 100) := SpecularMaterial(c, specularpower);
+/// Светящийся материал
+ class function Emissive(c: Color) := EmissiveMaterial(c);
+/// Материал, формируемый на основе изображения. M,N - количество повторений изображения по ширине и высоте
+ class function Image(fname: string; M: real := 1; N: real := 1) := ImageMaterial(fname,M,N);
+/// Радужный материал
+ class function Rainbow := RainbowMaterial;
+ end;
+
+type
+// -----------------------------------------------------
+//>> Graph3D: класс View3DType # Graph3D View3DType class
+// -----------------------------------------------------
+ ///!#
+ /// Класс пространства отображения
+ View3DType = class
+ private
+ procedure SetSGLP(v: boolean) := gvl.Visible := v;
+ procedure SetSGL(v: boolean) := Invoke(SetSGLP, v);
+ function GetSGL: boolean := InvokeBoolean(()->gvl.Visible);
+
+ procedure SetSCIP(v: boolean) := hvp.ShowCameraInfo := v;
+ procedure SetSCI(v: boolean) := Invoke(SetSCIP, v);
+ function GetSCI: boolean := InvokeBoolean(()->hvp.ShowCameraInfo);
+
+ procedure SetSVCP(v: boolean) := hvp.ShowViewCube := v;
+ procedure SetSVC(v: boolean) := Invoke(SetSVCP, v);
+ function GetSVC: boolean := InvokeBoolean(()->hvp.ShowViewCube);
+
+ procedure SetTP(v: string) := hvp.Title := v;
+ procedure SetT(v: string) := Invoke(SetTP, v);
+ function GetT: string := InvokeString(()->hvp.Title);
+
+ procedure SetSTP(v: string) := hvp.SubTitle := v;
+ procedure SetST(v: string) := Invoke(SetSTP, v);
+ function GetST: string := InvokeString(()->hvp.SubTitle);
+
+ procedure SetCMP(v: HelixToolkit.Wpf.CameraMode) := hvp.CameraMode := v;
+ procedure SetCM(v: HelixToolkit.Wpf.CameraMode) := Invoke(SetCMP, v);
+ function GetCM: HelixToolkit.Wpf.CameraMode := Invoke&(()->hvp.CameraMode);
+
+ procedure SetBCP(v: GColor) := hvp.Background := new SolidColorBrush(v);
+ procedure SetBC(v: GColor) := Invoke(SetBCP, v);
+ function GetBC: GColor := Invoke&(()->(hvp.Background as SolidColorBrush).Color);
+ procedure ExportP(fname: string) := hvp.Viewport.Export(fname, hvp.Background);
+ public
+ /// Отображать ли координатную систему
+ property ShowCoordinateSystem: boolean
+ read InvokeBoolean(()->hvp.ShowCoordinateSystem)
+ write Invoke(procedure(v: boolean)->hvp.ShowCoordinateSystem := v, value);
+ /// Отображать ли координатную сетку
+ property ShowGridLines: boolean read GetSGL write SetSGL;
+ /// Отображать ли информацию о камере
+ property ShowCameraInfo: boolean read GetSCI write SetSCI;
+ /// Отображать ли ViewCube
+ property ShowViewCube: boolean read GetSVC write SetSVC;
+ /// Заголовок пространства отображения
+ property Title: string read GetT write SetT;
+ /// Подзаголовок пространства отображения
+ property SubTitle: string read GetST write SetST;
+ /// Режим камеры
+ property CameraMode: HelixToolkit.Wpf.CameraMode read GetCM write SetCM;
+ /// Цвет фона
+ property BackgroundColor: GColor read GetBC write SetBC;
+ /// Сохраняет содержимое 3d-окна в файл
+ procedure Save(fname: string) := Invoke(ExportP, fname);
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс CameraType # Graph3D CameraType class
+// -----------------------------------------------------
+ ///!#
+ /// Класс камеры
+ CameraType = class
+ private
+ function Cam: GCamera := hvp.Camera;
+ procedure SetPP(p: Point3D);
+ begin
+ Cam.Position := p;
+ end;
+
+ procedure SetP(p: Point3D) := Invoke(SetPP, p);
+ function GetP: Point3D := Invoke&(()->Cam.Position);
+ procedure SetLDP(v: Vector3D) := Cam.LookDirection := v;
+ procedure SetLD(v: Vector3D) := Invoke(SetLDP, v);
+ function GetLD: Vector3D := Invoke&(()->Cam.LookDirection);
+ procedure SetUDP(v: Vector3D) := Cam.UpDirection := v;
+ procedure SetUD(v: Vector3D) := Invoke(SetUDP, v);
+ function GetUD: Vector3D := Invoke&(()->Cam.UpDirection);
+ procedure SetDP(d: real);
+ begin
+ var dist := Cam.Position.DistanceTo(P3D(0, 0, 0));
+ Cam.Position := Cam.Position.Multiply(d / dist);
+ end;
+
+ procedure SetD(d: real) := Invoke(SetDP, d);
+ function GetD: real := InvokeReal(()->Cam.Position.DistanceTo(P3D(0, 0, 0)));
+ procedure MoveOnP(x,y,z: real);
+ begin
+ Cam.Position += V3D(x,y,z)//:= P3D(Cam.Position.
+ end;
+ procedure MoveOnPV(v: Vector3D);
+ begin
+ Cam.Position += v;
+ end;
+ procedure AddMoveForceP(x,y,z: real);
+ begin
+ hvp.CameraController.ShowCameraTarget := True;
+ hvp.CameraController.AddMoveForce(x,y,z);
+ end;
+ procedure AddRotateForceP(x,y: real);
+ begin
+ hvp.CameraController.AddRotateForce(x,y);
+ end;
+ procedure RotateP(axis: Vector3D; angle: real);
+ begin
+ var look := Cam.LookDirection;
+ var q := new Quaternion(axis, angle);
+ var qConjugate := q;
+ qConjugate.Conjugate();
+
+ var p := new Quaternion(look.X, look.Y, look.Z, 0);
+ var qRotatedPoint := q * p * qConjugate;
+ Cam.LookDirection := V3D(qRotatedPoint.X, qRotatedPoint.Y, qRotatedPoint.Z);
+ end;
+
+ public
+ /// Позиция камеры
+ property Position: Point3D read GetP write SetP;
+ /// Направление взгляда камеры
+ property LookDirection: Vector3D read GetLD write SetLD;
+ /// Направление "вверх" камеры
+ property UpDirection: Vector3D read GetUD write SetUD;
+ /// Расстояние камеры до начала координат
+ property Distanse: real read GetD write SetD;
+
+ /// Перемещает камеру на вектор (dx,dy,dz)
+ procedure MoveOn(dx,dy,dz: real) := Invoke(MoveOnP,dx,dy,dz);
+ /// Перемещает камеру на вектор v
+ procedure MoveOn(v: Vector3D) := Invoke(MoveOnPV,v);
+ /// Обеспечивает плавное движение камеры
+ procedure AddMoveForce(ForwardForce,RightForce,UpForce: real) := Invoke(AddMoveForceP,RightForce,UpForce,ForwardForce);
+ /// Обеспечивает плавное движение камеры вперед с некоторой силой
+ procedure AddForwardForce(Force: real := 0.2) := AddMoveForce(Force,0,0);
+ /// Обеспечивает плавное движение камеры назад с некоторой силой
+ procedure AddBackwardForce(Force: real := 0.2) := AddMoveForce(-Force,0,0);
+ /// Обеспечивает плавное движение камеры вправо
+ procedure AddRightForce(Force: real := 0.2) := AddMoveForce(0,Force,0);
+ /// Обеспечивает плавное движение камеры влево
+ procedure AddLeftForce(Force: real := 0.2) := AddMoveForce(0,-Force,0);
+ /// Обеспечивает плавное движение камеры вверх
+ procedure AddUpForce(Force: real := 0.2) := AddMoveForce(0,0,Force);
+ /// Обеспечивает плавное движение камеры вниз
+ procedure AddDownForce(Force: real := 0.2) := AddMoveForce(0,0,-Force);
+ /// Обеспечивает плавный поворот камеры
+ procedure AddRotateForce(RightForce,UpForce: real) := Invoke(AddRotateForceP,RightForce,UpForce);
+ /// Поворачивает камеру на данный угол относительно данной оси
+ procedure Rotate(axis: Vector3D; angle: real) := Invoke(RotateP,axis,angle);
+ end;
+
+ ///!#
+ /// Класс источника света
+ LightsType = class
+ public
+ /// Количество источников света
+ property Count: integer read Invoke&(()->LightsGroup.Children.Count);
+ /// Добавляет направленный источник света
+ procedure AddDirectionalLight(c: Color; v: Vector3D) := Invoke(()->LightsGroup.Children.Add(new DirectionalLight(c, v)));
+ /// Добавляет конусообразный источник света
+ procedure AddSpotLight(c: Color; p: Point3D; v: Vector3D; outerconeangle, innerconeangle: real) := Invoke(()->LightsGroup.Children.Add(new SpotLight(c, p, v, outerconeangle, innerconeangle)));
+ /// Добавляет точечный источник света
+ procedure AddPointLight(c: Color; p: Point3D) := Invoke(()->LightsGroup.Children.Add(new PointLight(c, p)));
+ /// Удаляет источник света
+ procedure RemoveLight(i: integer) := Invoke(()->LightsGroup.Children.RemoveAt(i));
+ {procedure Proba();
+ begin
+ var p := new PointLight(Colors.Gray, P3D(2, 2, 2));
+ p.Color := Colors.Gray;
+ p.Position := P3D(3, 3, 3);
+ end;}
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс GridLinesType # Graph3D GridLinesType class
+// -----------------------------------------------------
+ ///!#
+ /// Класс координатной сетки
+ GridLinesType = class
+ private
+ procedure SetW(r: real) := Invoke(procedure(r: real)->gvl.Width := r, r);
+ function GetW: real := InvokeReal(()->gvl.Width);
+ procedure SetL(r: real) := Invoke(procedure(r: real)->gvl.Length := r, r);
+ function GetL: real := InvokeReal(()->gvl.Length);
+ procedure SetMj(r: real) := Invoke(procedure(r: real)->gvl.MajorDistance := r, r);
+ function GetMj: real := InvokeReal(()->gvl.MajorDistance);
+ procedure SetMn(r: real) := Invoke(procedure(r: real)->gvl.MinorDistance := r, r);
+ function GetMn: real := InvokeReal(()->gvl.MinorDistance);
+ procedure SetN(r: Vector3D) := Invoke(procedure(r: Vector3D)->gvl.Normal := r, r);
+ function GetN: Vector3D := Inv(()->gvl.Normal);
+ public
+ /// Ширина координаной сетки (размер по оси OY)
+ property Width: real read GetW write SetW;
+ /// Длина координаной сетки (размер по оси OX)
+ property Length: real read GetL write SetL;
+ /// Вектор нормали координаной сетки
+ property Normal: Vector3D read GetN write SetN;
+ /// Большое расстояние между линиями координаной сетки
+ property MajorDistance: real read GetMj write SetMj;
+ /// Маленькое расстояние между линиями координаной сетки
+ property MinorDistance: real read GetMn write SetMn;
+ end;
+
+type
+ AnimationBase = class;
+ ObjectWithChildren3D = class;
+
+// -----------------------------------------------------
+//>> Graph3D: класс Object3D # Graph3D Object3D class
+// -----------------------------------------------------
+ ///!#
+ /// Базовый класс трехмерных объектов
+ Object3D = class
+ (DependencyObject) // для генерации документации
+ private
+ model: Visual3D;
+ Parent: ObjectWithChildren3D;
+ transfgroup := new Transform3DGroup;
+
+ rotatetransform := new MatrixTransform3D;
+ scaletransform := new ScaleTransform3D;
+ transltransform: TranslateTransform3D;
+
+ procedure AddToObject3DList;
+ procedure DeleteFromObject3DList;
+
+ procedure CreateBase0(m: Visual3D; x, y, z: real);
+ begin
+ model := m;
+ transltransform := new TranslateTransform3D(x, y, z);
+ //transfgroup.Children.Add(new MatrixTransform3D); // ответственен за поворот. Не храним в отдельной переменной т.к. при повороте меняется сам объект, а не поля объекта!!!
+
+ transfgroup.Children.Add(rotatetransform);
+ transfgroup.Children.Add(scaletransform);
+ transfgroup.Children.Add(transltransform);
+
+ model.Transform := transfgroup;
+ hvp.Children.Add(model);
+ AddToObject3DList;
+ end;
+
+ procedure SetX(xx: real) := Invoke(()->begin transltransform.OffsetX += xx - Self.X; end);
+ function GetX: real := InvokeReal(()->transfgroup.Value.OffsetX);
+ procedure SetY(yy: real) := Invoke(()->begin transltransform.OffsetY += yy - Self.Y; end);
+ function GetY: real := InvokeReal(()->transfgroup.Value.OffsetY);
+ procedure SetZ(zz: real) := Invoke(()->begin transltransform.OffsetZ += zz - Self.Z; end);
+ function GetZ: real := InvokeReal(()->transfgroup.Value.OffsetZ);
+ function GetPos: Point3D := Invoke&(()->P3D(Self.X, Self.Y, Self.Z));
+
+ function FindVisual(v: Visual3D): Object3D; virtual;
+ begin
+ if model = v then
+ Result := Self
+ end;
+
+ function GetColor: GColor := EmptyColor;
+ procedure SetColor(c: GColor);
+ begin end;
+
+ protected
+ function CreateObject: Object3D; virtual;// нужно для клонирования
+ begin
+ Result := nil;
+ end;
+
+ procedure CloneChildren(from: Object3D); virtual;
+ begin
+ end;
+
+ function CloneT: Object3D; virtual;
+ begin
+ Result := CreateObject;
+ Result.CloneChildren(Self);
+
+ var ind := (model.Transform as Transform3DGroup).Children.IndexOf(rotatetransform);
+ (Result.model.Transform as Transform3DGroup).Children[ind] := (model.Transform as Transform3DGroup).Children[ind].Clone;
+ Result.rotatetransform := (Result.model.Transform as Transform3DGroup).Children[ind] as MatrixTransform3d;
+ //(Result.model.Transform as Transform3DGroup).Children[1] := (model.Transform as Transform3DGroup).Children[1].Clone;
+ //(Result.model.Transform as Transform3DGroup).Children[2] := (model.Transform as Transform3DGroup).Children[2].Clone;
+ //(Result.model.Transform as Transform3DGroup).Children[3] := (model.Transform as Transform3DGroup).Children[3].Clone; //- почему-то это не нужно!!! с ним не работает!
+ end;
+
+ public
+ constructor(model: Visual3D) := CreateBase0(model, 0, 0, 0);
+
+ /// Координата X
+ property X: real read GetX write SetX;
+ /// Координата Y
+ property Y: real read GetY write SetY;
+ /// Координата Z
+ property Z: real read GetZ write SetZ;
+ /// Перемещает 3D-объект к точке (xx,yy,zz)
+ function MoveTo(xx, yy, zz: real): Object3D :=
+ Invoke&(()->begin
+ transltransform.OffsetX += xx - Self.X;
+ transltransform.OffsetY += yy - Self.Y;
+ transltransform.OffsetZ += zz - Self.Z;
+ Result := Self;
+ end);
+ /// Перемещает 3D-объект к точке p
+ function MoveTo(p: Point3D): Object3D := MoveTo(p.X, p.y, p.z);
+ /// Перемещает 3D-объект на вектор (dx,dy,dz)
+ function MoveOn(dx, dy, dz: real): Object3D := MoveTo(x + dx, y + dy, z + dz);
+ /// Перемещает 3D-объект на вектор v
+ function MoveOn(v: Vector3D): Object3D := MoveOn(v.X, v.Y, v.Z);
+ /// Перемещает x-координату 3D-объекта на dx
+ function MoveOnX(dx: real): Object3D := MoveOn(dx, 0, 0);
+ /// Перемещает y-координату 3D-объекта на dy
+ function MoveOnY(dy: real): Object3D := MoveOn(0, dy, 0);
+ /// Перемещает z-координату 3D-объекта на dz
+ function MoveOnZ(dz: real): Object3D := MoveOn(0, 0, dz);
+ /// Цвет 3D-объекта
+ property Color: GColor read GetColor write SetColor; virtual;
+ private
+ procedure MoveToProp(p: Point3D) := MoveTo(p);
+
+ public
+ /// Позиция 3D-объекта
+ property Position: Point3D read GetPos write MoveToProp;
+
+ /// Масштабирует 3D-объект в f раз
+ function Scale(f: real): Object3D :=
+ Invoke&(()->begin
+ scaletransform.ScaleX *= f;
+ scaletransform.ScaleY *= f;
+ scaletransform.ScaleZ *= f;
+ Result := Self;
+ end);
+ /// Масштабирует 3D-объект в f раз по оси OX
+ function ScaleX(f: real): Object3D :=
+ Invoke&(()->begin
+ scaletransform.ScaleX *= f;
+ Result := Self;
+ end);
+ /// Масштабирует 3D-объект в f раз по оси OY
+ function ScaleY(f: real): Object3D :=
+ Invoke&(()->begin
+ scaletransform.ScaleY *= f;
+ Result := Self;
+ end);
+ /// Масштабирует 3D-объект в f раз по оси OZ
+ function ScaleZ(f: real): Object3D :=
+ Invoke&(()->begin
+ scaletransform.ScaleZ *= f;
+ Result := Self;
+ end);
+ /// Поворачивает объект на угол angle вокруг оси axis
+ function Rotate(axis: Vector3D; angle: real): Object3D :=
+ Invoke&(()->begin
+ var m := Matrix3D.Identity;
+ m.Rotate(new Quaternion(axis, angle));
+ var ind := transfgroup.Children.IndexOf(rotatetransform);
+ rotatetransform := new MatrixTransform3D(m * rotatetransform.Value);
+ transfgroup.Children[ind] := rotatetransform;
+ Result := Self;
+ end);
+ /// Поворачивает объект на угол angle вокруг оси axis относительно точки center
+ function RotateAt(axis: Vector3D; angle: real; center: Point3D): Object3D :=
+ Invoke&(()->begin
+ var m := Matrix3D.Identity;
+ m.RotateAt(new Quaternion(axis, angle), center);
+ var ind := transfgroup.Children.IndexOf(rotatetransform);
+ rotatetransform := new MatrixTransform3D(m * rotatetransform.Value);
+ transfgroup.Children[ind] := rotatetransform;
+ Result := Self;
+ end);
+ /// Возвращает анимацию перемещения объекта к точке (x, y, z) за seconds секунд. В конце анимации выполняется процедура Completed
+ function AnimMoveTo(x, y, z: real; seconds: real; Completed: procedure): AnimationBase;
+ /// Возвращает анимацию перемещения объекта к точке (x, y, z) за seconds секунд
+ function AnimMoveTo(x, y, z: real; seconds: real := 1): AnimationBase := AnimMoveTo(x,y,z,seconds,nil);
+ /// Возвращает анимацию перемещения объекта к точке p за seconds секунд. В конце анимации выполняется процедура Completed
+ function AnimMoveTo(p: Point3D; seconds: real; Completed: procedure) := AnimMoveTo(p.x, p.y, p.z, seconds, Completed);
+ /// Возвращает анимацию перемещения объекта к точке p за seconds секунд
+ function AnimMoveTo(p: Point3D; seconds: real := 1) := AnimMoveTo(p.x, p.y, p.z, seconds, nil);
+ /// Возвращает анимацию перемещения объекта по траектории, заданной последовательностью точек trajectory за seconds секунд. В конце анимации выполняется процедура Completed
+ function AnimMoveTrajectory(trajectory: sequence of Point3D; seconds: real; Completed: procedure): AnimationBase;
+ /// Возвращает анимацию перемещения объекта по траектории, заданной последовательностью точек trajectory за seconds секунд
+ function AnimMoveTrajectory(trajectory: sequence of Point3D; seconds: real := 1): AnimationBase := AnimMoveTrajectory(trajectory,seconds,nil);
+
+ /// Возвращает анимацию перемещения объекта на вектор (dx, dy, dz) за seconds секунд. В конце анимации выполняется процедура Completed
+ function AnimMoveOn(dx, dy, dz: real; seconds: real; Completed: procedure): AnimationBase;
+ /// Возвращает анимацию перемещения объекта на вектор (dx, dy, dz) за seconds секунд
+ function AnimMoveOn(dx, dy, dz: real; seconds: real := 1): AnimationBase := AnimMoveOn(dx,dy,dz,seconds,nil);
+
+ /// Возвращает анимацию перемещения объекта на вектор v за seconds секунд. В конце анимации выполняется процедура Completed
+ function AnimMoveOn(v: Vector3D; seconds: real; Completed: procedure) := AnimMoveOn(v.x, v.y, v.z, seconds, Completed);
+ /// Возвращает анимацию перемещения объекта на вектор v за seconds секунд
+ function AnimMoveOn(v: Vector3D; seconds: real := 1) := AnimMoveOn(v.x, v.y, v.z, seconds, nil);
+
+ /// Возвращает анимацию перемещения объекта по оси OX на величину dx за seconds секунд. В конце анимации выполняется процедура Completed
+ function AnimMoveOnX(dx: real; seconds: real; Completed: procedure) := AnimMoveOn(dx, 0, 0, seconds, Completed);
+ /// Возвращает анимацию перемещения объекта по оси OX на величину dx за seconds секунд
+ function AnimMoveOnX(dx: real; seconds: real) := AnimMoveOnX(dx, seconds, nil);
+ /// Возвращает анимацию перемещения объекта по оси OX на величину dx за 1 секунду
+ function AnimMoveOnX(dx: real) := AnimMoveOnX(dx, 1, nil);
+
+ /// Возвращает анимацию перемещения объекта по оси OY на величину dy за seconds секунд. В конце анимации выполняется процедура Completed
+ function AnimMoveOnY(dy: real; seconds: real; Completed: procedure) := AnimMoveOn(0, dy, 0, seconds, Completed);
+ /// Возвращает анимацию перемещения объекта по оси OY на величину dy за seconds секунд
+ function AnimMoveOnY(dy: real; seconds: real) := AnimMoveOnY(dy, seconds, nil);
+ /// Возвращает анимацию перемещения объекта по оси OZ на величину dz за 1 секунду
+ function AnimMoveOnY(dy: real) := AnimMoveOnY(dy, 1, nil);
+
+ /// Возвращает анимацию перемещения объекта по оси OZ на величину dz за seconds секунд. В конце анимации выполняется процедура Completed
+ function AnimMoveOnZ(dz: real; seconds: real; Completed: procedure) := AnimMoveOn(0, 0, dz, seconds, Completed);
+ /// Возвращает анимацию перемещения объекта по оси OZ на величину dz за seconds секунд
+ function AnimMoveOnZ(dz: real; seconds: real) := AnimMoveOnZ(dz, seconds, nil);
+ /// Возвращает анимацию перемещения объекта по оси OZ на величину dz за 1 секунду
+ function AnimMoveOnZ(dz: real) := AnimMoveOnZ(dz, 1, nil);
+
+ /// Возвращает анимацию масштабирования объекта на величину sc за seconds секунд. В конце анимации выполняется процедура Completed
+ function AnimScale(sc: real; seconds: real; Completed: procedure): AnimationBase;
+ /// Возвращает анимацию масштабирования объекта по оси OX на величину sc за seconds секунд. В конце анимации выполняется процедура Completed
+ function AnimScaleX(sc: real; seconds: real; Completed: procedure): AnimationBase;
+ /// Возвращает анимацию масштабирования объекта по оси OY на величину sc за seconds секунд. В конце анимации выполняется процедура Completed
+ function AnimScaleY(sc: real; seconds: real; Completed: procedure): AnimationBase;
+ /// Возвращает анимацию масштабирования объекта по оси OZ на величину sc за seconds секунд. В конце анимации выполняется процедура Completed
+ function AnimScaleZ(sc: real; seconds: real; Completed: procedure): AnimationBase;
+
+ /// Возвращает анимацию масштабирования объекта на величину sc за seconds секунд
+ function AnimScale(sc: real; seconds: real := 1): AnimationBase := AnimScale(sc,seconds,nil);
+ /// Возвращает анимацию масштабирования объекта по оси OX на величину sc за seconds секунд
+ function AnimScaleX(sc: real; seconds: real := 1): AnimationBase := AnimScale(sc,seconds,nil);
+ /// Возвращает анимацию масштабирования объекта по оси OY на величину sc за seconds секунд
+ function AnimScaleY(sc: real; seconds: real := 1): AnimationBase := AnimScale(sc,seconds,nil);
+ /// Возвращает анимацию масштабирования объекта по оси OZ на величину sc за seconds секунд
+ function AnimScaleZ(sc: real; seconds: real := 1): AnimationBase := AnimScale(sc,seconds,nil);
+
+ /// Возвращает анимацию поворота объекта вокруг вектора (vx,vy,vz) на величину angle за seconds секунд. В конце анимации выполняется процедура Completed
+ function AnimRotate(vx, vy, vz, angle: real; seconds: real; Completed: procedure): AnimationBase;
+ /// Возвращает анимацию поворота объекта вокруг вектора (vx,vy,vz) на величину angle за seconds секунд
+ function AnimRotate(vx, vy, vz, angle: real; seconds: real := 1): AnimationBase := AnimRotate(vx,vy,vz,angle,seconds,nil);
+
+ /// Возвращает анимацию поворота объекта вокруг вектора v, направленного из центра объекта, на величину angle за seconds секунд. В конце анимации выполняется процедура Completed
+ function AnimRotate(v: Vector3D; angle: real; seconds: real; Completed: procedure) := AnimRotate(v.x, v.y, v.z, angle, seconds, Completed);
+ /// Возвращает анимацию поворота объекта вокруг вектора v, направленного из центра объекта, на величину angle за seconds секунд
+ function AnimRotate(v: Vector3D; angle: real; seconds: real := 1) := AnimRotate(v.x, v.y, v.z, angle, seconds, nil);
+
+ /// Возвращает анимацию поворота объекта вокруг вектора axis, направленного из точки center, на величину angle за seconds секунд. В конце анимации выполняется процедура Completed
+ function AnimRotateAt(axis: Vector3D; angle: real; center: Point3D; seconds: real; Completed: procedure): AnimationBase;
+ /// Возвращает анимацию поворота объекта вокруг вектора axis, направленного из точки center, на величину angle за seconds секунд
+ function AnimRotateAt(axis: Vector3D; angle: real; center: Point3D; seconds: real := 1): AnimationBase := AnimRotateAt(axis,angle,center,seconds,nil);
+
+ /// Клонирует 3D-объект
+ function Clone: Object3D := Invoke&(CloneT);
+ private
+ procedure SaveP(fname: string);
+ begin
+ var f := new System.IO.StreamWriter(fname);
+ XamlWriter.Save(Model, f);
+ f.Close()
+ end;
+ public
+ /// Сохраняет 3D-объект в файл
+ procedure Save(fname: string); virtual := Invoke(SaveP, fname); // надо её сделать виртуальной!
+ class function Load(fname: string): Object3D := Invoke&(()->begin
+ var m := XamlReader.Load(new System.IO.FileStream(fname, System.IO.FileMode.Open)) as Visual3D;
+ Result := new Object3D(m);
+ end);
+ /// Удаляет 3D-объект
+ procedure Destroy(); virtual := DeleteFromObject3DList;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс ObjectWithChildren3D # Graph3D ObjectWithChildren3D class
+// -----------------------------------------------------
+ /// 3D-объект с дочерними подобъектами
+ ObjectWithChildren3D = class(Object3D) // model is ModelVisual3D
+ private
+ l := new List;
+
+ procedure DestroyT;
+ begin
+ end;
+
+ procedure AddT(obj: Object3D);
+ begin
+ var p := Self;
+ while p <> nil do
+ begin
+ if obj = p then
+ raise new System.ArgumentException('Group.Add: Нельзя в дочерние элементы группы добавить себя или своего предка');
+ p := p.Parent
+ end;
+ if obj.Parent = Self then
+ exit;
+
+ if obj.Parent = nil then
+ hvp.Children.Remove(obj.model)
+ else
+ begin
+ var q := obj.Parent.model as ModelVisual3D;
+ q.Children.Remove(obj.model);
+ obj.Parent.l.Remove(obj);
+ end;
+
+ (model as ModelVisual3D).Children.Add(obj.model);
+ l.Add(obj);
+ obj.Parent := Self;
+ end;
+
+ procedure RemoveT(obj: Object3D);
+ begin
+ var b := (model as ModelVisual3D).Children.Remove(obj.model);
+ if not b then exit;
+ l.Remove(obj);
+ hvp.Children.Add(obj.model);
+ obj.Parent := nil;
+ end;
+
+ function GetObj(i: integer): Object3D := l[i];
+ function CountT: integer := (model as ModelVisual3D).Children.Count;
+ function FindVisual(v: Visual3D): Object3D; override;
+ begin
+ Result := nil;
+ if model = v then
+ Result := Self
+ else
+ foreach var x in l do
+ begin
+ Result := x.FindVisual(v);
+ if Result <> nil then
+ exit;
+ end;
+ end;
+
+ protected
+ procedure CloneChildren(from: Object3D); override;
+ begin
+ var ll := (from as ObjectWithChildren3D).l;
+ if ll.Count = 0 then exit;
+ foreach var xx in ll do
+ AddChild(xx.Clone);
+ end;
+
+ public
+ /// Добавить дочерний подобъект
+ procedure AddChild(obj: Object3D) := Invoke(AddT, obj);
+ /// i-тый дочерний подобъект
+ property Items[i: integer]: Object3D read GetObj; default;
+
+ /// Количество дочерних подобъектов
+ function Count: integer := Invoke&(CountT);
+
+ private
+ procedure DestroyP;
+ begin
+ if Parent = nil then
+ hvp.Children.Remove(model)
+ else
+ begin
+ var q := Parent.model as ModelVisual3D;
+ q.Children.Remove(model);
+ Parent.l.Remove(Self);
+ end;
+ model := nil;
+ end;
+
+ public
+ /// Удалить дочерний подобъект
+ procedure Destroy; override;
+ begin
+ inherited Destroy;
+ Invoke(DestroyP);
+ end;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс ObjectWithMaterial3D # Graph3D ObjectWithMaterial3D class
+// -----------------------------------------------------
+ /// 3D-объект с материалом
+ ObjectWithMaterial3D = class(ObjectWithChildren3D) // model is MeshElement3D
+ private
+ procedure CreateBase(m: MeshElement3D; x, y, z: real; mat: GMaterial);
+ begin
+ CreateBase0(m, x, y, z);
+ m.Material := mat;
+ //MaterialHelper.ChangeOpacity(mat,0.1);
+ //MaterialHelper.ChangeOpacity(BackMaterial,0.1);
+ //m.BackMaterial := nil;
+ end;
+
+ function GetColorP: GColor;
+ begin
+ Result := EmptyColor;
+ var g := Material as System.Windows.Media.Media3D.MaterialGroup;
+ if g = nil then exit;
+ var t := g.Children[0] as System.Windows.Media.Media3D.DiffuseMaterial;
+ if t = nil then exit;
+ var v := t.Brush as System.Windows.Media.SolidColorBrush;
+ if v = nil then exit;
+ Result := v.Color;
+ end;
+
+ function GetColor: GColor := Invoke&(GetColorP);
+ procedure SetColorP(c: GColor) := (model as MeshElement3D).Material := MaterialHelper.CreateMaterial(c);
+ procedure SetColor(c: GColor) := Invoke(SetColorP, c);
+ procedure SetVP(v: boolean) := (model as MeshElement3D).Visible := v;
+ procedure SetV(v: boolean) := Invoke(SetVP, v);
+ function GetV: boolean := Invoke&(()->(model as MeshElement3D).Visible);
+
+ procedure SetMP(mat: GMaterial) := (model as MeshElement3D).Material := mat;
+ procedure SetMaterial(mat: GMaterial) := Invoke(SetMP, mat);
+ function GetMaterial: GMaterial := Invoke&(()->(model as MeshElement3D).Material);
+ procedure SetBMP(mat: GMaterial) := (model as MeshElement3D).BackMaterial := mat;
+ procedure SetBMaterial(mat: GMaterial) := Invoke(SetBMP, mat);
+ function GetBMaterial: GMaterial := Invoke&(()->(model as MeshElement3D).BackMaterial);
+ public
+ /// Цвет объекта
+ property Color: GColor read GetColor write SetColor; override;
+ /// Материал объекта
+ property Material: GMaterial read GetMaterial write SetMaterial;
+ /// Материал задней поверхности объекта
+ property BackMaterial: GMaterial read GetBMaterial write SetBMaterial;
+ /// Видим ли объект
+ property Visible: boolean read GetV write SetV;
+ end;
+
+ /// Группа 3D-объектов
+ Group3D = class(ObjectWithChildren3D)
+ protected
+ function CreateObject: Object3D; override := new Group3D(X, Y, Z);
+ public
+ constructor(x, y, z: real) := CreateBase0(new ModelVisual3D, x, y, z);
+
+ constructor(x, y, z: real; lst: sequence of Object3D);
+ begin
+ CreateBase0(new ModelVisual3D, x, y, z);
+ foreach var xx in lst do
+ AddChild(xx);
+ end;
+
+ /// ВОзвращает клон группы 3D-объектов
+ function Clone := (inherited Clone) as Group3D;
+ end;
+
+//------------------------------ Animations -----------------------------------
+
+// -----------------------------------------------------
+//>> Graph3D: класс AnimationBase # Graph3D AnimationBase class
+// -----------------------------------------------------
+ /// Базовый класс анимации 3D-объектов
+ AnimationBase = class
+ private
+ Element: Object3D;
+ Seconds: real;
+ // Completed - действие при завершении элементарной (не составной) анимации (имеющей единую продолжительность).
+ // Не учитывается составными анимациями - у них есть AnimationCompleted. Работает точнее чем sb.Completed.
+ Completed: procedure;
+ // AnimationCompleted - фигурирует только в WhenCompleted. Неточна. После неё индивидуальные анимации делают ещё один шаг
+ AnimationCompleted: procedure;
+ ApplyDecorators := new List;
+ procedure ApplyAllDecorators; virtual;
+ begin
+ foreach var d in ApplyDecorators do
+ d();
+ end;
+
+ procedure InitAnimWait; virtual;
+ begin
+ end;
+
+ private
+ class function AddDoubleAnimRemainderHelper(d: DoubleAnimationBase; sb: StoryBoard; seconds: real; ttname: string; prop: Object): DoubleAnimationBase;
+ begin
+ d.Duration := new System.Windows.Duration(System.TimeSpan.FromSeconds(seconds));
+ StoryBoard.SetTargetName(d, ttname);
+ StoryBoard.SetTargetProperty(d, new PropertyPath(prop));
+ sb.Children.Add(d);
+ Result := d;
+ end;
+
+ protected
+ sb: StoryBoard;
+
+ class function AddDoubleAnimByName(sb: StoryBoard; toValue, seconds: real; ttname: string; prop: Object): DoubleAnimationBase;
+ begin
+ var d := new DoubleAnimation();
+ d.To := toValue;
+ Result := AddDoubleAnimRemainderHelper(d, sb, seconds, ttname, prop);
+ end;
+
+ class function AddDoubleAnimOnByName(sb: StoryBoard; toValue, seconds: real; ttname: string; prop: Object): DoubleAnimationBase;
+ begin
+ var d := new DoubleAnimation();
+ d.By := toValue;
+ Result := AddDoubleAnimRemainderHelper(d, sb, seconds, ttname, prop);
+ end;
+
+ class function AddDoubleAnimByNameUsingKeyframes(sb: StoryBoard; a: sequence of real; seconds: real; ttname: string; prop: Object): DoubleAnimationBase;
+ begin
+ var d := new DoubleAnimationUsingKeyframes;
+ d.KeyFrames := new DoubleKeyFrameCollection;
+ foreach var x in a do
+ d.KeyFrames.Add(new LinearDoubleKeyFrame(x)); // не указываем keytime - надеемся, что по секунде
+ Result := AddDoubleAnimRemainderHelper(d, sb, seconds, ttname, prop);
+ end;
+
+ {class function AddDoubleAnimByNameUsingTrajectory(sb: StoryBoard; a: sequence of real; seconds: real; ttname: string; prop: Object; waittime: real := 0.0): DoubleAnimationBase;
+ begin
+ var d := new DoubleAnimationUsingKeyframes;
+ d.KeyFrames := new DoubleKeyFrameCollection;
+ foreach var x in a do
+ d.KeyFrames.Add(new LinearDoubleKeyFrame(x)); // не указываем keytime - надеемся, что по секунде
+ d.Duration := new System.Windows.Duration(System.TimeSpan.FromSeconds(seconds));
+ d.BeginTime := System.TimeSpan.FromSeconds(waittime);
+ StoryBoard.SetTargetName(d, ttname);
+ StoryBoard.SetTargetProperty(d, new PropertyPath(prop));
+ sb.Children.Add(d);
+ Result := d;
+ end;}
+
+ function RegisterName(sb: StoryBoard; element: Object; ttname: string): boolean;
+ begin
+ Result := False;
+ if MainWindow.FindName(ttname) = nil then
+ begin
+ MainWindow.RegisterName(ttname, element);
+ sb.Completed += (o, e) -> begin
+ if MainWindow.FindName(ttname) <> nil then
+ MainWindow.UnregisterName(ttname);
+ end;
+ Result := True;
+ end;
+ end;
+
+ procedure InitAnim; virtual := InitAnimWait;
+ private
+ function CreateStoryboard: StoryBoard;
+ begin
+ sb := new StoryBoard;
+ var storyboardName := 's' + sb.GetHashCode;
+ MainWindow.Resources.Add(storyboardName, sb);
+ var an := AnimationCompleted;
+ sb.Completed += (o, e) -> begin
+ MainWindow.Resources.Remove(storyboardName);
+ if an <> nil then
+ an;
+ end;
+
+ Result := sb;
+ end;
+
+ public
+ constructor(e: Object3D; sec: real; Completed: procedure := nil);
+ begin
+ Self.Completed := Completed;
+ (Element, Seconds) := (e, sec);
+ end;
+
+ /// Устанавливает действие по завершению анимации
+ function WhenCompleted(act: procedure): AnimationBase;
+ begin
+ Self.AnimationCompleted := act;
+ Result := Self;
+ end;
+
+ private
+ procedure BeginT;
+ begin
+ sb := CreateStoryboard;
+ InitAnim;
+
+ ApplyAllDecorators;
+ sb.Begin;
+ end;
+
+ procedure RemoveT := begin
+ sb.Pause;
+ sb.Remove;
+ sb := new Storyboard;
+ end;
+ procedure ChangeT(a: AnimationBase);
+ begin
+ sb := CreateStoryboard;
+ foreach var d in a.sb.Children do
+ sb.Children.Add(d);
+ end;
+
+ public
+ /// Начинает анимацию
+ procedure &Begin; virtual := Invoke(BeginT);
+ /// Удаляет анимацию
+ procedure Remove := Invoke(RemoveT);
+ /// Меняет анимацию на другую
+ procedure Change(a: AnimationBase) := Invoke(ChangeT, a);
+ /// Делает паузу анимации
+ procedure Pause := if sb <> nil then sb.Pause;
+ /// Возобновляет анимацию
+ procedure Resume := if sb <> nil then sb.Resume;
+
+ /// Возвращает продолжительность анимации
+ function Duration: real; virtual := seconds;
+ /// Указывает анимацию, выполняющуюся после данной
+ function &Then(second: AnimationBase): AnimationBase;
+ /// Модификатор анимации, выполняющий её бесконечно. Не может быть применен к группе анимаций
+ function Forever: AnimationBase; virtual := Self;
+ /// Модификатор анимации, возвращающий объект в исходное положение. Не может быть применен к группе анимаций
+ function AutoReverse: AnimationBase; virtual := Self;
+ /// Модификатор анимации, устанавливающий ускорение анимации в начале и замедление анимации в конце
+ function AccelerationRatio(acceleration: real; deceleration: real := 0): AnimationBase; virtual := Self;
+ end;
+
+ EmptyAnimation = class(AnimationBase)
+ public
+ constructor(wait: real) := Seconds := wait;
+ procedure InitAnim(); override := InitAnimWait;
+ end;
+
+
+ Double1AnimationBase = class(AnimationBase)
+ private
+ v: real;
+ da: DoubleAnimationBase;
+ public
+ constructor(e: Object3D; sec: real; value: real; Completed: procedure := nil);
+ begin
+ inherited Create(e, sec, Completed);
+ v := value;
+ end;
+
+ function AutoReverse: AnimationBase; override;
+ begin
+ ApplyDecorators.Add(()-> begin
+ da.AutoReverse := True;
+ end);
+ Result := Self;
+ end;
+
+ function Forever: AnimationBase; override;
+ begin
+ ApplyDecorators.Add(()-> begin
+ da.RepeatBehavior := RepeatBehavior.Forever;
+ end);
+ Result := Self;
+ end;
+
+ function AccelerationRatio(acceleration: real; deceleration: real := 0): AnimationBase; override;
+ begin
+ if acceleration < 0 then acceleration := 0;
+ if acceleration > 1 then acceleration := 1;
+ if deceleration < 0 then deceleration := 0;
+ if deceleration > 1 then deceleration := 1;
+ if acceleration + deceleration > 1 then
+ begin
+ acceleration /= acceleration + deceleration;
+ deceleration := 1 - acceleration;
+ end;
+ ApplyDecorators.Add(()-> begin
+ da.AccelerationRatio := acceleration;
+ da.DecelerationRatio := deceleration;
+ end);
+ Result := Self;
+ end;
+ end;
+
+ Double3AnimationBase = class(AnimationBase)
+ private
+ x, y, z: real;
+ dax, day, daz: DoubleAnimationBase;
+ public
+ constructor(e: Object3D; sec: real; xx, yy, zz: real; Completed: procedure := nil);
+ begin
+ inherited Create(e, sec, Completed);
+ (x, y, z) := (xx, yy, zz);
+ end;
+
+ function AutoReverse: AnimationBase; override;
+ begin
+ ApplyDecorators.Add(()-> begin
+ dax.AutoReverse := True;
+ day.AutoReverse := True;
+ daz.AutoReverse := True;
+ end);
+ Result := Self;
+ end;
+
+ function Forever: AnimationBase; override;
+ begin
+ ApplyDecorators.Add(()-> begin
+ dax.RepeatBehavior := RepeatBehavior.Forever;
+ day.RepeatBehavior := RepeatBehavior.Forever;
+ daz.RepeatBehavior := RepeatBehavior.Forever;
+ end);
+ Result := Self;
+ end;
+
+ function AccelerationRatio(acceleration: real; deceleration: real := 0): AnimationBase; override;
+ begin
+ if acceleration < 0 then acceleration := 0;
+ if acceleration > 1 then acceleration := 1;
+ if deceleration < 0 then deceleration := 0;
+ if deceleration > 1 then deceleration := 1;
+ if acceleration + deceleration > 1 then
+ begin
+ acceleration /= acceleration + deceleration;
+ deceleration := 1 - acceleration;
+ end;
+ ApplyDecorators.Add(()-> begin
+ dax.AccelerationRatio := acceleration;
+ day.AccelerationRatio := acceleration;
+ daz.AccelerationRatio := acceleration;
+ dax.DecelerationRatio := deceleration;
+ day.DecelerationRatio := deceleration;
+ daz.DecelerationRatio := deceleration;
+ end);
+ Result := Self;
+ end;
+ end;
+
+ OffsetAnimationOn = class(Double3AnimationBase)
+ private
+ el: TranslateTransform3D;
+ procedure Hand(o: object; e: System.EventArgs);
+ begin
+ var el0 := Element.transltransform;
+ el0.OffsetX += el.OffsetX;
+ el0.OffsetY += el.OffsetY;
+ el0.OffsetZ += el.OffsetZ;
+ Element.transfgroup.Children.Remove(el);
+ if Completed <> nil then
+ Completed();
+ end;
+
+ procedure InitAnimWait; override;
+ begin
+ el := new TranslateTransform3D();
+ Element.transfgroup.Children.Add(el);
+ var ttname := 't' + el.GetHashCode;
+ if not RegisterName(sb, el, ttname) then;
+ dax := AddDoubleAnimOnByName(sb, x, seconds, ttname, TranslateTransform3D.OffsetXProperty);
+ day := AddDoubleAnimOnByName(sb, y, seconds, ttname, TranslateTransform3D.OffsetYProperty);
+ daz := AddDoubleAnimOnByName(sb, z, seconds, ttname, TranslateTransform3D.OffsetZProperty);
+ daz.Completed += Hand;
+ end;
+ public
+ end;
+
+ OffsetAnimation = class(OffsetAnimationOn)
+ procedure InitAnimWait; override;
+ begin
+ el := new TranslateTransform3D();
+ Element.transfgroup.Children.Add(el);
+ var ttname := 't' + el.GetHashCode;
+ if not RegisterName(sb, el, ttname) then;
+ dax := AddDoubleAnimOnByName(sb, x-Element.x, seconds, ttname, TranslateTransform3D.OffsetXProperty);
+ day := AddDoubleAnimOnByName(sb, y-Element.y, seconds, ttname, TranslateTransform3D.OffsetYProperty);
+ daz := AddDoubleAnimOnByName(sb, z-Element.z, seconds, ttname, TranslateTransform3D.OffsetZProperty);
+ daz.Completed += Hand;
+ end;
+ public
+ end;
+
+ OffsetAnimationUsingKeyframes = class(Double3AnimationBase)
+ private
+ el: TranslateTransform3D;
+ a: sequence of Point3D;
+ procedure Hand(o: object; e: System.EventArgs);
+ begin
+ var el0 := Element.transltransform;
+ el0.OffsetX += el.OffsetX;
+ el0.OffsetY += el.OffsetY;
+ el0.OffsetZ += el.OffsetZ;
+ Element.transfgroup.Children.Remove(el);
+ if Completed <> nil then
+ Completed();
+ end;
+ procedure InitAnimWait; override;
+ begin
+ el := new TranslateTransform3D();
+ Element.transfgroup.Children.Add(el);
+ var ttname := 't' + el.GetHashCode;
+ if not RegisterName(sb, el, ttname) then;
+ var aa := a.ToArray;
+ dax := AddDoubleAnimByNameUsingKeyframes(sb, aa.Select(p -> p.x-Element.x), seconds, ttname, TranslateTransform3D.OffsetXProperty);
+ day := AddDoubleAnimByNameUsingKeyframes(sb, aa.Select(p -> p.y-Element.y), seconds, ttname, TranslateTransform3D.OffsetYProperty);
+ daz := AddDoubleAnimByNameUsingKeyframes(sb, aa.Select(p -> p.z-Element.z), seconds, ttname, TranslateTransform3D.OffsetZProperty);
+ daz.Completed += Hand;
+ end;
+
+ public
+ constructor(e: Object3D; sec: real; aa: sequence of Point3D; Completed: procedure := nil);
+ begin
+ inherited Create(e, sec, Completed);
+ a := aa;
+ end;
+ end;
+
+ ScaleAnimation = class(Double3AnimationBase)
+ private
+ scale: real;
+ el: ScaleTransform3D;
+ procedure Hand(o: object; e: System.EventArgs);
+ begin
+ var el0 := Element.scaletransform;
+ el0.ScaleX += el.ScaleX;
+ el0.ScaleY += el.ScaleY;
+ el0.ScaleZ += el.ScaleZ;
+ Element.transfgroup.Children.Remove(el);
+ if Completed <> nil then
+ Completed();
+ end;
+ procedure InitAnimWait; override;
+ begin
+ el := new ScaleTransform3D();
+ Element.transfgroup.Children.Add(el);
+ var sctransform := Element.scaletransform;
+ var ttname := 's' + sctransform.GetHashCode;
+ if not RegisterName(sb, sctransform, ttname) then;
+ dax := AddDoubleAnimByName(sb, scale, seconds, ttname, ScaleTransform3D.ScaleXProperty);
+ day := AddDoubleAnimByName(sb, scale, seconds, ttname, ScaleTransform3D.ScaleYProperty);
+ daz := AddDoubleAnimByName(sb, scale, seconds, ttname, ScaleTransform3D.ScaleZProperty);
+ daz.Completed += Hand;
+ end;
+ public
+ constructor(e: Object3D; sec: real; sc: real; Completed: procedure := nil);
+ begin
+ inherited Create(e, sec, Completed);
+ scale := sc;
+ end;
+ end;
+
+ ScaleXAnimation = class(Double1AnimationBase)
+ private
+ scale: real;
+ el: ScaleTransform3D;
+ procedure Hand(o: object; e: System.EventArgs);
+ begin
+ var el0 := Element.scaletransform;
+ el0.ScaleX += el.ScaleX;
+ Element.transfgroup.Children.Remove(el);
+ if Completed <> nil then
+ Completed();
+ end;
+ procedure InitAnimWait; override;
+ begin
+ el := new ScaleTransform3D();
+ Element.transfgroup.Children.Add(el);
+ var sctransform := Element.scaletransform;
+ var ttname := 's' + sctransform.GetHashCode;
+ if not RegisterName(sb, sctransform, ttname) then;
+ da := AddDoubleAnimByName(sb, scale, seconds, ttname, ScaleTransform3D.ScaleXProperty);
+ da.Completed += Hand;
+ end;
+ public
+ constructor(e: Object3D; sec: real; sc: real; Completed: procedure := nil);
+ begin
+ inherited Create(e, sec, Completed);
+ scale := sc;
+ end;
+ end;
+
+ ScaleYAnimation = class(ScaleXAnimation)
+ private
+ procedure Hand(o: object; e: System.EventArgs);
+ begin
+ var el0 := Element.scaletransform;
+ el0.ScaleY += el.ScaleY;
+ Element.transfgroup.Children.Remove(el);
+ if Completed <> nil then
+ Completed();
+ end;
+ procedure InitAnimWait; override;
+ begin
+ el := new ScaleTransform3D();
+ Element.transfgroup.Children.Add(el);
+ var sctransform := Element.scaletransform;
+ var ttname := 's' + sctransform.GetHashCode;
+ if not RegisterName(sb, sctransform, ttname) then;
+ da := AddDoubleAnimByName(sb, scale, seconds, ttname, ScaleTransform3D.ScaleYProperty);
+ da.Completed += Hand;
+ end;
+ end;
+
+ ScaleZAnimation = class(ScaleXAnimation)
+ private
+ procedure Hand(o: object; e: System.EventArgs);
+ begin
+ var el0 := Element.scaletransform;
+ el0.ScaleZ += el.ScaleZ;
+ Element.transfgroup.Children.Remove(el);
+ if Completed <> nil then
+ Completed();
+ end;
+ procedure InitAnimWait; override;
+ begin
+ el := new ScaleTransform3D();
+ Element.transfgroup.Children.Add(el);
+ var sctransform := Element.scaletransform;
+ var ttname := 's' + sctransform.GetHashCode;
+ if not RegisterName(sb, sctransform, ttname) then;
+ da := AddDoubleAnimByName(sb, scale, seconds, ttname, ScaleTransform3D.ScaleZProperty);
+ da.Completed += Hand;
+ end;
+ end;
+
+ RotateAtAnimation = class(Double1AnimationBase)
+ private
+ vx, vy, vz, angle: real;
+ center: Point3D;
+ el: RotateTransform3D;
+ procedure Hand(o: object; e: System.EventArgs);
+ begin
+ var rot := el.Rotation as AxisAngleRotation3D;
+ Element.RotateAt(rot.Axis, angle, center);
+ Element.transfgroup.Children.Remove(el);
+ if Completed <> nil then
+ Completed();
+ end;
+
+ procedure InitAnimWait; override;
+ begin
+ el := new RotateTransform3D();
+ el.Rotation := new AxisAngleRotation3D();
+
+ Element.transfgroup.Children.Insert(0,el); // До основной матрицы, связанной с поворотом
+ var rottransform := el;
+ rottransform.CenterX := center.x;
+ rottransform.CenterY := center.y;
+ rottransform.CenterZ := center.z;
+ var rot := rottransform.Rotation as AxisAngleRotation3D;
+ var ttname := 'r' + rot.GetHashCode;
+ if not RegisterName(sb, rot, ttname) then;
+
+ rot.Angle := 0; //?
+ rot.Axis := V3D(vx, vy, vz); //?
+
+ //var elem: Object3D := Element;
+ // Мб da.Completed
+
+ da := AddDoubleAnimByName(sb, angle, seconds, ttname, AxisAngleRotation3D.AngleProperty);
+ da.Completed += Hand;
+ end;
+
+ public
+ constructor(e: Object3D; sec: real; vvx, vvy, vvz, a: real; c: Point3D; Completed: procedure := nil);
+ begin
+ inherited Create(e, sec, Completed);
+ (vx, vy, vz, angle, center) := (vvx, vvy, vvz, a, c)
+ end;
+ end;
+
+ CompositeAnimation = class(AnimationBase)
+ private
+ ll: List;
+ public
+ constructor(params l: array of AnimationBase) := ll := Lst(l);
+ constructor(l: List) := ll := l;
+ end;
+
+ GroupAnimation = class(CompositeAnimation)
+ public
+ function Duration: real; override := ll.Select(l -> l.Duration).Max;
+ function Add(b: AnimationBase): GroupAnimation;
+ begin
+ ll += b;
+ Result := Self;
+ end;
+ class function operator +=(a: GroupAnimation; b: AnimationBase): GroupAnimation;
+ begin
+ a.ll += b;
+ Result := a;
+ end;
+ procedure BeginT;
+ begin
+ for var i:=0 to ll.Count-1 do
+ ll[i].Begin;
+ end;
+ procedure &Begin; override := Invoke(BeginT);
+ end;
+
+ SequenceAnimation = class(CompositeAnimation)
+ public
+ function Duration: real; override := ll.Select(l -> l.Duration).Sum;
+ function Add(b: AnimationBase): SequenceAnimation;
+ begin
+ ll += b;
+ Result := Self;
+ end;
+ class function operator +=(a: SequenceAnimation; b: AnimationBase): SequenceAnimation;
+ begin
+ a.ll += b;
+ Result := a;
+ end;
+ procedure BeginT;
+ begin
+ for var ii:=0 to ll.Count-2 do
+ begin
+ var i := ii; // параметр цикла неправильно захватывается лямбдой
+ var lll := ll; // поле предка - вообще не захватывается
+
+ // Если ll[i] - CompositeAnimation, то надо повесить Completed на самую правую не CompositeAnimation
+ var lf := ll[i];
+ while lf is CompositeAnimation do
+ begin
+ var ca := lf as CompositeAnimation;
+ lf := ca.ll[ca.ll.Count-1];
+ end;
+
+ lf.Completed += procedure ->
+ begin
+ lll[i+1].Begin;
+ end;
+ end;
+ ll[0].Begin;
+ end;
+ procedure &Begin; override := Invoke(BeginT);
+ end;
+
+ /// Класс, содержащий комбинации анимаций: группа и последовательность
+ Animate = class
+ public
+ /// Возвращает группу анимаций, выполняющихся параллельно
+ class function Group(params l: array of AnimationBase) := new GroupAnimation(Lst(l));
+ /// Возвращает последовательность анимаций, выполняющихся последовательно
+ class function &Sequence(params l: array of AnimationBase) := new SequenceAnimation(l);
+ end;
+
+type
+// -----------------------------------------------------
+//>> Graph3D: класс SphereT # Graph3D SphereT class
+// -----------------------------------------------------
+/// Класс сферы
+ SphereT = class(ObjectWithMaterial3D)
+ private
+ function Model := inherited model as SphereVisual3D;
+ procedure SetRP(r: real) := Model.Radius := r;
+ procedure SetR(r: real) := Invoke(SetRP, r);
+ function GetR: real := InvokeReal(()->Model.Radius);
+ function NewVisualObject(r: real): SphereVisual3D;
+ begin
+ var sph := new SphereVisual3D;
+ sph.Center := P3D(0,0,0);
+ sph.Radius := r;
+ Result := sph;
+ end;
+
+ protected
+ function CreateObject: Object3D; override := new SphereT(X, Y, Z, Radius, Material.Clone);
+ constructor := CreateBase(NewVisualObject(1), 0, 0, 0, Materialhelper.CreateMaterial(Colors.Blue));
+ constructor(x, y, z, r: real; m: Gmaterial) := CreateBase(NewVisualObject(r), x, y, z, m);
+ public
+/// Радиус сферы
+ property Radius: real read GetR write SetR;
+/// Возвращает клон сферы
+ function Clone := (inherited Clone) as SphereT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс EllipsoidT # Graph3D EllipsoidT class
+// -----------------------------------------------------
+/// Класс эллипсоида
+ EllipsoidT = class(ObjectWithMaterial3D)
+ private
+ function Model := inherited model as EllipsoidVisual3D;
+ procedure SetRX(r: real) := Invoke(procedure(r: real)->Model.RadiusX := r, r);
+ function GetRX: real := InvokeReal(()->Model.RadiusX);
+ procedure SetRYP(r: real) := Model.RadiusY := r;
+ procedure SetRY(r: real) := Invoke(SetRYP, r);
+ function GetRY: real := InvokeReal(()->Model.RadiusY);
+ procedure SetRZP(r: real) := Model.RadiusZ := r;
+ procedure SetRZ(r: real) := Invoke(SetRZP, r);
+ function GetRZ: real := InvokeReal(()->Model.RadiusZ);
+ function NewVisualObject(rx, ry, rz: real): EllipsoidVisual3D;
+ begin
+ var ell := new EllipsoidVisual3D;
+ ell.Center := P3D(0,0,0);
+ ell.RadiusX := rx;
+ ell.RadiusY := ry;
+ ell.RadiusZ := rz;
+ Result := ell;
+ end;
+
+ protected
+ function CreateObject: Object3D; override := new EllipsoidT(X, Y, Z, RadiusX, RadiusY, RadiusZ, Material.Clone);
+ constructor(x, y, z, rx, ry, rz: real; m: GMaterial) := CreateBase(NewVisualObject(rx, ry, rz), x, y, z, m);
+ public
+/// Радиус эллипсоида по оси X
+ property RadiusX: real read GetRX write SetRX;
+/// Радиус эллипсоида по оси Y
+ property RadiusY: real read GetRY write SetRY;
+/// Радиус эллипсоида по оси Z
+ property RadiusZ: real read GetRZ write SetRZ;
+/// Возвращает клон эллипсоида
+ function Clone := (inherited Clone) as EllipsoidT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс CubeT # Graph3D CubeT class
+// -----------------------------------------------------
+/// Класс куба
+ CubeT = class(ObjectWithMaterial3D)
+ private
+ function model := inherited model as CubeVisual3D;
+ procedure SetWP(r: real) := model.SideLength := r;
+ procedure SetW(r: real) := Invoke(SetWP, r);
+ function GetW: real := InvokeReal(()->model.SideLength);
+ private
+ function NewVisualObject(w: real): CubeVisual3D;
+ begin
+ var bx := new CubeVisual3D;
+ bx.Center := P3D(0,0,0);
+ bx.SideLength := w;
+ Result := bx;
+ end;
+
+ protected
+ function CreateObject: Object3D; override := new CubeT(X, Y, Z, SideLength, Material.Clone);
+ constructor(x, y, z, w: real; m: GMaterial) := CreateBase(NewVisualObject(w), x, y, z, m);
+
+ public
+/// Сторона куба
+ property SideLength: real read GetW write SetW;
+/// Возвращает клон куба
+ function Clone := (inherited Clone) as CubeT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс BoxT # Graph3D BoxT class
+// -----------------------------------------------------
+/// Класс паралеллепипеда
+ BoxT = class(ObjectWithMaterial3D)
+ private
+ function model := inherited model as BoxVisual3D;
+ procedure SetWP(r: real) := model.Width := r;
+ procedure SetW(r: real) := Invoke(SetWP, r);
+ function GetW: real := InvokeReal(()->model.Width);
+
+ procedure SetHP(r: real) := model.Height := r;
+ procedure SetH(r: real) := Invoke(SetHP, r);
+ function GetH: real := InvokeReal(()->model.Height);
+
+ procedure SetLP(r: real) := model.Length := r;
+ procedure SetL(r: real) := Invoke(SetLP, r);
+ function GetL: real := InvokeReal(()->model.Length);
+
+ procedure SetSzP(r: Size3D) := (model.Length, model.Width, model.Height) := (r.X, r.Y, r.Z);
+ procedure SetSz(r: Size3D) := Invoke(SetSzP, r);
+ function GetSz: Size3D := Inv(()->Sz3D(model.Length, model.Width, model.Height));
+ private
+ function NewVisualObject(l, w, h: real): BoxVisual3D;
+ begin
+ var bx := new BoxVisual3D;
+ bx.Center := P3D(0,0,0);
+ (bx.Width, bx.Height, bx.Length) := (w, h, l);
+ Result := bx;
+ end;
+
+ protected
+ function CreateObject: Object3D; override := new BoxT(X, Y, Z, Length, Width, Height, Material.Clone);
+ constructor(x, y, z, l, w, h: real; m: GMaterial) := CreateBase(NewVisualObject(l, w, h), x, y, z, m);
+
+ public
+/// Возвращает длину паралеллепипеда (по оси X)
+ property Length: real read GetL write SetL;
+/// Возвращает ширину паралеллепипеда (по оси Y)
+ property Width: real read GetW write SetW;
+/// Возвращает высоту паралеллепипеда (по оси Z)
+ property Height: real read GetH write SetH;
+/// Возвращает размеры паралеллепипеда
+ property Size: Size3D read GetSz write SetSz;
+/// Возвращает клон паралеллепипеда
+ function Clone := (inherited Clone) as BoxT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс ArrowT # Graph3D ArrowT class
+// -----------------------------------------------------
+/// Класс 3D-стрелки
+ ArrowT = class(ObjectWithMaterial3D)
+ private
+ function model := inherited model as ArrowVisual3D;
+
+ procedure SetDP(r: real) := model.Diameter := r;
+ procedure SetD(r: real) := Invoke(SetDP, r);
+ function GetD: real := InvokeReal(()->model.Diameter);
+
+ procedure SetLP(r: real) := model.HeadLength := r;
+ procedure SetL(r: real) := Invoke(SetLP, r);
+ function GetL: real := InvokeReal(()->model.HeadLength);
+
+ procedure SetDirP(r: Vector3D) := model.Direction := r;
+ procedure SetDir(r: Vector3D) := Invoke(SetDirP, r);
+ function GetDir: Vector3D := Invoke&(()->model.Direction);
+ private
+ function NewVisualObject(dx, dy, dz, d, hl: real): ArrowVisual3D;
+ begin
+ var a := new ArrowVisual3D;
+ a.HeadLength := hl;
+ a.Diameter := d;
+ a.Origin := P3D(0,0,0);
+ Result := a;
+ end;
+
+ protected
+ function CreateObject: Object3D; override := new ArrowT(X, Y, Z, Direction.X, Direction.Y, Direction.Z, Diameter, HeadLength, Material.Clone);
+ constructor(x, y, z, dx, dy, dz, d, hl: real; m: GMaterial);
+ begin
+ var a := NewVisualObject(dx, dy, dz, d, hl);
+ CreateBase(a, x, y, z, m);
+ a.Direction := V3D(dx, dy, dz);
+ end;
+
+ public
+/// Длина наконечника 3D-стрелки
+ property HeadLength: real read GetL write SetL;
+/// Диаметр 3D-стрелки
+ property Diameter: real read GetD write SetD;
+/// направление 3D-стрелки
+ property Direction: Vector3D read GetDir write SetDir;
+/// Возвращает клон 3D-стрелки
+ function Clone := (inherited Clone) as ArrowT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс TruncatedConeT # Graph3D TruncatedConeT class
+// -----------------------------------------------------
+/// Класс усеченного конуса
+ TruncatedConeT = class(ObjectWithMaterial3D)
+ private
+ function model := inherited model as TruncatedConeVisual3D;
+
+ procedure SetH(r: real) := Invoke(procedure(r: real)->model.Height := r, r);
+ function GetH: real := InvokeReal(()->model.Height);
+
+ procedure SetBRP(r: real) := model.BaseRadius := r;
+ procedure SetBR(r: real) := Invoke(SetBRP, r);
+ function GetBR: real := InvokeReal(()->model.BaseRadius);
+
+ procedure SetTRP(r: real) := model.TopRadius := r;
+ procedure SetTR(r: real) := Invoke(SetTRP, r);
+ function GetTR: real := InvokeReal(()->model.TopRadius);
+
+ procedure SetTCP(r: boolean) := model.TopCap := r;
+ procedure SetTC(r: boolean) := Invoke(SetTCP, r);
+ function GetTC: boolean := Invoke&(()->model.TopCap);
+ private
+ function NewVisualObject(h, baser, topr: real; sides: integer; topcap: boolean): TruncatedConeVisual3D;
+ begin
+ var a := new TruncatedConeVisual3D;
+ a.Origin := P3D(0,0,0);
+ a.BaseRadius := baser;
+ a.TopRadius := topr;
+ a.Height := h;
+ a.TopCap := topcap;
+ a.ThetaDiv := sides + 1;
+ a.BaseCap := True;
+ Result := a;
+ end;
+
+ protected
+ function CreateObject: Object3D; override := new TruncatedConeT(X, Y, Z, Height, BaseRadius, TopRadius, (model as TruncatedConeVisual3D).ThetaDiv - 1, Topcap, Material.Clone);
+ constructor(x, y, z, h, baser, topr: real; sides: integer; topcap: boolean; m: GMaterial);
+ begin
+ var a := NewVisualObject(h, baser, topr, sides, topcap);
+ CreateBase(a, x, y, z, m);
+ end;
+
+ public
+/// Высота усеченного конуса
+ property Height: real read GetH write SetH;
+/// Радиус основания усеченного конуса
+ property BaseRadius: real read GetBR write SetBR;
+/// Верхний радиус усеченного конуса
+ property TopRadius: real read GetTR write SetTR;
+/// Есть ли шапочка у усеченного конуса
+ property Topcap: boolean read GetTC write SetTC;
+/// Возвращает клон усеченного конуса
+ function Clone := (inherited Clone) as TruncatedConeT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс CylinderT # Graph3D CylinderT class
+// -----------------------------------------------------
+/// Класс цилиндра
+ CylinderT = class(TruncatedConeT)
+ private
+ procedure SetR(r: real);
+ begin
+ BaseRadius := r;
+ TopRadius := r;
+ end;
+
+ function GetR: real := BaseRadius;
+ protected
+ function CreateObject: Object3D; override := new CylinderT(X, Y, Z, Height, Radius, (model as TruncatedConeVisual3D).ThetaDiv - 1, Topcap, Material.Clone);
+ constructor(x, y, z, h, r: real; ThetaDiv: integer; topcap: boolean; m: GMaterial);
+ begin
+ var a := NewVisualObject(h, r, r, ThetaDiv, topcap);
+ CreateBase(a, x, y, z, m);
+ end;
+
+ public
+/// Радиус цилиндра
+ property Radius: real read GetR write SetR;
+/// Возвращает клон цилиндра
+ function Clone := (inherited Clone) as CylinderT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс TeapotT # Graph3D TeapotT class
+// -----------------------------------------------------
+/// Класс чайника
+ TeapotT = class(ObjectWithMaterial3D)
+ private
+ procedure SetVP(v: boolean) := (model as MeshElement3D).Visible := v;
+ procedure SetV(v: boolean) := Invoke(SetVP, v);
+ function GetV: boolean := Invoke&(()->(model as MeshElement3D).Visible);
+ protected
+ function CreateObject: Object3D; override := new TeapotT(X, Y, Z, Material.Clone);
+ constructor(x, y, z: real; m: GMaterial);
+ begin
+ var a := new Teapot;
+ CreateBase(a, x, y, z, m);
+ Rotate(V3D(1,0,0), 90);
+ end;
+ public
+/// Видим ли чайник
+ property Visible: boolean read GetV write SetV;
+/// Возвращает клон чайника
+ function Clone := (inherited Clone) as TeapotT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс CoordinateSystemT # Graph3D CoordinateSystemT class
+// -----------------------------------------------------
+/// Класс системы координат
+ CoordinateSystemT = class(ObjectWithChildren3D)
+ private
+ procedure SetALP(r: real) := (model as CoordinateSystemVisual3D).ArrowLengths := r;
+ procedure SetAL(r: real) := Invoke(SetALP, r);
+ function GetAL: real := InvokeReal(()->(model as CoordinateSystemVisual3D).ArrowLengths);
+ function GetD: real := InvokeReal(()->((model as CoordinateSystemVisual3D).Children[0] as ArrowVisual3D).Diameter);
+ protected
+ function CreateObject: Object3D; override := new CoordinateSystemT(X, Y, Z, ArrowLengths, Diameter);
+ constructor(x, y, z, arrlength, diameter: real);
+ begin
+ var a := new CoordinateSystemVisual3D;
+ CreateBase0(a, x, y, z);
+ a.ArrowLengths := arrlength;
+ (a.Children[0] as ArrowVisual3D).Diameter := diameter;
+ (a.Children[1] as ArrowVisual3D).Diameter := diameter;
+ (a.Children[2] as ArrowVisual3D).Diameter := diameter;
+ (a.Children[3] as CubeVisual3D).SideLength := diameter;
+ end;
+
+ public
+/// Длина стрелок системы координат
+ property ArrowLengths: real read GetAL write SetAL;
+/// Диаметр стрелок системы координат
+ property Diameter: real read GetD;
+/// Возвращает клон системы координат
+ function Clone := (inherited Clone) as CoordinateSystemT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс BillboardTextT # Graph3D BillboardTextT class
+// -----------------------------------------------------
+/// Класс текста на билборде (всегда направлен к камере)
+ BillboardTextT = class(ObjectWithChildren3D)
+ private
+ function model := inherited model as BillboardTextVisual3D;
+
+ procedure SetTP(r: string) := model.Text := r;
+ procedure SetT(r: string) := Invoke(SetTP, r);
+ function GetT: string := InvokeString(()->model.Text);
+
+ procedure SetFSP(r: real) := model.FontSize := r;
+ procedure SetFS(r: real) := Invoke(SetFSP, r);
+ function GetFS: real := InvokeReal(()->model.FontSize);
+ protected
+ function CreateObject: Object3D; override := new BillboardTextT(X, Y, Z, Text, FontSize);
+ constructor(x, y, z: real; text: string; fontsize: real);
+ begin
+ var a := new BillboardTextVisual3D;
+ CreateBase0(a, x, y, z);
+ a.Position := p3D(0, 0, 0);
+ a.Text := text;
+ a.FontSize := fontsize;
+ end;
+
+ public
+/// Текст на билборде
+ property Text: string read GetT write SetT;
+/// Размер шрифта на билборде
+ property FontSize: real read GetFS write SetFS;
+/// Возвращает клон билборда
+ function Clone := (inherited Clone) as BillboardTextT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс TextT # Graph3D TextT class
+// -----------------------------------------------------
+/// Класс 3D-текстового объекта
+ TextT = class(ObjectWithChildren3D)
+ private
+ _fontname: string;
+ function model := inherited model as TextVisual3D;
+
+ procedure SetTP(r: string) := model.Text := r;
+ procedure SetT(r: string) := Invoke(SetTP, r);
+ function GetT: string := InvokeString(()->model.Text);
+
+ procedure SetFSP(r: real) := model.Height := r;
+ procedure SetFS(r: real) := Invoke(SetFS, r);
+ function GetFS: real := InvokeReal(()->model.Height);
+
+ procedure SetUP(v: Vector3D) := model.UpDirection := v;
+ procedure SetU(v: Vector3D) := Invoke(SetUP, v);
+ function GetU: Vector3D := Invoke&(()->model.UpDirection);
+
+ procedure SetNP(fontname: string) := model.FontFamily := new FontFamily(fontname);
+ procedure SetN(fontname: string) := Invoke(SetTP, fontname);
+ function GetN: string := InvokeString(()->_fontname);
+
+ procedure SetColorP(c: GColor) := model.Foreground := new SolidColorBrush(c);
+ procedure SetColor(c: GColor) := Invoke(SetColorP, c);
+ function GetColor: GColor := Invoke&(()->(model.Foreground as SolidColorBrush).Color);
+ protected
+ function CreateObject: Object3D; override := new TextT(X, Y, Z, Text, Height, FontName, Color);
+ constructor(x, y, z: real; text: string; height: real; fontname: string; c: GColor);
+ begin
+ var a := new TextVisual3D;
+ a.Position := p3D(0, 0, 0);
+ a.Text := text;
+ a.Height := height;
+ //a.HorizontalAlignment := HorizontalAlignment.Left;
+ Self._fontname := fontname;
+ a.FontFamily := new FontFamily(fontname);
+ a.Foreground := new SolidColorBrush(c);
+ CreateBase0(a, x, y, z);
+ end;
+
+ public
+/// Текст на 3D-текстовом объекте
+ property Text: string read GetT write SetT;
+/// Высота 3D-текстового объекта
+ property Height: real read GetFS write SetFS;
+/// Имя шрифта 3D-текстового объекта
+ property FontName: string read GetN write SetN;
+/// Направление "вверх" для 3D-текстового объекта
+ property UpDirection: Vector3D read GetU write SetU;
+/// Цвет 3D-текстового объекта
+ property Color: GColor read GetColor write SetColor; override;
+/// Возвращает клон 3D-текстового объекта
+ function Clone := (inherited Clone) as TextT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс RectangleT # Graph3D RectangleT class
+// -----------------------------------------------------
+/// Класс 3D-прямоугольника
+ RectangleT = class(ObjectWithMaterial3D)
+ private
+ function model := inherited model as RectangleVisual3D;
+ procedure SetWP(r: real) := model.Width := r;
+ procedure SetW(r: real) := Invoke(SetWP, r);
+ function GetW: real := InvokeReal(()->model.Width);
+
+ procedure SetLP(r: real) := model.Length := r;
+ procedure SetL(r: real) := Invoke(SetLP, r);
+ function GetL: real := InvokeReal(()->model.Length);
+
+ procedure SetLDP(r: Vector3D) := model.LengthDirection := r;
+ procedure SetLD(r: Vector3D) := Invoke(SetLDP, r);
+ function GetLD: Vector3D := Invoke&(()->model.LengthDirection);
+
+ procedure SetNP(r: Vector3D) := model.Normal := r;
+ procedure SetN(r: Vector3D) := Invoke(SetNP, r);
+ function GetN: Vector3D := Invoke&(()->model.Normal);
+ protected
+ function CreateObject: Object3D; override := new RectangleT(X, Y, Z, Length, Width, Normal, LengthDirection, Material);
+ constructor(x, y, z, Length, Width: real; Normal, LengthDirection: Vector3D; m: GMaterial);
+ begin
+ var a := new RectangleVisual3D;
+ a.Origin := P3D(0, 0, 0);
+ a.Width := Width;
+ a.Length := Length;
+ a.LengthDirection := lengthdirection;
+ a.Normal := normal;
+ CreateBase(a, x, y, z, m);
+ end;
+
+ public
+/// Ширина 3D-прямоугольника
+ property Width: real read GetW write SetW;
+/// Длина 3D-прямоугольника
+ property Length: real read GetL write SetL;
+/// Направление длины 3D-прямоугольника
+ property LengthDirection: Vector3D read GetLD write SetLD;
+/// Нормаль к 3D-прямоугольнику
+ property Normal: Vector3D read GetN write SetN;
+/// Возвращает клон 3D-прямоугольника
+ function Clone := (inherited Clone) as RectangleT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс FileModelT # Graph3D FileModelT class
+// -----------------------------------------------------
+/// Класс 3D-модели
+ FileModelT = class(ObjectWithChildren3D)
+ private
+ fn: string;
+ procedure SetMP(mat: GMaterial) := (model as FileModelVisual3D).DefaultMaterial := mat;
+ procedure SetMaterial(mat: GMaterial) := Invoke(SetMP, mat);
+ function GetMaterial: GMaterial := Invoke&(()->(model as FileModelVisual3D).DefaultMaterial);
+ public
+ //property Color: GColor write SetColor;
+ property Material: GMaterial read GetMaterial write SetMaterial;// не работает почему-то на запись
+
+ {procedure SetVP(v: boolean) := (model as FileModelVisual3D).Visibility := v;
+ procedure SetV(v: boolean) := Invoke(SetVP, v);
+ function GetV: boolean := Invoke&(()->(model as FileModelVisual3D).Visibility);}
+ protected
+ function CreateObject: Object3D; override := new FileModelT(X, Y, Z, fn, Material.Clone);
+ constructor(x, y, z: real; fname: string; mat: GMaterial);
+ begin
+ {'.3ds': r := new studioreader(nil);
+ '.lwo': r := new lworeader(nil);
+ '.stl': r := new stlreader(nil);
+ '.obj','.objx': r := new objreader(nil);}
+
+ var a := new FileModelVisual3D;
+ a.DefaultMaterial := mat;
+ a.Source := fname;
+ CreateBase0(a, x, y, z);
+ end;
+
+ public
+/// Возвращает клон 3D-модели
+ function Clone := (inherited Clone) as FileModelT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс PipeT # Graph3D PipeT class
+// -----------------------------------------------------
+/// Класс трубы
+ PipeT = class(ObjectWithMaterial3D)
+ private
+ function model := inherited model as PipeVisual3D;
+ procedure SetDP(r: real) := model.Diameter := r * 2;
+ procedure SetD(r: real) := Invoke(SetDP, r);
+ function GetD: real := InvokeReal(()->model.Diameter / 2);
+
+ procedure SetIDP(r: real) := model.InnerDiameter := r * 2;
+ procedure SetID(r: real) := Invoke(SetIDP, r);
+ function GetID: real := InvokeReal(()->model.InnerDiameter / 2);
+
+ procedure SetHP(r: real) := model.Point2 := P3D(0, 0, r);
+ procedure SetH(r: real) := Invoke(SetHP, r);
+ function GetH: real := InvokeReal(()->model.Point2.Z);
+ protected
+ function CreateObject: Object3D; override := new PipeT(X, Y, Z, Height, Radius, InnerRadius, Material);
+ constructor(x, y, z, h, r, ir: real; m: GMaterial);
+ begin
+ var a := new PipeVisual3D;
+ a.Diameter := r * 2;
+ a.InnerDiameter := ir * 2;
+ a.Point1 := P3D(0, 0, 0);
+ a.Point2 := P3D(0, 0, h);
+ CreateBase(a, x, y, z, m);
+ end;
+
+ public
+/// Радиус трубы
+ property Radius: real read GetD write SetD;
+/// Внутренний радиус трубы
+ property InnerRadius: real read GetID write SetID;
+/// Высота трубы
+ property Height: real read GetH write SetH;
+/// Возвращает клон трубы
+ function Clone := (inherited Clone) as PipeT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс LegoT # Graph3D LegoT class
+// -----------------------------------------------------
+/// Класс лего-детали
+ LegoT = class(ObjectWithMaterial3D)
+ private
+ //function model := inherited model as LegoVisual3D;
+ procedure SetWP(r: integer);
+ procedure SetW(r: integer);
+ function GetW: integer;
+
+ procedure SetHP(r: integer);
+ procedure SetH(r: integer);
+ function GetH: integer;
+
+ procedure SetLP(r: integer);
+ procedure SetL(r: integer);
+ function GetL: integer;
+
+ {procedure SetSzP(r: Size3D);
+ begin
+ var mmm := model as LegoVisual3D;
+ (mmm.Columns,mmm.Rows,mmm.Height) := (r.X,r.Y,r.Z);
+ end;
+ procedure SetSz(r: Size3D) := Invoke(SetSzP,r);
+ function GetSz: Size3D := Invoke&(()->begin var mmm := model as LegoVisual3D; Result := Sz3D(mmm.Length,mmm.Width,mmm.Height) end);}
+ protected
+ function CreateObject: Object3D; override := new LegoT(X, Y, Z, Columns, Rows, Height, Material);
+ public
+ constructor(x, y, z: real; Rows, Columns, Height: integer; m: GMaterial);
+
+/// Количество кирпичиков лего-детали по оси X
+ property Columns: integer read GetL write SetL;
+/// Количество кирпичиков лего-детали по оси Y
+ property Rows: integer read GetW write SetW;
+/// Высота лего-детали, измеряемая в количестве деталей одинарной высоты
+ property Height: integer read GetH write SetH;
+ {property Size: Size3D read GetSz write SetSz;}
+/// Возвращает клон лего-детали
+ function Clone := (inherited Clone) as LegoT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс PlatonicAbstractT # Graph3D PlatonicAbstractT class
+// -----------------------------------------------------
+/// Абстрактный класс платоновых тел
+ PlatonicAbstractT = class(ObjectWithMaterial3D)
+ private
+ function GetLength: real;
+ procedure SetLengthP(r: real);
+ public
+/// Длина грани
+ property Length: real read GetLength write Invoke(SetLengthP, value);
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс IcosahedronT # Graph3D IcosahedronT class
+// -----------------------------------------------------
+/// Класс икосаэдра
+ IcosahedronT = class(PlatonicAbstractT)
+ protected
+ function CreateObject: Object3D; override := new IcosahedronT(X, Y, Z, Length, Material);
+ public
+ constructor(x, y, z, Length: real; m: GMaterial);
+/// Возвращает клон икосаэдра
+ function Clone := (inherited Clone) as IcosahedronT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс DodecahedronT # Graph3D DodecahedronT class
+// -----------------------------------------------------
+/// Класс додекаэдра
+ DodecahedronT = class(PlatonicAbstractT)
+ protected
+ function CreateObject: Object3D; override := new DodecahedronT(X, Y, Z, Length, Material);
+ public
+ constructor(x, y, z, Length: real; m: GMaterial);
+/// Возвращает клон додекаэдра
+ function Clone := (inherited Clone) as DodecahedronT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс TetrahedronT # Graph3D TetrahedronT class
+// -----------------------------------------------------
+/// Класс тетраэдра
+ TetrahedronT = class(PlatonicAbstractT)
+ protected
+ function CreateObject: Object3D; override := new TetrahedronT(X, Y, Z, Length, Material);
+ public
+ constructor(x, y, z, Length: real; m: GMaterial);
+/// Возвращает клон тетраэдра
+ function Clone := (inherited Clone) as TetrahedronT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс OctahedronT # Graph3D OctahedronT class
+// -----------------------------------------------------
+/// Класс октаэдра
+ OctahedronT = class(PlatonicAbstractT)
+ protected
+ function CreateObject: Object3D; override := new OctahedronT(X, Y, Z, Length, Material);
+ public
+ constructor(x, y, z, Length: real; m: GMaterial);
+/// Возвращает клон октаэдра
+ function Clone := (inherited Clone) as OctahedronT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс TriangleT # Graph3D TriangleT class
+// -----------------------------------------------------
+/// Класс 3D-треугольника
+ TriangleT = class(ObjectWithMaterial3D)
+ protected
+ procedure SetP1(p: Point3D);
+ function GetP1: Point3D;
+ procedure SetP2(p: Point3D);
+ function GetP2: Point3D;
+ procedure SetP3(p: Point3D);
+ function GetP3: Point3D;
+
+ function CreateObject: Object3D; override;
+ public
+ constructor(p1, p2, p3: Point3D; m: Gmaterial);
+
+/// Первая точка 3D-треугольника
+ property P1: Point3D read GetP1 write SetP1;
+/// Вторая точка 3D-треугольника
+ property P2: Point3D read GetP2 write SetP2;
+/// Третья точка 3D-треугольника
+ property P3: Point3D read GetP3 write SetP3;
+/// Устанавливает точки 3D-треугольника
+ procedure SetPoints(p1, p2, p3: Point3D);
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс PrismT # Graph3D PrismT class
+// -----------------------------------------------------
+/// Класс правильной призмы
+ PrismT = class(ObjectWithMaterial3D)
+ private
+ procedure SetR(r: real);
+ function GetR: real;
+ procedure SetH(r: real);
+ function GetH: real;
+ procedure SetN(n: integer);
+ function GetN: integer;
+ protected
+ function CreateObject: Object3D; override := new PrismT(X, Y, Z, N, Radius, Height, Material.Clone);
+ public
+ constructor(x, y, z: real; N: integer; r, h: real; m: Gmaterial);
+/// Радиус правильной призмы
+ property Radius: real read GetR write SetR;
+/// Высота правильной призмы
+ property Height: real read GetH write SetH;
+/// Количество углов правильной призмы
+ property N: integer read GetN write SetN;
+/// Возвращает клон правильной призмы
+ function Clone := (inherited Clone) as PrismT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс PyramidT # Graph3D PyramidT class
+// -----------------------------------------------------
+/// Класс правильной пирамиды
+ PyramidT = class(PrismT)
+ private
+ protected
+ function CreateObject: Object3D; override := new PyramidT(X, Y, Z, N, Radius, Height, Material.Clone);
+ public
+ constructor(x, y, z: real; N: integer; r, h: real; m: GMaterial);
+/// Радиус правильной пирамиды
+ property Radius: real read GetR write SetR;
+/// Высота правильной пирамиды
+ property Height: real read GetH write SetH;
+/// Количество углов правильной пирамиды
+ property N: integer read GetN write SetN;
+/// Возвращает клон правильной пирамиды
+ function Clone := (inherited Clone) as PyramidT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс PrismTWireframe # Graph3D PrismTWireframe class
+// -----------------------------------------------------
+/// Класс проволочной правильной призмы
+ PrismTWireframe = class(ObjectWithChildren3D)
+ private
+ fn: integer;
+ fh, fr: real;
+ function Model := inherited model as LinesVisual3D;
+
+ procedure SetCP(c: GColor) := (model as LinesVisual3D).Color := c;
+ procedure SetC(c: GColor) := Invoke(SetCP, c);
+ function GetC: GColor := Invoke&(()->(model as LinesVisual3D).Color);
+ procedure SetTP(th: real) := (model as LinesVisual3D).Thickness := th;
+ procedure SetT(th: real) := Invoke(SetTP, th);
+ function GetT: real := InvokeReal(()->(model as LinesVisual3D).Thickness);
+
+ procedure SetRP(value: real);
+ begin
+ if fr = value then
+ exit;
+ fr := value;
+ (model as LinesVisual3D).Points := CreatePoints;
+ end;
+
+ procedure SetR(value: real) := Invoke(SetRP, value);
+ procedure SetHP(value: real);
+ begin
+ if fh = value then
+ exit;
+ fh := value;
+ (model as LinesVisual3D).Points := CreatePoints;
+ end;
+
+ procedure SetH(value: real) := Invoke(SetHP, value);
+ procedure SetNP(value: integer);
+ begin
+ if fN = value then
+ exit;
+ fN := value;
+ (model as LinesVisual3D).Points := CreatePoints;
+ end;
+
+ procedure SetN(value: integer) := Invoke(SetNP, value);
+
+ function CreatePoints: Point3DCollection; virtual;
+ begin
+ var pc := new Point3DCollection;
+
+ var a := Partition(0, 2 * Pi, N).Select(x -> P3D(fr * cos(x), fr * sin(x), 0)).ToArray;
+ var b := Partition(0, 2 * Pi, N).Select(x -> P3D(fr * cos(x), fr * sin(x), fh)).ToArray;
+ for var i := 0 to a.High - 1 do
+ begin
+ pc.Add(a[i]);
+ pc.Add(b[i]);
+ end;
+ for var i := 0 to a.High - 1 do
+ begin
+ pc.Add(a[i]);
+ pc.Add(a[i + 1]);
+ end;
+ for var i := 0 to a.High - 1 do
+ begin
+ pc.Add(b[i]);
+ pc.Add(b[i + 1]);
+ end;
+
+ Result := pc;
+ end;
+
+ function NewVisualObject(N: integer; Radius, Height: real; Thickness: real; c: GColor): LinesVisual3D;
+ begin
+ (fn, fr, fh) := (n, Radius, Height);
+ var ls := new LinesVisual3D;
+ ls.Thickness := Thickness;
+ ls.Color := c;
+ ls.Points := CreatePoints;
+ Result := ls;
+ end;
+
+ protected
+ function CreateObject: Object3D; override := new PrismTWireframe(X, Y, Z, N, Radius, Height, (model as LinesVisual3D).Thickness, (model as LinesVisual3D).Color);
+ public
+ function Points: Point3DCollection; virtual;
+ begin
+ var a := Partition(0, 2 * Pi, N).Select(x -> P3D(fr * cos(x), fr * sin(x), 0)).SkipLast;
+ var b := Partition(0, 2 * Pi, N).Select(x -> P3D(fr * cos(x), fr * sin(x), fh)).SkipLast;
+ var pc := new Point3DCollection(a + b);
+
+ Result := pc;
+ end;
+
+ constructor(x, y, z: real; N: integer; Radius, Height: real; Thickness: real; c: GColor) :=
+ CreateBase0(NewVisualObject(N, Radius, Height, Thickness, c), x, y, z);
+
+/// Радиус проволочной правильной призмы
+ property Radius: real read fr write SetR;
+/// Высота проволочной правильной призмы
+ property Height: real read fh write SetH;
+/// Количество углов проволочной правильной призмы
+ property N: integer read fn write SetN;
+/// Цвет проволоки правильной призмы
+ property Color: GColor read GetC write SetC; override;
+/// Толщина проволоки правильной призмы
+ property Thickness: real read GetT write SetT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс PyramidTWireframe # Graph3D PyramidTWireframe class
+// -----------------------------------------------------
+/// Класс проволочной правильной пирамиды
+ PyramidTWireframe = class(PrismTWireframe)
+ protected
+ function CreateObject: Object3D; override := new PyramidTWireframe(X, Y, Z, N, Radius, Height, (model as LinesVisual3D).Thickness, (model as LinesVisual3D).Color);
+ private
+ function CreatePoints: Point3DCollection; override;
+ begin
+ var pc := new Point3DCollection;
+
+ var a := Partition(0, 2 * Pi, N).Select(x -> P3D(fr * cos(x), fr * sin(x), 0)).ToArray;
+ var b := P3D(0, 0, fh);
+ for var i := 0 to a.High - 1 do
+ begin
+ pc.Add(a[i]);
+ pc.Add(b);
+ end;
+ for var i := 0 to a.High - 1 do
+ begin
+ pc.Add(a[i]);
+ pc.Add(a[i + 1]);
+ end;
+ Result := pc;
+ end;
+ public
+/// Радиус проволочной правильной пирамиды
+ property Radius: real read fr write SetR;
+/// Высота проволочной правильной пирамиды
+ property Height: real read fh write SetH;
+/// Количество углов проволочной правильной пирамиды
+ property N: integer read fn write SetN;
+/// Цвет проволоки правильной пирамиды
+ property Color: GColor read GetC write SetC; override;
+/// Толщина проволоки правильной пирамиды
+ property Thickness: real read GetT write SetT;
+ end;
+
+ P3DArray = array of Point3D;
+ //P3DList = List;
+
+// -----------------------------------------------------
+//>> Graph3D: класс SegmentsT # Graph3D SegmentsT class
+// -----------------------------------------------------
+/// Класс Набор 3D-отрезков
+ SegmentsT = class(ObjectWithChildren3D)
+ private
+ function Model := inherited model as LinesVisual3D;
+ function GetTP: real := Model.Thickness;
+ function GetT: real := InvokeReal(GetTP);
+ procedure SetT(t: real) := Invoke(procedure(t: real)->Model.Thickness := t, t);
+ function GetCP: GColor := Model.Color;
+ function GetC: GColor := Invoke&(GetCP);
+ procedure SetC(t: GColor) := Invoke(procedure(t: GColor)->Model.Color := t, t);
+ function GetPP: array of Point3D := Model.Points.ToArray;
+ function GetP: array of Point3D; virtual := Invoke&(GetPP);
+ procedure SetPP(pp: array of Point3D) := Model.Points := new Point3DCollection(pp);
+ procedure SetP(pp: array of Point3D) := Invoke(SetPP, pp);
+ protected
+ function CreateObject: Object3D; override := new SegmentsT(Points, Thickness, Color);
+ public
+ constructor(points: sequence of Point3D; thickness: real; c: GColor);
+ begin
+ var l := new LinesVisual3D;
+ l.Thickness := thickness;
+ l.Color := c;
+ l.Points := new Point3DCollection(points);
+ CreateBase0(l, 0, 0, 0);
+ end;
+
+/// Толщина 3D-отрезков
+ property Thickness: real read GetT write SetT;
+/// Цвет 3D-отрезков
+ property Color: GColor read GetC write SetC; override;
+/// Точки 3D-отрезков
+ property Points: array of Point3D read GetP write SetP;
+/// Возвращает клон 3D-отрезков
+ function Clone := (inherited Clone) as SegmentsT;
+ end;
+
+// -----------------------------------------------------
+//>> Graph3D: класс TorusT # Graph3D TorusT class
+// -----------------------------------------------------
+/// Класс Тор (бублик)
+ TorusT = class(ObjectWithMaterial3D)
+ private
+ procedure SetD(d: real) := Invoke(procedure(d: real)->(model as TorusVisual3D).TorusDiameter := d, d);
+ function GetD: real := InvokeReal(()->(model as TorusVisual3D).TorusDiameter);
+ procedure SetTD(d: real) := Invoke(procedure(d: real)->(model as TorusVisual3D).TubeDiameter := d, d);
+ function GetTD: real := InvokeReal(()->(model as TorusVisual3D).TubeDiameter);
+ protected
+ function CreateObject: Object3D; override := new TorusT(X, Y, Z, Diameter, TubeDiameter, Material.Clone);
+ public
+ constructor(x, y, z: real; Diameter, TubeDiameter: real; m: Gmaterial);
+ begin
+ var t := new TorusVisual3D;
+ t.TorusDiameter := Diameter;
+ t.TubeDiameter := TubeDiameter;
+ CreateBase(t, x, y, z, m);
+ end;
+
+/// Диаметр тора
+ property Diameter: real read GetD write SetD;
+/// Диаметр трубы тора
+ property TubeDiameter: real read GetTD write SetTD;
+/// Возвращает клон тора
+ function Clone := (inherited Clone) as PrismT;
+ end;
+
+
+// -----------------------------------------------------
+//>> Graph3D: сервисные функции # Graph3D service functions
+// -----------------------------------------------------
+/// Возвращает материал по умолчанию
+function DefaultMaterial: Material;
+/// Возвращает пустую группу объектов в точке (x, y, z)
+function Group(x, y, z: integer): Group3D;
+/// Возвращает пустую группу объектов в точке p
+function Group(p: Point3D): Group3D;
+/// Возвращает пустую группу объектов в точке (0, 0, 0)
+function Group: Group3D;
+/// Возвращает группу объектов, перечисленных как параметры
+function Group(params lst: array of Object3D): Group3D;
+/// Возвращает группу объектов из последовательности en
+function Group(en: sequence of Object3D): Group3D;
+
+// -----------------------------------------------------
+//>> Graph3D: функции для создания 3D-объектов # Graph3D functions for creation 3D-objects
+// -----------------------------------------------------
+/// Возвращает сферу с центром в точке (x, y, z) радиуса Radius
+function Sphere(x, y, z, Radius: real; m: Material := DefaultMaterial): SphereT;
+/// Возвращает сферу с центром в точке center радиуса Radius
+function Sphere(center: Point3D; Radius: real; m: Material := DefaultMaterial): SphereT;
+/// Возвращает эллипсоид с центром в точке (x, y, z) и радиусами RadiusX, RadiusY, RadiusZ
+function Ellipsoid(x, y, z, RadiusX, RadiusY, RadiusZ: real; m: Material := DefaultMaterial): EllipsoidT;
+/// Возвращает эллипсоид с центром в точке center и радиусами RadiusX, RadiusY, RadiusZ
+function Ellipsoid(center: Point3D; RadiusX, RadiusY, RadiusZ: real; m: Material := DefaultMaterial): EllipsoidT;
+/// Возвращает эллипсоид с центром в точке (x, y, z) и длиной стороны SideLength
+function Cube(x, y, z, SideLength: real; m: Material := DefaultMaterial): CubeT;
+/// Возвращает эллипсоид с центром в точке center и длиной стороны SideLength
+function Cube(center: Point3D; SideLength: real; m: Material := DefaultMaterial): CubeT;
+/// Возвращает паралеллепипед с центром в точке (x, y, z) и размерами SizeX, SizeY, SizeZ
+function Box(x, y, z, SizeX, SizeY, SizeZ: real; m: Material := DefaultMaterial): BoxT;
+/// Возвращает паралеллепипед с центром в точке center и размерами SizeX, SizeY, SizeZ
+function Box(center: Point3D; sz: Size3D; m: Material := DefaultMaterial): BoxT;
+/// Возвращает 3D-стрелку с центром в точке (x, y, z), направлением (vx, vy, vz), диаметра Diameter и длиной наконечника HeadLength
+function Arrow(x, y, z, vx, vy, vz, Diameter, HeadLength: real; m: Material := DefaultMaterial): ArrowT;
+/// Возвращает 3D-стрелку с центром в точке (x, y, z), направлением (vx, vy, vz), диаметра Diameter
+function Arrow(x, y, z, vx, vy, vz, Diameter: real; m: Material := DefaultMaterial): ArrowT;
+/// Возвращает 3D-стрелку с центром в точке (x, y, z), направлением (vx, vy, vz)
+function Arrow(x, y, z, vx, vy, vz: real; m: Material := DefaultMaterial): ArrowT;
+/// Возвращает 3D-стрелку с центром в точке p, направлением p, диаметра Diameter и длиной наконечника HeadLength
+function Arrow(p: Point3D; v: Vector3D; Diameter, HeadLength: real; m: Material := DefaultMaterial): ArrowT;
+/// Возвращает 3D-стрелку с центром в точке p, направлением p, диаметра Diameter
+function Arrow(p: Point3D; v: Vector3D; Diameter: real; m: Material := DefaultMaterial): ArrowT;
+/// Возвращает 3D-стрелку с центром в точке p, направлением p
+function Arrow(p: Point3D; v: Vector3D; m: Material := DefaultMaterial): ArrowT;
+
+///--
+function TruncatedCone(x, y, z, Height, Radius, TopRadius: real; topcap: boolean; m: Material := DefaultMaterial): TruncatedConeT;
+/// Возвращает усеченный конус с центром основания в точке (x, y, z) высоты Height, радиуса основания Radius, верхнего радиуса TopRadius
+function TruncatedCone(x, y, z, Height, Radius, TopRadius: real; m: Material := DefaultMaterial): TruncatedConeT;
+///--
+function TruncatedCone(p: Point3D; Height, Radius, TopRadius: real; topcap: boolean; m: Material := DefaultMaterial): TruncatedConeT;
+/// Возвращает усеченный конус с центром основания в точке p высоты Height, радиуса основания Radius, верхнего радиуса TopRadius
+function TruncatedCone(p: Point3D; Height, Radius, TopRadius: real; m: Material := DefaultMaterial): TruncatedConeT;
+
+///--
+function Cylinder(x, y, z, Height, Radius: real; topcap: boolean; m: Material := DefaultMaterial): CylinderT;
+/// Возвращает цилиндр с центром основания в точке (x, y, z) высоты Height радиуса Radius
+function Cylinder(x, y, z, Height, Radius: real; m: Material := DefaultMaterial): CylinderT;
+///--
+function Cylinder(p: Point3D; Height, Radius: real; topcap: boolean; m: Material := DefaultMaterial): CylinderT;
+/// Возвращает цилиндр с центром основания в точке p высоты Height радиуса Radius
+function Cylinder(p: Point3D; Height, Radius: real; m: Material := DefaultMaterial): CylinderT;
+/// Возвращает трубу с центром основания в точке (x, y, z) высотой Height, радиусом Radius и внутренним радиусом InnerRadius
+function Tube(x, y, z, Height, Radius, InnerRadius: real; m: Material := DefaultMaterial): PipeT;
+/// Возвращает трубу с центром основания в точке p высотой Height, радиусом Radius и внутренним радиусом InnerRadius
+function Tube(p: Point3D; Height, Radius, InnerRadius: real; m: Material := DefaultMaterial): PipeT;
+/// Возвращает конус с центром основания в точке (x, y, z) высотой Height, радиусом Radius
+function Cone(x, y, z, Height, Radius: real; m: Material := DefaultMaterial): TruncatedConeT;
+/// Возвращает конус с центром основания в точке p высотой Height, радиусом Radius
+function Cone(p: Point3D; Height, Radius: real; m: Material := DefaultMaterial): TruncatedConeT;
+/// Возвращает чайник с центром в точке (x, y, z)
+function Teapot(x, y, z: real; c: Material := DefaultMaterial): TeapotT;
+/// Возвращает чайник с центром в точке p
+function Teapot(p: Point3D; c: Material := DefaultMaterial): TeapotT;
+/// Возвращает текст на билборде с центром в точке (x, y, z) с размером шрифта Fontsize
+function BillboardText(x, y, z: real; Text: string; Fontsize: real := 12): BillboardTextT;
+/// Возвращает текст на билборде с центром в точке p с размером шрифта Fontsize
+function BillboardText(p: Point3D; Text: string; Fontsize: real := 12): BillboardTextT;
+/// Возвращает координатную систему с длиной стрелок ArrowsLength и диаметром стрелок Diameter
+function CoordinateSystem(ArrowsLength, Diameter: real): CoordinateSystemT;
+/// Возвращает координатную систему с длиной стрелок ArrowsLength
+function CoordinateSystem(ArrowsLength: real): CoordinateSystemT;
+/// Возвращает 3D-текст с центром в точке (x, y, z) с высотой Height, именем шрифта FontName заданного цвета
+function Text3D(x, y, z: real; Text: string; Height: real; FontName: string := 'Arial'; c: Color := Colors.Black): TextT;
+/// Возвращает 3D-текст с центром в точке p с высотой Height, именем шрифта FontName заданного цвета
+function Text3D(p: Point3D; Text: string; Height: real; FontName: string := 'Arial'; c: Color := Colors.Black): TextT;
+/// Возвращает 3D-текст с центром в точке (x, y, z) с высотой Height заданного цвета
+function Text3D(x, y, z: real; Text: string; Height: real; c: Color): TextT;
+/// Возвращает 3D-текст с центром в точке p с высотой Height заданного цвета
+function Text3D(p: Point3D; Text: string; Height: real; c: Color): TextT;
+/// Возвращает 3D-прямоугольник с центром в точке (x, y, z) длины Length, ширины Width, нормалью Normal и направлением длины LengthDirection
+function Rectangle3D(x, y, z, Length, Width: real; Normal, LengthDirection: Vector3D; m: Material := DefaultMaterial): RectangleT;
+/// Возвращает 3D-прямоугольник с центром в точке p длины Length, ширины Width, нормалью Normal и направлением длины LengthDirection
+function Rectangle3D(p: Point3D; Length, Width: real; Normal, LengthDirection: Vector3D; m: Material := DefaultMaterial): RectangleT;
+/// Возвращает 3D-прямоугольник с центром в точке (x, y, z) длины Length, ширины Width, нормалью Normal
+function Rectangle3D(x, y, z, Length, Width: real; Normal: Vector3D; m: Material := DefaultMaterial): RectangleT;
+/// Возвращает 3D-прямоугольник с центром в точке (x, y, z) длины Length, ширины Width
+function Rectangle3D(x, y, z, Length, Width: real; m: Material := DefaultMaterial): RectangleT;
+/// Возвращает 3D-прямоугольник с центром в точке p длины Length, ширины Width, нормалью Normal
+function Rectangle3D(p: Point3D; Length, Width: real; Normal: Vector3D; m: Material := DefaultMaterial): RectangleT;
+/// Возвращает 3D-прямоугольник с центром в точке p длины Length, ширины Width
+function Rectangle3D(p: Point3D; Length, Width: real; m: Material := DefaultMaterial): RectangleT;
+
+/// Загружает модель из файла в форматах .obj, .3ds, .lwo, .objz, .stl, .off и отображает ее в точке (x, y, z)
+function FileModel3D(x, y, z: real; fname: string; m: Material): FileModelT;
+/// Загружает модель из файла в форматах .obj, .3ds, .lwo, .objz, .stl, .off и отображает ее в точке p
+function FileModel3D(p: Point3D; fname: string; m: Material): FileModelT;
+
+/// Возвращает правильную призму с центром основания в точке (x, y, z), количеством сторон Sides, высотой Height и радиусом Radius
+function Prism(x, y, z: real; Sides: integer; Height, Radius: real; m: Material := DefaultMaterial): PrismT;
+/// Возвращает правильную призму с центром основания в точке p, количеством сторон Sides, высотой Height и радиусом Radius
+function Prism(p: Point3D; Sides: integer; Height, Radius: real; m: Material := DefaultMaterial): PrismT;
+/// Возвращает проволочную правильную призму с центром основания в точке (x, y, z), количеством сторон Sides, высотой Height, радиусом Radius и толщиной проволоки Thickness
+function PrismWireFrame(x, y, z: real; Sides: integer; Height, Radius: real; Thickness: real := 1.2; c: Color := GrayColor(64)): PrismTWireFrame;
+/// Возвращает проволочную правильную призму с центром основания в точке p, количеством сторон Sides, высотой Height, радиусом Radius и толщиной проволоки Thickness
+function PrismWireFrame(p: Point3D; Sides: integer; Height, Radius: real; Thickness: real := 1.2; c: Color := GrayColor(64)): PrismTWireFrame;
+/// Возвращает правильную пирамиду с центром основания в точке (x, y, z), количеством сторон Sides, высотой Height и радиусом Radius
+function Pyramid(x, y, z: real; Sides: integer; Height, Radius: real; m: Material := DefaultMaterial): PyramidT;
+/// Возвращает правильную пирамиду с центром основания в точке p, количеством сторон Sides, высотой Height и радиусом Radius
+function Pyramid(p: Point3D; Sides: integer; Height, Radius: real; m: Material := DefaultMaterial): PyramidT;
+/// Возвращает проволочную правильную пирамиду с центром основания в точке (x, y, z), количеством сторон Sides, высотой Height и радиусом Radius
+function PyramidWireFrame(x, y, z: real; Sides: integer; Height, Radius: real; Thickness: real := 1.2; c: Color := GrayColor(64)): PyramidTWireFrame;
+/// Возвращает проволочную правильную пирамиду с центром основания в точке p, количеством сторон Sides, высотой Height и радиусом Radius
+function PyramidWireFrame(p: Point3D; Sides: integer; Height, Radius: real; Thickness: real := 1.2; c: Color := GrayColor(64)): PyramidTWireFrame;
+/// Возвращает лего-деталь с центром в точке (x, y, z), размера (Rows, Columns, Height), измеряемом в количестве кирпичиков по каждой размерности
+function Lego(x, y, z: real; Rows, Columns, Height: integer; m: Material := DefaultMaterial): LegoT;
+/// Возвращает икосаэдр с центром в точке (x, y, z) и радиусом описанной окружности Radius
+function Icosahedron(x, y, z, Radius: real; m: Material := DefaultMaterial): IcosahedronT;
+/// Возвращает додекаэдр с центром в точке (x, y, z) и радиусом описанной окружности Radius
+function Dodecahedron(x, y, z, Radius: real; m: Material := DefaultMaterial): DodecahedronT;
+/// Возвращает тетраэдр с центром в точке (x, y, z) и радиусом описанной окружности Radius
+function Tetrahedron(x, y, z, Radius: real; m: Material := DefaultMaterial): TetrahedronT;
+/// Возвращает октаэдр с центром в точке (x, y, z) и радиусом описанной окружности Radius
+function Octahedron(x, y, z, Radius: real; m: Material := DefaultMaterial): OctahedronT;
+/// Возвращает икосаэдр с центром в точке p и радиусом описанной окружности Radius
+function Icosahedron(p: Point3D; Radius: real; m: Material := DefaultMaterial): IcosahedronT;
+/// Возвращает додекаэдр с центром в точке p и радиусом описанной окружности Radius
+function Dodecahedron(p: Point3D; Radius: real; m: Material := DefaultMaterial): DodecahedronT;
+/// Возвращает тетраэдр с центром в точке p и радиусом описанной окружности Radius
+function Tetrahedron(p: Point3D; Radius: real; m: Material := DefaultMaterial): TetrahedronT;
+/// Возвращает октаэдр с центром в точке p и радиусом описанной окружности Radius
+function Octahedron(p: Point3D; Radius: real; m: Material := DefaultMaterial): OctahedronT;
+/// Возвращает набор отрезков, задаваемых последовательностью точек points, толщиной Thickness, заданного цвета. Количество точек должно быть четным
+function Segments3D(points: sequence of Point3D; Thickness: real := 1.2; c: Color := GrayColor(64)): SegmentsT;
+/// Возвращает ломаную, задаваемую последовательностью точек points, толщиной Thickness, заданного цвета
+function Polyline3D(points: sequence of Point3D; Thickness: real := 1.2; c: Color := GrayColor(64)): SegmentsT;
+/// Возвращает замкнутую ломаную, задаваемую последовательностью точек points, толщиной Thickness, заданного цвета
+function Polygon3D(points: sequence of Point3D; Thickness: real := 1.2; c: Color := GrayColor(64)): SegmentsT;
+/// Возвращает отрезок из точки p1 в точку p2 толщиной Thickness заданного цвета
+function Segment3D(p1, p2: Point3D; Thickness: real := 1.2; c: Color := GrayColor(64)): SegmentsT;
+/// Возвращает тор (бублик) с центром в точке (x, y, z), диаметром Diameter и диаметром трубы TubeDiameter
+function Torus(x, y, z, Diameter, TubeDiameter: real; m: Material := DefaultMaterial): TorusT;
+/// Возвращает тор (бублик) с центром в точке p, диаметром Diameter и диаметром трубы TubeDiameter
+function Torus(p: Point3D; Diameter, TubeDiameter: real; m: Material := DefaultMaterial): TorusT;
+/// Возвращает треугольник, соединяющий точки p1, p2, p3
+function Triangle(p1, p2, p3: Point3D; m: Material := DefaultMaterial): TriangleT;
+
+// Конец примитивов
+//------------------------------------------------------------------------------------
+
+// -----------------------------------------------------
+//>> Graph3D: функции для создания невизуальных объектов # Graph3D functions for creation non-visual objects
+// -----------------------------------------------------
+/// Возвращает невизуальную плоскость, проходящую через точку p и имеющую нормаль Normal
+function Plane(p: Point3D; Normal: Vector3D): Plane3D;
+
+/// Возвращает невизуальный луч, проходящий через точку p в направлении вектора v
+function Ray(p: Point3D; v: Vector3D): Ray3D;
+
+/// Возвращает невизуальную прямую, проходящую через точку p в направлении вектора v
+function Line(p: Point3D; v: Vector3D): Line3D;
+
+/// Возвращает невизуальную прямую, проходящую через точки p1 и p2
+function Line(p1, p2: Point3D): Line3D;
+
+/// Возвращает невизуальный луч, выпущенный из камеры и проходящий через точку (x,y) экрана
+function GetRay(x, y: real): Ray3D;
+
+/// Создает пустую анимацию заданной длительности
+function EmptyAnim(sec: real): EmptyAnimation;
+
+// -----------------------------------------------------
+//>> Graph3D: функции для определения ближайших точек и объектов # Graph3D functions for nearest points and objects
+// -----------------------------------------------------
+/// Возвращает ближайший 3D-объект, который пересекает луч, выпущенный из камеры и проходящий через точку (x,y) экрана
+function FindNearestObject(x, y: real): Object3D;
+
+/// Возвращает точку на ближайшем 3D-объекте, который пересекает луч, выпущенный из камеры и проходящий через точку (x,y) экрана. Если пересечения нет, возвращается точка BadPoint
+function FindNearestObjectPoint(x, y: real): Point3D;
+
+/// Возвращает точку на плоскости Plane, которую пересекает невизуальный луч, выпущенный из камеры и проходящий через точку (x,y) экрана
+function PointOnPlane(Plane: Plane3D; x, y: real): Point3D;
+
+/// Возвращает ближайшую точку на линии Line с лучом, выпущенным из камеры и проходящем через точку (x,y) экрана
+function NearestPointOnLine(Line: Ray3D; x, y: real): Point3D;
+
+var
+// -----------------------------------------------------
+//>> События модуля Graph3D # Graph3D events
+// -----------------------------------------------------
+ /// Событие нажатия на кнопку мыши. (x,y) - координаты курсора мыши в момент наступления события, mousebutton = 1, если нажата левая кнопка мыши, и 2, если нажата правая кнопка мыши
+ OnMouseDown: procedure(x, y: real; mousebutton: integer);
+ /// Событие отжатия кнопки мыши. (x,y) - координаты курсора мыши в момент наступления события, mousebutton = 1, если отжата левая кнопка мыши, и 2, если отжата правая кнопка мыши
+ OnMouseUp: procedure(x, y: real; mousebutton: integer);
+ /// Событие перемещения мыши. (x,y) - координаты курсора мыши в момент наступления события, mousebutton = 0, если кнопка мыши не нажата, 1, если нажата левая кнопка мыши, и 2, если нажата правая кнопка мыши
+ OnMouseMove: procedure(x, y: real; mousebutton: integer);
+ /// Событие нажатия клавиши
+ OnKeyDown: procedure(k: Key);
+ /// Событие отжатия клавиши
+ OnKeyUp: procedure(k: Key);
+
+var
+// -----------------------------------------------------
+//>> Переменные модуля Graph3D # Graph3D variables
+// -----------------------------------------------------
+/// Пространство отображения
+ View3D: View3DType;
+/// Графическое окно
+ Window: WindowType;
+/// Камера
+ Camera: CameraType;
+/// Источники света
+ Lights: LightsType;
+/// Координатная сетка
+ GridLines: GridLinesType;
+/// Список 3D-объектов
+ Object3DList := new List;
+/// Орт (единичный вектор) оси OX
+ OrtX: Vector3D := V3D(1, 0, 0);
+/// Орт (единичный вектор) оси OY
+ OrtY: Vector3D := V3D(0, 1, 0);
+/// Орт (единичный вектор) оси OZ
+ OrtZ: Vector3D := V3D(0, 0, 1);
+/// Точка начала координат
+ Origin: Point3D := P3D(0, 0, 0);
+/// Плоскость OXY
+ PlaneXY: Plane3D := Plane(Origin, OrtZ);
+/// Плоскость OYZ
+ PlaneYZ: Plane3D := Plane(Origin, OrtX);
+/// Плоскость OXZ
+ PlaneXZ: Plane3D := Plane(Origin, OrtY);
+/// Ось OX
+ XAxis: Ray3D := Ray(Origin, OrtX);
+/// Ось OY
+ YAxis: Ray3D := Ray(Origin, OrtY);
+/// Ось OZ
+ ZAxis: Ray3D := Ray(Origin, OrtZ);
+/// Плохая точка (возвращается в случае неуспеха функцией FindNearestObjectPoint)
+ BadPoint: Point3D := P3D(real.MaxValue, real.MaxValue, real.MaxValue);
+
+//{{{--doc: Конец секции 1 }}}
+
+///--
+procedure __InitModule__;
+///--
+procedure __FinalizeModule__;
+
+implementation
+
+function RGB(r, g, b: byte) := Color.Fromrgb(r, g, b);
+function ARGB(a, r, g, b: byte) := Color.FromArgb(a, r, g, b);
+function P3D(x, y, z: real) := new Point3D(x, y, z);
+function V3D(x, y, z: real) := new Vector3D(x, y, z);
+function Sz3D(x, y, z: real) := new Size3D(x, y, z);
+function Pnt(x, y: real) := new Point(x, y);
+function Rect(x, y, w, h: real) := new System.Windows.Rect(x, y, w, h);
+function RandomColor: Color := RGB(Random(256), Random(256), Random(256));
+function EmptyColor: Color := ARGB(0,0,0,0);
+function GrayColor(b: byte): Color := RGB(b, b, b);
+function RandomSolidBrush: SolidColorBrush := new SolidColorBrush(RandomColor);
+
+type
+ IMHelper = auto class
+ fname: string;
+ M, N: real;
+ function ImageMaterial: Material;
+ begin
+ //Result := MaterialHelper.CreateImageMaterial(fname)
+ var bi := new System.Windows.Media.Imaging.BitmapImage();
+ bi.BeginInit();
+ bi.UriSource := new System.Uri(fname, System.UriKind.Relative);
+ bi.EndInit();
+ var b := new ImageBrush(bi);
+ b.Viewport := Rect(0, 0, M, N);
+ if (M <> 1) or (N <> 1) then
+ b.TileMode := TileMode.Tile;
+ Result := new GDiffuseMaterial(b);
+ end;
+ end;
+ DEMHelper = auto class
+ c: Color;
+ function Diffuse := new GDiffuseMaterial(new SolidColorBrush(c));
+ function Emissive := new GEmissiveMaterial(new SolidColorBrush(c));
+ end;
+ SpMHelper = auto class
+ c: Color;
+ specularpower: real;
+ function SpecularMaterial := new System.Windows.Media.Media3D.SpecularMaterial(new SolidColorBrush(c), specularpower);
+ end;
+
+function ImageMaterial(fname: string; M,N: real): Material := Invoke&(IMHelper.Create(fname, M, N).ImageMaterial);
+function DiffuseMaterial(c: Color): Material := Invoke&(DEMHelper.Create(c).Diffuse);
+function SpecularMaterial(specularBrightness: byte; specularpower: real): Material := Invoke&(SpMHelper.Create(RGB(specularBrightness, specularBrightness, specularBrightness), specularpower).SpecularMaterial);
+function SpecularMaterial(c: Color; specularpower: real): Material := Invoke&(SpMHelper.Create(c, specularpower).SpecularMaterial);
+function EmissiveMaterial(c: Color): Material := Invoke&(DEMHelper.Create(c).Emissive);
+function RainbowMaterial: Material := GMaterials.Rainbow;
+
+//function wplus: real := SystemParameters.WindowResizeBorderThickness.Left + SystemParameters.WindowResizeBorderThickness.Right;
+
+//function hplus: real := SystemParameters.WindowCaptionHeight + SystemParameters.WindowResizeBorderThickness.Top + SystemParameters.WindowResizeBorderThickness.Bottom;
+
+function Object3D.AnimMoveTo(x, y, z, seconds: real; Completed: procedure) := new OffsetAnimation(Self, seconds, x, y, z, Completed);
+
+function Object3D.AnimMoveTrajectory(trajectory: sequence of Point3D; seconds: real; Completed: procedure) := new OffsetAnimationUsingKeyframes(Self, seconds, trajectory, Completed);
+
+function Object3D.AnimMoveOn(dx, dy, dz, seconds: real; Completed: procedure) := new OffsetAnimationOn(Self, seconds, dx, dy, dz, Completed);
+
+function Object3D.AnimScale(sc, seconds: real; Completed: procedure) := new ScaleAnimation(Self, seconds, sc, Completed);
+
+function Object3D.AnimScaleX(sc, seconds: real; Completed: procedure) := new ScaleXAnimation(Self, seconds, sc, Completed);
+
+function Object3D.AnimScaleY(sc, seconds: real; Completed: procedure) := new ScaleYAnimation(Self, seconds, sc, Completed);
+
+function Object3D.AnimScaleZ(sc, seconds: real; Completed: procedure) := new ScaleZAnimation(Self, seconds, sc, Completed);
+
+function Object3D.AnimRotate(vx, vy, vz, angle, seconds: real; Completed: procedure) := new RotateAtAnimation(Self, seconds, vx, vy, vz, angle, P3D(0, 0, 0), Completed);
+
+function Object3D.AnimRotateAt(axis: Vector3D; angle: real; center: Point3D; seconds: real; Completed: procedure) := new RotateAtAnimation(Self, seconds, axis.X, axis.y, axis.z, angle, center, Completed);
+
+procedure Object3D.AddToObject3DList := Object3DList.Add(Self);
+
+procedure Object3D.DeleteFromObject3DList;
+begin
+ var oc := Self as ObjectWithChildren3D;
+ foreach var c in oc.l do
+ c.DeleteFromObject3DList;
+ Object3DList.Remove(Self)
+end;
+
+function EmptyAnim(sec: real) := EmptyAnimation.Create(sec);
+
+function AnimationBase.&Then(second: AnimationBase): AnimationBase := Animate.Sequence(Self, second);
+
+//------------------------------ End Animation -------------------------------
+
+type
+ LegoVisual3D = class(MeshElement3D)
+ private
+ public
+ class HeightProperty: DependencyProperty;
+ class RowsProperty: DependencyProperty;
+ class ColumnsProperty: DependencyProperty;
+ class DivisionsProperty: DependencyProperty;
+ private
+ procedure SetHeight(value: integer) := SetValue(HeightProperty, value);
+ function GetHeight := integer(GetValue(HeightProperty));
+ procedure SetRows(value: integer) := SetValue(RowsProperty, value);
+ function GetRows := integer(GetValue(RowsProperty));
+ procedure SetColumns(value: integer) := SetValue(ColumnsProperty, value);
+ function GetColumns := integer(GetValue(ColumnsProperty));
+ procedure SetDivisions(value: integer) := SetValue(DivisionsProperty, value);
+ function GetDivisions := integer(GetValue(DivisionsProperty));
+
+ class constructor;
+ begin
+ HeightProperty := DependencyProperty.Register('Height', typeof(integer), typeof(LegoVisual3D), new UIPropertyMetadata(3, GeometryChanged));
+ RowsProperty := DependencyProperty.Register('Raws', typeof(integer), typeof(LegoVisual3D), new UIPropertyMetadata(3, GeometryChanged));
+ ColumnsProperty := DependencyProperty.Register('Columns', typeof(integer), typeof(LegoVisual3D), new UIPropertyMetadata(3, GeometryChanged));
+ DivisionsProperty := DependencyProperty.Register('Divisions', typeof(integer), typeof(LegoVisual3D), new UIPropertyMetadata(48));
+ end;
+
+ public
+ property Height: integer read GetHeight write SetHeight;
+ property Rows: integer read GetRows write SetRows;
+ property Columns: integer read GetColumns write SetColumns;
+ property Divisions: integer read GetDivisions write SetDivisions;
+ public
+ function Tessellate(): MeshGeometry3D; override;
+ const
+ m = 1 / 0.008;
+ grid = 0.008 * m;
+ margin = 0.0001 * m;
+ wallThickness = 0.001 * m;
+ plateThickness = 0.0032 * m;
+ brickThickness = 0.0096 * m;
+ knobHeight = 0.0018 * m;
+ knobDiameter = 0.0048 * m;
+ outerDiameter = 0.00651 * m;
+ axleDiameter = 0.00475 * m;
+ holeDiameter = 0.00485 * m;
+ begin
+ var width := Columns * grid - margin * 2;
+ var length := Rows * grid - margin * 2;
+ var height1 := Height * plateThickness;
+ var builder := new MeshBuilder(true, true);
+ for var i := 0 to Columns - 1 do
+ for var j := 0 to Rows - 1 do
+ begin
+ var o := new Point3D((i + 0.5) * grid, (j + 0.5) * grid, height1);
+ builder.AddCone(o, new Vector3D(0, 0, 1), knobDiameter / 2, knobDiameter / 2, knobHeight, false, true, Divisions);
+ builder.AddPipe(new Point3D(o.X, o.Y, o.Z - wallThickness), new Point3D(o.X, o.Y, wallThickness),
+ knobDiameter, outerDiameter, Divisions);
+ end;
+
+ builder.AddBox(new Point3D(Columns * 0.5 * grid, Rows * 0.5 * grid, height1 - wallThickness / 2), width, length,
+ wallThickness,
+ BoxFaces.All);
+ builder.AddBox(new Point3D(margin + wallThickness / 2, Rows * 0.5 * grid, height1 / 2 - wallThickness / 2),
+ wallThickness, length, height1 - wallThickness,
+ BoxFaces.All xor BoxFaces.Top);
+ builder.AddBox(
+ new Point3D(Columns * grid - margin - wallThickness / 2, Rows * 0.5 * grid, height1 / 2 - wallThickness / 2),
+ wallThickness, length, height1 - wallThickness,
+ BoxFaces.All xor BoxFaces.Top);
+ builder.AddBox(new Point3D(Columns * 0.5 * grid, margin + wallThickness / 2, height1 / 2 - wallThickness / 2),
+ width, wallThickness, height1 - wallThickness,
+ BoxFaces.All xor BoxFaces.Top);
+ builder.AddBox(
+ new Point3D(Columns * 0.5 * grid, Rows * grid - margin - wallThickness / 2, height1 / 2 - wallThickness / 2),
+ width, wallThickness, height1 - wallThickness,
+ BoxFaces.All xor BoxFaces.Top);
+ Result := builder.ToMesh(false);
+ end;
+ end;
+
+constructor LegoT.Create(x, y, z: real; Rows, Columns, Height: integer; m: GMaterial);
+begin
+ var bx := new LegoVisual3D;
+ (bx.Rows, bx.Height, bx.Columns) := (Rows, Height, Columns);
+ CreateBase(bx, x, y, z, m);
+end;
+
+procedure LegoT.SetWP(r: integer) := (model as LegoVisual3D).Rows := r;
+procedure LegoT.SetW(r: integer) := Invoke(SetWP, r);
+function LegoT.GetW: integer := InvokeInteger(()->(model as LegoVisual3D).Rows);
+
+procedure LegoT.SetHP(r: integer) := (model as LegoVisual3D).Height := r;
+procedure LegoT.SetH(r: integer) := Invoke(SetHP, r);
+function LegoT.GetH: integer := InvokeInteger(()->(model as LegoVisual3D).Height);
+
+procedure LegoT.SetLP(r: integer) := (model as LegoVisual3D).Columns := r;
+procedure LegoT.SetL(r: integer) := Invoke(SetLP, r);
+function LegoT.GetL: integer := InvokeInteger(()->(model as LegoVisual3D).Columns);
+
+type
+ Panel = class
+ Points: array of Point3D;
+ TriangleIndex: integer;
+ end;
+
+ ModelTypes = (TetrahedronType, OctahedronType, HexahedronType, IcosahedronType, DodecahedronType, StellatedOctahedronType, MyAny);
+
+ PanelModelBuilder = class
+ Panels: List := new List;
+ TriangleIndexToPanelIndex: List;
+
+ procedure AddPanel(params points: array of Point3D);
+ begin
+ var p := new Panel;
+ p.points := points;
+ Panels.Add(p);
+ end;
+
+ procedure AddPanel(params coords: array of real);
+ begin
+ var points := new Point3D[coords.Length div 3];
+ for var i := 0 to coords.Length div 3 - 1 do
+ points[i] := new Point3D(coords[i * 3], coords[i * 3 + 1], coords[i * 3 + 2]);
+ Reverse(points);
+ AddPanel(points);
+ end;
+
+ function ToMeshGeometry3D(): MeshGeometry3D;
+ begin
+ TriangleIndexToPanelIndex := new List;
+
+ var tm := new MeshBuilder(false, false);
+ var panelIndex := 0;
+ foreach var p in Panels do
+ begin
+ p.TriangleIndex := tm.Positions.Count;
+ tm.AddTriangleFan(p.Points, nil, nil);
+ for var i := 0 to p.Points.Length - 3 do
+ TriangleIndexToPanelIndex.Add(panelIndex);
+
+ panelIndex += 1;
+ end;
+ var panelsGeometry := tm.ToMesh(false);
+
+ Result := panelsGeometry;
+ end;
+ end;
+
+function CreateModel(CurrentModelType: ModelTypes; a: real): MeshGeometry3D;
+begin
+ var pmb := new PanelModelBuilder();
+ case CurrentModelType of
+ TetrahedronType:
+ begin
+ a /= Sqrt(8); // тогда длина ребра = 1
+ pmb.AddPanel(a, a, a, -a, a, -a, a, -a, -a);
+ pmb.AddPanel(-a, a, -a, -a, -a, a, a, -a, -a);
+ pmb.AddPanel(a, a, a, a, -a, -a, -a, -a, a);
+ pmb.AddPanel(a, a, a, -a, -a, a, -a, a, -a);
+ end;
+ OctahedronType:
+ begin
+ a /= 2;
+ var b := 0.5 * (2 * Sqrt(2)) * a;
+ pmb.AddPanel(-a, 0, a, -a, 0, -a, 0, b, 0);
+ pmb.AddPanel(-a, 0, -a, a, 0, -a, 0, b, 0);
+ pmb.AddPanel(a, 0, -a, a, 0, a, 0, b, 0);
+ pmb.AddPanel(a, 0, a, -a, 0, a, 0, b, 0);
+ pmb.AddPanel(a, 0, -a, -a, 0, -a, 0, -b, 0);
+ pmb.AddPanel(-a, 0, -a, -a, 0, a, 0, -b, 0);
+ pmb.AddPanel(a, 0, a, a, 0, -a, 0, -b, 0);
+ pmb.AddPanel(-a, 0, a, a, 0, a, 0, -b, 0);
+ end;
+ HexahedronType:
+ begin
+ a /= 2;
+ pmb.AddPanel(-a, -a, a, a, -a, a, a, -a, -a, -a, -a, -a);
+ pmb.AddPanel(-a, a, -a, -a, a, a, -a, -a, a, -a, -a, -a);
+ pmb.AddPanel(-a, a, a, a, a, a, a, -a, a, -a, -a, a);
+ pmb.AddPanel(a, a, -a, a, a, a, -a, a, a, -a, a, -a);
+ pmb.AddPanel(a, -a, a, a, a, a, a, a, -a, a, -a, -a);
+ pmb.AddPanel(a, -a, -a, a, a, -a, -a, a, -a, -a, -a, -a);
+ end;
+ IcosahedronType:
+ begin
+ a /= Sqrt(5) - 1;
+ var phi := (1 + Sqrt(5)) / 2;
+ var b := 1.0 / (2 * phi) * 2 * a;
+ pmb.AddPanel(0, b, -a, b, a, 0, -b, a, 0);
+ pmb.AddPanel(0, b, a, -b, a, 0, b, a, 0);
+ pmb.AddPanel(0, b, a, 0, -b, a, -a, 0, b);
+ pmb.AddPanel(0, b, a, a, 0, b, 0, -b, a);
+ pmb.AddPanel(0, b, -a, 0, -b, -a, a, 0, -b);
+ pmb.AddPanel(0, b, -a, -a, 0, -b, 0, -b, -a);
+ pmb.AddPanel(0, -b, a, b, -a, 0, -b, -a, 0);
+ pmb.AddPanel(0, -b, -a, -b, -a, 0, b, -a, 0);
+ pmb.AddPanel(-b, a, 0, -a, 0, b, -a, 0, -b);
+ pmb.AddPanel(-b, -a, 0, -a, 0, -b, -a, 0, b);
+ pmb.AddPanel(b, a, 0, a, 0, -b, a, 0, b);
+ pmb.AddPanel(b, -a, 0, a, 0, b, a, 0, -b);
+ pmb.AddPanel(0, b, a, -a, 0, b, -b, a, 0);
+ pmb.AddPanel(0, b, a, b, a, 0, a, 0, b);
+ pmb.AddPanel(0, b, -a, -b, a, 0, -a, 0, -b);
+ pmb.AddPanel(0, b, -a, a, 0, -b, b, a, 0);
+ pmb.AddPanel(0, -b, -a, -a, 0, -b, -b, -a, 0);
+ pmb.AddPanel(0, -b, -a, b, -a, 0, a, 0, -b);
+ pmb.AddPanel(0, -b, a, -b, -a, 0, -a, 0, b);
+ pmb.AddPanel(0, -b, a, a, 0, b, b, -a, 0);
+ end;
+ DodecahedronType:
+ begin
+ var phi := (1 + Sqrt(5)) / 2;
+ a /= 2 * (2 - phi);
+ var b := 1 / phi * a;
+ var c := (2 - phi) * a;
+ pmb.AddPanel(c, 0, a, -c, 0, a, -b, b, b, 0, a, c, b, b, b);
+ pmb.AddPanel(-c, 0, a, c, 0, a, b, -b, b, 0, -a, c, -b, -b, b);
+ pmb.AddPanel(c, 0, -a, -c, 0, -a, -b, -b, -b, 0, -a, -c, b, -b, -b);
+ pmb.AddPanel(-c, 0, -a, c, 0, -a, b, b, -b, 0, a, -c, -b, b, -b);
+ pmb.AddPanel(b, b, -b, a, c, 0, b, b, b, 0, a, c, 0, a, -c);
+
+ pmb.AddPanel(-b, b, b, -a, c, 0, -b, b, -b, 0, a, -c, 0, a, c);
+ pmb.AddPanel(-b, -b, -b, -a, -c, 0, -b, -b, b, 0, -a, c, 0, -a, -c);
+
+ pmb.AddPanel(b, -b, b, a, -c, 0, b, -b, -b, 0, -a, -c, 0, -a, c);
+ pmb.AddPanel(a, c, 0, a, -c, 0, b, -b, b, c, 0, a, b, b, b);
+ pmb.AddPanel(a, -c, 0, a, c, 0, b, b, -b, c, 0, -a, b, -b, -b);
+ pmb.AddPanel(-a, c, 0, -a, -c, 0, -b, -b, -b, -c, 0, -a, -b, b, -b);
+ pmb.AddPanel(-a, -c, 0, -a, c, 0, -b, b, b, -c, 0, a, -b, -b, b);
+ end;
+ StellatedOctahedronType:
+ begin
+ pmb.AddPanel(a, a, a, -a, a, -a, a, -a, -a);
+ pmb.AddPanel(-a, a, -a, -a, -a, a, a, -a, -a);
+ pmb.AddPanel(a, a, a, a, -a, -a, -a, -a, a);
+ pmb.AddPanel(a, a, a, -a, -a, a, -a, a, -a);
+ pmb.AddPanel(-a, a, a, a, a, -a, -a, -a, -a);
+ pmb.AddPanel(a, a, -a, a, -a, a, -a, -a, -a);
+ pmb.AddPanel(-a, a, a, -a, -a, -a, a, -a, a);
+ pmb.AddPanel(-a, a, a, a, -a, a, a, a, -a);
+ end;
+ MyAny:
+ begin
+ pmb.AddPanel(0, 0, 0, -a, 0, 0, -a, 0, a, 0, 0, a);
+ pmb.AddPanel(-a, 0, 0, 0, a, 0, 0, a, a, -a, 0, a);
+ pmb.AddPanel(0, a, 0, 0, 0, 0, 0, 0, a, 0, a, a);
+ pmb.AddPanel(0, 0, 0, 0, a, 0, -a, 0, 0);
+ pmb.AddPanel(0, 0, a, -a, 0, a, 0, a, a);
+ end;
+ end;
+ Result := pmb.ToMeshGeometry3D;
+end;
+
+type
+ PlatonicAbstractVisual3D = abstract class(MeshElement3D)
+ private
+ fa: real;
+ procedure SetA(value: real);begin fa := value; OnGeometryChanged; end;
+
+ public
+ constructor(Length: real);
+ begin
+ inherited Create;
+ Self.Length := Length;
+ end;
+
+ property Length: real read fa write SetA;
+ end;
+ IcosahedronVisual3D = class(PlatonicAbstractVisual3D)
+ public function Tessellate(): MeshGeometry3D; override := CreateModel(ModelTypes.IcosahedronType, Length);
+ end;
+ DodecahedronVisual3D = class(PlatonicAbstractVisual3D)
+ public function Tessellate(): MeshGeometry3D; override := CreateModel(ModelTypes.DodecahedronType, Length);
+ end;
+ TetrahedronVisual3D = class(PlatonicAbstractVisual3D)
+ public function Tessellate(): MeshGeometry3D; override := CreateModel(ModelTypes.TetrahedronType, Length);
+ end;
+ OctahedronVisual3D = class(PlatonicAbstractVisual3D)
+ public function Tessellate(): MeshGeometry3D; override := CreateModel(ModelTypes.OctahedronType, Length);
+ end;
+ MyAnyVisual3D = class(PlatonicAbstractVisual3D)
+ public function Tessellate(): MeshGeometry3D; override := CreateModel(ModelTypes.MyAny, Length);
+ end;
+
+function PlatonicAbstractT.GetLength: real := InvokeReal(()->(model as PlatonicAbstractVisual3D).Length);
+procedure PlatonicAbstractT.SetLengthP(r: real) := (model as PlatonicAbstractVisual3D).Length := r;
+
+constructor IcosahedronT.Create(x, y, z, Length: real; m: GMaterial) := CreateBase(new IcosahedronVisual3D(Length), x, y, z, m);
+
+constructor DodecahedronT.Create(x, y, z, Length: real; m: GMaterial) := CreateBase(new DodecahedronVisual3D(Length), x, y, z, m);
+
+constructor TetrahedronT.Create(x, y, z, Length: real; m: GMaterial) := CreateBase(new TetrahedronVisual3D(Length), x, y, z, m);
+
+constructor OctahedronT.Create(x, y, z, Length: real; m: GMaterial) := CreateBase(new OctahedronVisual3D(Length), x, y, z, m);
+
+
+type
+ PrismVisual3D = class(MeshElement3D)
+ private
+ fn: integer;
+ fh, fr: real;
+ procedure SetR(value: real);begin fr := value; OnGeometryChanged; end;
+
+ procedure SetH(value: real);begin fh := value; OnGeometryChanged; end;
+
+ procedure SetN(value: integer);begin fn := value; OnGeometryChanged; end;
+
+ public
+ constructor(N: integer; Radius, Height: real);
+ begin
+ (fn, fr, fh) := (n, Radius, Height);
+ OnGeometryChanged;
+ end;
+
+ property Height: real read fh write SetH;
+ property Radius: real read fr write SetR;
+ property N: integer read fn write SetN;
+ protected
+ function Tessellate(): MeshGeometry3D; override;
+ begin
+ var pmb := new PanelModelBuilder();
+ if N > 0 then
+ begin
+ var a := Partition(0, 2 * Pi, N).Select(x -> P3D(fr * cos(x), fr * sin(x), 0)).ToArray;
+ var b := Partition(0, 2 * Pi, N).Select(x -> P3D(fr * cos(x), fr * sin(x), fh)).ToArray;
+ for var i := 0 to fn - 1 do
+ pmb.AddPanel(a[i + 1].X, a[i + 1].Y, a[i + 1].Z, a[i].X, a[i].Y, a[i].Z, b[i].X, b[i].Y, b[i].Z, b[i + 1].X, b[i + 1].Y, b[i + 1].Z);
+ pmb.AddPanel(a.Reverse.ToArray);
+ pmb.AddPanel(b);
+ end;
+ Result := pmb.ToMeshGeometry3D
+ end;
+ end;
+
+ PyramidVisual3D = class(PrismVisual3D)
+ protected
+ function Tessellate(): MeshGeometry3D; override;
+ begin
+ var pmb := new PanelModelBuilder();
+ if N > 0 then
+ begin
+ var a := Partition(0, 2 * Pi, N).Select(x -> P3D(fr * cos(x), fr * sin(x), 0)).ToArray;
+ var top := P3D(0, 0, fh);
+ for var i := 0 to fn - 1 do
+ pmb.AddPanel(a[i + 1].X, a[i + 1].Y, a[i + 1].Z, a[i].X, a[i].Y, a[i].Z, top.X, top.Y, top.Z);
+ pmb.AddPanel(a.Reverse.ToArray);
+ end;
+ Result := pmb.ToMeshGeometry3D
+ end;
+ end;
+
+ TriangleVisual3D = class(MeshElement3D)
+ private
+ pp1, pp2, pp3: Point3D;
+ protected
+ function Tessellate(): MeshGeometry3D; override;
+ begin
+ var m := new MeshBuilder(true);
+ m.AddTriangle(p1, p2, p3);
+ Result := m.ToMesh;
+ end;
+
+ procedure SetP1(p1: Point3D);
+ begin
+ pp1 := p1;
+ OnGeometryChanged;
+ end;
+
+ procedure SetP2(p1: Point3D);
+ begin
+ pp2 := p2;
+ OnGeometryChanged;
+ end;
+
+ procedure SetP3(p3: Point3D);
+ begin
+ pp3 := p3;
+ OnGeometryChanged;
+ end;
+
+ public
+ constructor(ppp1, ppp2, ppp3: Point3D);
+ begin
+ (pp1, pp2, pp3) := (ppp1, ppp2, ppp3);
+ Material := Materialhelper.CreateMaterial(Colors.Red);
+ OnGeometryChanged;
+ end;
+
+ property P1: Point3D read pp1 write SetP1;
+ property P2: Point3D read pp2 write SetP2;
+ property P3: Point3D read pp3 write SetP3;
+ procedure SetPoints(p1, p2, p3: Point3D);
+ begin
+ pp1 := p1;
+ pp2 := p2;
+ pp3 := p3;
+ OnGeometryChanged;
+ end;
+ end;
+
+
+procedure TriangleT.SetP1(p: Point3D) := Invoke(procedure(p: Point3D)->(model as TriangleVisual3D).P1 := p, p);
+function TriangleT.GetP1: Point3D := Invoke&(()->(model as TriangleVisual3D).P1);
+procedure TriangleT.SetP2(p: Point3D) := Invoke(procedure(p: Point3D)->(model as TriangleVisual3D).P2 := p, p);
+function TriangleT.GetP2: Point3D := Invoke&(()->(model as TriangleVisual3D).P2);
+procedure TriangleT.SetP3(p: Point3D) := Invoke(procedure(p: Point3D)->(model as TriangleVisual3D).P3 := p, p);
+function TriangleT.GetP3: Point3D := Invoke&(()->(model as TriangleVisual3D).P3);
+procedure TriangleT.SetPoints(p1, p2, p3: Point3D) := Invoke(procedure(p1, p2, p3: Point3D)->begin (model as TriangleVisual3D).SetPoints(p1, p2, p3); end, p1, p2, p3);
+
+function TriangleT.CreateObject: Object3D := new TriangleT((model as TriangleVisual3D).p1, (model as TriangleVisual3D).p2, (model as TriangleVisual3D).p3, Material.Clone);
+
+constructor TriangleT.Create(p1, p2, p3: Point3D; m: Gmaterial);
+begin
+ CreateBase(new TriangleVisual3D(p1, p2, p3), 0, 0, 0, m);
+ (model as TriangleVisual3D).BackMaterial := (model as TriangleVisual3D).Material;
+end;
+
+procedure PrismT.SetR(r: real) := Invoke(procedure(r: real)->(model as PrismVisual3D).Radius := r, r);
+function PrismT.GetR: real := InvokeReal(()->(model as PrismVisual3D).Radius);
+procedure PrismT.SetH(r: real) := Invoke(procedure(r: real)->(model as PrismVisual3D).Height := r, r);
+function PrismT.GetH: real := InvokeReal(()->(model as PrismVisual3D).Height);
+procedure PrismT.SetN(n: integer) := Invoke(procedure(n: integer)->(model as PrismVisual3D).N := n, n);
+function PrismT.GetN: integer := InvokeInteger(()->(model as PrismVisual3D).N);
+
+constructor PrismT.Create(x, y, z: real; N: integer; r, h: real; m: Gmaterial) := CreateBase(new PrismVisual3D(N, r, h), x, y, z, m);
+
+constructor PyramidT.Create(x, y, z: real; N: integer; r, h: real; m: GMaterial) := CreateBase(new PyramidVisual3D(N, r, h), x, y, z, m);
+
+
+
+
+function DefaultMaterialColor := RandomColor;
+
+function DefaultMaterial: Material := MaterialHelper.CreateMaterial(DefaultMaterialColor);
+
+function Group(x, y, z: integer): Group3D := Inv(()->Group3D.Create(x, y, z));
+
+function Group(p: Point3D): Group3D := Inv(()->Group3D.Create(p.x, p.y, p.z));
+
+function Group: Group3D := Inv(()->Group3D.Create(0, 0, 0));
+
+function Group(params lst: array of Object3D): Group3D := Inv(()->Group3D.Create(0, 0, 0, lst));
+
+function Group(en: sequence of Object3D): Group3D := Inv(()->Group3D.Create(0, 0, 0, en));
+
+function Sphere(x, y, z, Radius: real; m: Material): SphereT := Inv(()->SphereT.Create(x, y, z, Radius, m));
+
+function Sphere(center: Point3D; Radius: real; m: Material) := Sphere(center.x, center.y, center.z, Radius, m);
+
+function Ellipsoid(x, y, z, RadiusX, RadiusY, RadiusZ: real; m: Material): EllipsoidT := Inv(()->EllipsoidT.Create(x, y, z, RadiusX, RadiusY, RadiusZ, m));
+
+function Ellipsoid(center: Point3D; RadiusX, RadiusY, RadiusZ: real; m: Material) := Ellipsoid(center.x, center.y, center.z, RadiusX, RadiusY, RadiusZ, m);
+
+function Cube(x, y, z, SideLength: real; m: Material): CubeT := Inv(()->CubeT.Create(x, y, z, SideLength, m));
+
+function Cube(center: Point3D; SideLength: real; m: Material): CubeT := Cube(center.x, center.y, center.z, SideLength, m);
+
+function Box(x, y, z, SizeX, SizeY, SizeZ: real; m: Material): BoxT := Inv(()->BoxT.Create(x, y, z, SizeX, SizeY, SizeZ, m));
+
+function Box(center: Point3D; sz: Size3D; m: Material): BoxT := Inv(()->BoxT.Create(center.x, center.y, center.z, sz.X, sz.Y, sz.z, m));
+
+const
+ arhl = 3; ard = 0.2;
+
+function Arrow(x, y, z, vx, vy, vz, diameter, HeadLength: real; m: Material): ArrowT := Inv(()->ArrowT.Create(x, y, z, vx, vy, vz, diameter, HeadLength, m));
+
+function Arrow(x, y, z, vx, vy, vz, diameter: real; m: Material) := Arrow(x, y, z, vx, vy, vz, diameter, arhl, m);
+
+function Arrow(x, y, z, vx, vy, vz: real; m: Material) := Arrow(x, y, z, vx, vy, vz, ard, arhl, m);
+
+function Arrow(p: Point3D; v: Vector3D; diameter, HeadLength: real; m: Material) := Arrow(p.x, p.y, p.z, v.X, v.Y, v.Z, diameter, HeadLength, m);
+
+function Arrow(p: Point3D; v: Vector3D; diameter: real; m: Material) := Arrow(p.x, p.y, p.z, v.X, v.Y, v.Z, diameter, arhl, m);
+
+function Arrow(p: Point3D; v: Vector3D; m: Material) := Arrow(p.x, p.y, p.z, v.X, v.Y, v.Z, ard, arhl, m);
+
+function TruncatedConeAux(x, y, z, Height, Radius, TopRadius: real; sides: integer; topcap: boolean; c: Material) := Inv(()->TruncatedConeT.Create(x, y, z, Height, Radius, TopRadius, sides, topcap, c));
+
+const
+ maxsides = 37;
+
+///--
+function TruncatedCone(x, y, z, Height, Radius, TopRadius: real; topcap: boolean; m: Material): TruncatedConeT := TruncatedConeAux(x, y, z, Height, Radius, TopRadius, maxsides, topcap, m);
+
+function TruncatedCone(x, y, z, Height, Radius, TopRadius: real; m: Material) := TruncatedCone(x, y, z, Height, Radius, TopRadius, True, m);
+///--
+function TruncatedCone(p: Point3D; Height, Radius, TopRadius: real; topcap: boolean; m: Material) := TruncatedCone(p.x, p.y, p.z, Height, Radius, TopRadius, topcap, m);
+
+function TruncatedCone(p: Point3D; Height, Radius, TopRadius: real; m: Material) := TruncatedCone(p.x, p.y, p.z, Height, Radius, TopRadius, True, m);
+
+///--
+function Cylinder(x, y, z, Height, Radius: real; topcap: boolean; m: Material): CylinderT := Inv(()->CylinderT.Create(x, y, z, Height, Radius, maxsides, topcap, m));
+
+function Cylinder(x, y, z, Height, Radius: real; m: Material) := Cylinder(x, y, z, Height, Radius, True, m);
+///--
+function Cylinder(p: Point3D; Height, Radius: real; topcap: boolean; m: Material) := Cylinder(p.x, p.y, p.z, Height, Radius, topcap, m);
+
+function Cylinder(p: Point3D; Height, Radius: real; m: Material) := Cylinder(p.x, p.y, p.z, Height, Radius, True, m);
+
+function Tube(x, y, z, Height, Radius, InnerRadius: real; m: Material): PipeT := Inv(()->PipeT.Create(x, y, z, Height, Radius, InnerRadius, m));
+
+function Tube(p: Point3D; Height, Radius, InnerRadius: real; m: Material) := Tube(p.x, p.y, p.z, Height, Radius, InnerRadius, m);
+
+function Cone(x, y, z, Height, Radius: real; m: Material): TruncatedConeT := TruncatedCone(x, y, z, Height, Radius, 0, True, m);
+
+function Cone(p: Point3D; Height, Radius: real; m: Material) := TruncatedCone(p.x, p.y, p.z, Height, Radius, 0, True, m);
+
+function Teapot(x, y, z: real; c: Material): TeapotT := Inv(()->TeapotT.Create(x, y, z, c));
+
+function Teapot(p: Point3D; c: Material) := Teapot(p.x, p.y, p.z, c);
+
+function BillboardText(x, y, z: real; Text: string; Fontsize: real): BillboardTextT := Inv(()->BillboardTextT.Create(x, y, z, text, fontsize));
+
+function BillboardText(p: Point3D; Text: string; Fontsize: real) := BillboardText(P.x, p.y, p.z, text, fontsize);
+
+function CoordinateSystem(ArrowsLength, Diameter: real): CoordinateSystemT := Inv(()->CoordinateSystemT.Create(0, 0, 0, arrowslength, diameter));
+
+function CoordinateSystem(ArrowsLength: real) := CoordinateSystem(arrowslength, arrowslength / 10);
+
+function Text3D(x, y, z: real; Text: string; Height: real; fontname: string; c: Color): TextT := Inv(()->TextT.Create(x, y, z, text, height, fontname, c));
+
+function Text3D(p: Point3D; Text: string; Height: real; fontname: string; c: Color) := Text3D(P.x, p.y, p.z, text, height, fontname, c);
+
+function Text3D(x, y, z: real; Text: string; Height: real; c: Color) := Text3D(x, y, z, text, height, 'Arial', c);
+
+function Text3D(p: Point3D; Text: string; Height: real; c: Color) := Text3D(p.x, p.y, p.z, text, height, 'Arial', c);
+
+function Rectangle3D(x, y, z, Length, Width: real; Normal, LengthDirection: Vector3D; m: Material): RectangleT := Inv(()->RectangleT.Create(x, y, z, Length, Width, normal, LengthDirection, m));
+
+function Rectangle3D(p: Point3D; Length, Width: real; Normal, LengthDirection: Vector3D; m: Material): RectangleT := Rectangle3D(p.x, p.y, p.z, Length, Width, Normal, LengthDirection, m);
+
+function Rectangle3D(x, y, z, Length, Width: real; Normal: Vector3D; m: Material): RectangleT := Rectangle3D(x, y, z, Length, Width, Normal, OrtX, m);
+
+function Rectangle3D(x, y, z, Length, Width: real; m: Material): RectangleT := Rectangle3D(x, y, z, Length, Width, OrtZ, OrtX, m);
+
+function Rectangle3D(p: Point3D; Length, Width: real; Normal: Vector3D; m: Material): RectangleT := Rectangle3D(p.x, p.y, p.z, Length, Width, Normal, OrtX, m);
+
+function Rectangle3D(p: Point3D; Length, Width: real; m: Material): RectangleT := Rectangle3D(p.x, p.y, p.z, Length, Width, OrtZ, OrtX, m);
+
+/// Загружает модель из файла .obj, .3ds, .lwo, .objz, .stl, .off
+function FileModel3D(x, y, z: real; fname: string; m: Material): FileModelT := Inv(()->FileModelT.Create(x, y, z, fname, m));
+
+function FileModel3D(p: Point3D; fname: string; m: Material): FileModelT := FileModel3D(p.x, p.y, p.z, fname, m);
+
+function Prism(x, y, z: real; Sides: integer; Height, Radius: real; m: Material): PrismT := Inv(()->PrismT.Create(x, y, z, Sides, Radius, Height, m));
+
+function Prism(p: Point3D; Sides: integer; Height, Radius: real; m: Material): PrismT := Prism(p.X, p.Y, p.Z, Sides, Radius, Height, m);
+
+function PrismWireFrame(x, y, z: real; Sides: integer; Height, Radius: real; Thickness: real; c: Color): PrismTWireFrame := Inv(()->PrismTWireFrame.Create(x, y, z, Sides, Radius, Height, thickness, c));
+
+function PrismWireFrame(p: Point3D; Sides: integer; Height, Radius: real; Thickness: real; c: Color): PrismTWireFrame := PrismWireFrame(p.x, p.y, p.z, Sides, Radius, Height, thickness, c);
+
+function Pyramid(x, y, z: real; Sides: integer; Height, Radius: real; m: Material): PyramidT := Inv(()->PyramidT.Create(x, y, z, Sides, Radius, Height, m));
+
+function Pyramid(p: Point3D; Sides: integer; Height, Radius: real; m: Material): PyramidT := Pyramid(p.X, p.Y, p.Z, Sides, Radius, Height, m);
+
+function PyramidWireFrame(x, y, z: real; Sides: integer; Height, Radius: real; Thickness: real; c: Color): PyramidTWireFrame := Inv(()->PyramidTWireFrame.Create(x, y, z, Sides, Radius, Height, thickness, c));
+
+function PyramidWireFrame(p: Point3D; Sides: integer; Height, Radius: real; Thickness: real; c: Color): PyramidTWireFrame := PyramidWireFrame(p.x, p.y, p.z, Sides, Radius, Height, thickness, c);
+
+function Lego(x, y, z: real; Rows, Columns, Height: integer; m: Material): LegoT := Inv(()->LegoT.Create(x, y, z, Rows, Columns, Height, m));
+
+function Icosahedron(x, y, z, Radius: real; m: Material): IcosahedronT := Inv(()->IcosahedronT.Create(x, y, z, 4 * Radius / Sqrt(2) / Sqrt(5 + Sqrt(5)), m));
+
+function Dodecahedron(x, y, z, Radius: real; m: Material): DodecahedronT := Inv(()->DodecahedronT.Create(x, y, z, Radius * 4 / Sqrt(3) / (1 + Sqrt(5)), m));
+
+function Tetrahedron(x, y, z, Radius: real; m: Material): TetrahedronT := Inv(()->TetrahedronT.Create(x, y, z, 4 * Radius / Sqrt(6), m));
+
+function Octahedron(x, y, z, Radius: real; m: Material): OctahedronT := Inv(()->OctahedronT.Create(x, y, z, Radius * Sqrt(2), m));
+
+function Icosahedron(p: Point3D; Radius: real; m: Material): IcosahedronT := Icosahedron(p.X, p.Y, p.Z, Radius, m);
+
+function Dodecahedron(p: Point3D; Radius: real; m: Material): DodecahedronT := Dodecahedron(p.X, p.Y, p.Z, Radius, m);
+
+function Tetrahedron(p: Point3D; Radius: real; m: Material): TetrahedronT := Tetrahedron(p.X, p.Y, p.Z, Radius, m);
+
+function Octahedron(p: Point3D; Radius: real; m: Material): OctahedronT := Octahedron(p.X, p.Y, p.Z, Radius, m);
+
+function Segments3D(points: sequence of Point3D; thickness: real; c: Color): SegmentsT := Inv(()->SegmentsT.Create(points, thickness, c));
+
+function Polyline3D(points: sequence of Point3D; thickness: real; c: Color): SegmentsT := Inv(()->SegmentsT.Create(points.Pairwise.SelectMany(x -> Seq(x[0], x[1])), thickness, c));
+
+function Polygon3D(points: sequence of Point3D; thickness: real; c: Color): SegmentsT := Inv(()->SegmentsT.Create((points + points.First).Pairwise.SelectMany(x -> Seq(x[0], x[1])), thickness, c));
+
+function Segment3D(p1, p2: Point3D; thickness: real; c: Color): SegmentsT := Inv(()->SegmentsT.Create(Seq(p1, p2), thickness, c));
+
+function Torus(x, y, z, Diameter, TubeDiameter: real; m: Material): TorusT := Inv(()->TorusT.Create(x, y, z, Diameter, TubeDiameter, m));
+
+function Torus(p: Point3D; Diameter, TubeDiameter: real; m: Material): TorusT := Torus(p.x, p.y, p.z, Diameter, TubeDiameter, m);
+
+function Triangle(p1, p2, p3: Point3D; m: Material): TriangleT := Inv(()->TriangleT.Create(p1, p2, p3, m));
+
+// Конец примитивов
+//------------------------------------------------------------------------------------
+
+// Функции для точек, лучей, прямых, плоскостей
+
+function FindNearestObject(x, y: real): Object3D;
+begin
+ Result := nil;
+ var v := hvp.FindNearestVisual(new Point(x, y));
+ foreach var obj in Object3DList do
+ if obj.model = v then
+ Result := obj
+end;
+
+function FindNearestObjectPoint(x, y: real): Point3D;
+begin
+ var p1 := hvp.FindNearestPoint(Pnt(x, y));
+ if p1.HasValue then
+ Result := p1.Value
+ else Result := BadPoint;
+end;
+
+function Plane(p: Point3D; normal: Vector3D): Plane3D := new Plane3D(p, normal);
+
+function Ray(p: Point3D; v: Vector3D): Ray3D := new Ray3D(p, v);
+
+function Line(p: Point3D; v: Vector3D): Line3D := new Line3D(p, v);
+
+function Line(p1, p2: Point3D): Line3D := new Line3D(p1, p2 - p1);
+
+function GetRay(x, y: real): Ray3D := hvp.Viewport.GetRay(Pnt(x, y));
+
+function PointOnPlane(Self: Plane3D; x, y: real): Point3D; extensionmethod;
+begin
+ var r := GetRay(x, y);
+ var p1 := r.PlaneIntersection(Self.Position, Self.Normal);
+ if p1.HasValue then
+ Result := p1.Value
+ else Result := BadPoint;
+end;
+
+function NearestPointOnLine(Self: Ray3D; x, y: real): Point3D; extensionmethod;
+begin
+ var ray := GetRay(x, y);
+ var a := Self.Direction;
+ var b := ray.Direction;
+ var ab := Vector3D.CrossProduct(a, b);
+ var planeNormal := Vector3D.CrossProduct(b, ab);
+ var p := Self.PlaneIntersection(ray.Origin, planeNormal);
+ if p.HasValue then
+ Result := p.Value
+ else Result := BadPoint;
+end;
+
+function PointOnPlane(Plane: Plane3D; x, y: real): Point3D := Plane.PointOnPlane(x,y);
+
+function NearestPointOnLine(Line: Ray3D; x, y: real): Point3D := Line.NearestPointOnLine(x,y);
+
+
+
+// Методы расширения для анимаций
+
+function Sec(Self: integer): real; extensionmethod := Self;
+
+function Sec(Self: real): real; extensionmethod := Self;
+
+// А теперь - тадам! - перегрузка + для Animate.Sequence и перегрузка * для Animate.Group
+function operator+(a, b: AnimationBase): AnimationBase; extensionmethod := Animate.Sequence(a, b);
+
+function operator*(a, b: AnimationBase): AnimationBase; extensionmethod := Animate.Group(a, b);
+
+// Конец методов расширения для анимаций
+
+// Методы расширения для точки
+
+function operator*(p: Point3D; r: real): Point3D; extensionmethod := p.Multiply(r);
+
+function operator*(r: real; p: Point3D): Point3D; extensionmethod := p.Multiply(r);
+
+function operator+(p1, p2: Point3D): Point3D; extensionmethod := p3d(p1.X + p2.X, p1.Y + p2.Y, p1.Z + p2.Z);
+
+function operator-(v: Vector3D): Vector3D; extensionmethod := v3d(-v.x,-v.y,-v.z);
+
+function MoveX(Self: Point3D; dx: real): Point3D; extensionmethod := P3D(Self.x + dx, Self.y, Self.z);
+
+function MoveY(Self: Point3D; dy: real): Point3D; extensionmethod := P3D(Self.x, Self.y + dy, Self.z);
+
+function MoveZ(Self: Point3D; dz: real): Point3D; extensionmethod := P3D(Self.x, Self.y, Self.z + dz);
+
+function Move(Self: Point3D; dx, dy, dz: real): Point3D; extensionmethod := P3D(Self.x + dx, Self.y + dy, Self.z + dz);
+
+// Конец методов расширения для точки
+
+type
+ TupleInt3 = (integer, integer, integer);
+ TupleReal3 = (real, real, real);
+
+// Разные методы расширения
+
+function ChangeOpacity(Self: GColor; value: integer): Color; extensionmethod := ARGB(value, Self.R, Self.G, Self.B);
+
+function operator implicit(t: TupleInt3): Point3D; extensionmethod := new Point3D(t[0], t[1], t[2]);
+
+function operator implicit(t: TupleReal3): Point3D; extensionmethod := new Point3D(t[0], t[1], t[2]);
+
+function operator implicit(ar: array of TupleInt3): Point3DCollection; extensionmethod := new Point3DCollection(ar.Select(t -> new Point3D(t[0], t[1], t[2])));
+
+function operator implicit(ar: array of Point3D): Point3DCollection; extensionmethod := new Point3DCollection(ar);
+
+function operator implicit(ar: List): Point3DCollection; extensionmethod := new Point3DCollection(ar);
+
+// Конец разных методов расширения
+
+type
+ GMHelper = auto class
+ a, b: Material;
+ function GroupMaterial: Material;
+ begin
+ var g := new MaterialGroup();
+ g.Children.Add(a);
+ g.Children.Add(b);
+ Result := g;
+ end;
+ end;
+
+// Методы расширения для Material
+
+function operator+(a, b: Material): Material; extensionmethod := Invoke&(GMHelper.Create(a, b).GroupMaterial);
+
+function operator implicit(c: GColor): GMaterial; extensionmethod := Materialhelper.CreateMaterial(c);
+
+// Конец методов расширения для Material
+
+
+//=============================================================================
+
+// Экспериментальные функции и классы
+type
+ MyAnyT = class(PlatonicAbstractT)
+ protected
+ function CreateObject: Object3D; override := new MyAnyT(X, Y, Z, Length, Material);
+ public
+ constructor(x, y, z, Length: real; m: GMaterial);
+ begin
+ CreateBase(new MyAnyVisual3D(Length), x, y, z, m);
+ end;
+
+ function Clone := (inherited Clone) as MyAnyT;
+ end;
+
+
+procedure ProbaP;
+begin
+ //var m := MaterialHelper.CreateMaterial(Brushes.Green,100,100);
+ //m.AmbientColor := Colors.Red;
+ //m.Color := Colors.Green;
+ //var bi := new System.Windows.Media.Imaging.BitmapImage(new System.Uri('dog.png',System.UriKind.Relative));
+ //var b := new ImageBrush(bi);
+ //b.ViewportUnits := BrushMappingMode.Absolute;
+ //b.Viewport := Rect(0,0,0.2,0.3);
+ //b.TileMode := System.Windows.Media.TileMode.Tile;
+ //Cube(6,-4,0,4,MaterialHelper.CreateMaterial(b));
+ Sphere(2, -4, 0, 2, MaterialHelper.CreateMaterial(Brushes.Green, 0.4, 100, 255));
+ Sphere(-2, -4, 0, 2, MaterialHelper.CreateMaterial(Brushes.Green, 0.6, 100, 255));
+ Sphere(-6, -4, 0, 2, MaterialHelper.CreateMaterial(Brushes.Green, 0.8, 100, 0));
+
+ Sphere(6, 0, 0, 2, MaterialHelper.CreateMaterial(Brushes.Green, 0.5, 100, 255));
+ Sphere(2, 0, 0, 2, MaterialHelper.CreateMaterial(Brushes.Green, 0.5, 70, 255));
+ Sphere(-2, 0, 0, 2, MaterialHelper.CreateMaterial(Brushes.Green, 0.5, 40, 255));
+ Sphere(-6, 0, 0, 2, MaterialHelper.CreateMaterial(Brushes.Green, 0.5, 20, 255));
+
+ Sphere(6, 4, 0, 2, MaterialHelper.CreateMaterial(Brushes.Green, Brushes.Gray, nil, 1));
+ //Sphere(2,4,0,2,MaterialHelper.CreateMaterial((Brushes.Green,new SolidColorBrush(RGB(0,64,0)),new SolidColorBrush(Rgb(128, 128, 128)), 100));
+ Sphere(-2, 4, 0, 2, MaterialHelper.CreateMaterial(Brushes.Green, 0.5, 40, 255));
+ //Cube(-6,4,0,4,Materials.Rainbow);
+ //var g := hvp.Children[1] as DefaultLights;
+end;
+
+procedure Proba := Invoke(ProbaP);
+
+procedure ProbaP2;
+begin
+ //var c := new CubeVisual3D();
+ //var c := new IcosahedronVisual3D();
+ //c.Length := 1;
+ //c.Material := Colors.Green;
+ //hvp.Children.Add(c);
+ //var ex := new HelixToolkit.Wpf.XamlExporter();
+ //ex.Export(c,new System.IO.FileStream('cube.xaml',System.IO.FileMode.Create));
+
+ //XamlWriter.Save(c,new System.IO.StreamWriter('www1.xaml'));
+ //var c1 := XamlReader.Load(new System.IO.FileStream('cube.xaml',System.IO.FileMode.Open)) as CubeVisual3D;
+ //hvp.Children.Add(c1);
+
+ {var off := new offreader(nil);
+ var s := System.IO.File.OpenRead('boxcube.off');
+ off.Load(s);
+
+ var m1 := new MeshVisual3D();
+ m1.FaceMaterial := Colors.Green;
+ m1.EdgeDiameter := 0;
+ m1.VertexRadius := 0;
+ m1.Mesh := off.CreateMesh;
+ hvp.Children.Add(m1);}
+
+ {var ex := new ExtrudedVisual3D();
+ ex.BackMaterial := Colors.Green;
+ ex.Diameters := new DoubleCollection(Arr(1.0,1.5,1.2));
+ ex.Path := new Point3DCollection(Arr(P3D(0,0,0),P3D(0,1,0),P3D(0,1,1),P3D(1,1,1)));
+ hvp.Children.Add(ex);}
+
+ var m := new SphereVisual3D();
+ m.Radius := 0.5;
+ hvp.Children.Add(m);
+
+ var t := new TranslateManipulator();
+ t.Color := Colors.Green;
+ //t.Offset := v3D(2,3,4);
+ t.Length := 2;
+ t.Diameter := 0.15;
+ t.Direction := V3D(1, 2, 0);
+ t.Value := 5;
+
+ var b := new System.Windows.Data.Binding('Transform');
+ b.Source := m;
+
+ var b1 := new System.Windows.Data.Binding('Transform');
+ b1.Source := m;
+
+ System.Windows.Data.BindingOperations.SetBinding(t, Manipulator.TargetTransformProperty, b);
+ System.Windows.Data.BindingOperations.SetBinding(t, Manipulator.TransformProperty, b);
+
+ //t.Bind(m);
+ hvp.Children.Add(t);
+
+ {var l := Lst(P3D(0,1,0),P3D(1,0,0),P3D(0,-1,0),P3D(-1,0,0),P3D(0,1,0));
+
+ var l1 := CanonicalSplineHelper.CreateSpline(l,0.5);
+ Polyline3D(l1);}
+
+end;
+
+procedure Proba2 := Invoke(ProbaP2);
+
+procedure ProbaP3(x,y,z: real);
+begin
+ hvp.CameraController.AddMoveForce(x,y,z);
+end;
+
+procedure Proba3(x,y,z: real) := Invoke(ProbaP3,x,y,z);
+
+type
+ My = class(ParametricSurface3D)
+ public
+ function Evaluate(u: real; v: real; var textureCoord: System.Windows.Point): Point3D; override;
+ begin
+ u -= 0.5;
+ v -= 0.5;
+ u *= 3;
+ v *= 3;
+ textureCoord := new Point(u, 2 * v);
+ Result := P3D(u, v, 0.2 * u * u + sin(u * v) + 2);
+ end;
+ end;
+
+ My13D = class(MeshElement3D)
+ public function Tessellate(): MeshGeometry3D; override;
+ begin
+ var tm := new MeshBuilder(false, false);
+ tm.AddRevolvedGeometry(Arr(Pnt(0, 0), Pnt(0, 1), Pnt(0.3, 1), Pnt(0.5, 0.3), Pnt(2, 1), Pnt(3, 0)), nil, Origin, OrtZ, 80);
+ Result := tm.ToMesh(false);
+ end;
+ end;
+
+type
+ AnyT = class(ObjectWithMaterial3D)
+ constructor(x, y, z: real; c: GColor);
+ begin
+ {var a := new ExtrudedVisual3D;
+ a.Path := new Point3DCollection(Arr(P3D(1,0,-0.5),P3D(1,0,0.5)));
+ a.Section := new PointCollection(Arr(Pnt(0,0),Pnt(0.5,0),Pnt(0,0.5)));
+ a.IsSectionClosed := True;}
+
+ //var a := new TerrainVisual3D;
+ //a.Content := (new SphereVisual3D()).Model;
+ //a.Text := 'PascalABC';
+ //var a := new LinesVisual3D;
+ {a.Thickness := 1.99;
+ a.Points := Arr(P3D(0, 0, 0), P3D(3, 0, 0), P3D(3, 0, 0), P3D(3, 3, 0), P3D(3, 3, 0), P3D(3, 3, 3));
+ a.Color := c;}
+
+ var a := new My13D;
+ a.Material := c;
+
+
+ {var aa := 1;
+ var b := 80;
+
+ var q := Partition(0,2*Pi*20,360*20*10).Select(t->P3D(5*cos(1*t),5*sin(1*t),t/5));
+ var q1 := q.Interleave(q.Skip(1));
+
+ //a.Points := Lst(P3D(0,0,0),P3D(4,4,2),p3D(4,4,2),p3D(2,8,-1));
+ a.Points := Lst(q1);
+ a.Color := Colors.Blue;
+
+ a.Thickness := 1.5;}
+
+ {var a := new HelixToolkit.Wpf.PieSliceVisual3D;
+ a.StartAngle := 0;
+ a.EndAngle := 360;
+ a.ThetaDiv := 60;}
+
+ {var a := new HelixToolkit.Wpf.TubeVisual3D;
+ var p := new Point3DCollection(Arr(P3D(1,2,0),P3D(2,1,0),P3D(3,1,0)));
+ a.Diameter := 0.05;
+ a.Path := p;}
+
+ {var a := new LegoVisual3D();
+ a.Rows := 1;
+ a.Columns := 2;
+ a.Height := 3;
+ //a.Divisions := 100;
+ a.Fill := Brushes.Blue;}
+
+ CreateBase0(a, x, y, z);
+ end;
+ end;
+
+function MyH(x, y, z, Length: real; c: Color): MyAnyT := Inv(()->MyAnyT.Create(x, y, z, Length, c));
+
+function MyH(x, y, z, Length: real; c: Material): MyAnyT := Inv(()->MyAnyT.Create(x, y, z, Length, c));
+
+function Any(x, y, z: real; c: Color): AnyT := Inv(()->AnyT.Create(x, y, z, c));
+
+// Сервисные функции и классы
+
+type
+ Graph3DWindow = class(GMainWindow)
+ public
+ procedure InitMainGraphControl; override;
+ begin
+ var g := Content as DockPanel;
+ hvp := new HelixViewport3D();
+ g.Children.Add(hvp);
+
+ hvp.ZoomExtentsWhenLoaded := True;
+ hvp.ShowCoordinateSystem := True;
+
+ hvp.Children.Add(new DefaultLights);
+
+ var mv := new ModelVisual3D;
+ LightsGroup := new Model3DGroup;
+ mv.Content := LightsGroup;
+ hvp.Children.Add(mv);
+
+ gvl := new GridLinesVisual3D();
+ gvl.Width := 12;
+ gvl.Length := 12;
+ gvl.Normal := OrtZ;
+ gvl.MinorDistance := 1;
+ gvl.MajorDistance := 1;
+ gvl.Thickness := 0.02;
+ hvp.Children.Add(gvl);
+ end;
+
+ procedure InitWindowProperties; override;
+ begin
+ (Width, Height) := (800, 600);
+ Title := '3D графика';
+ WindowStartupLocation := System.Windows.WindowStartupLocation.CenterScreen;
+ end;
+
+ procedure InitGlobals; override;
+ begin
+ Window := new WindowType;
+ Camera := new CameraType;
+ Lights := new LightsType;
+ GridLines := new GridLinesType;
+ View3D := new View3DType;
+
+ NameScope.SetNameScope(Self, new NameScope());
+ end;
+
+ /// --- SystemKeyEvents
+ procedure SystemOnKeyDown(sender: Object; e: System.Windows.Input.KeyEventArgs);
+ begin
+ if Graph3D.OnKeyDown <> nil then
+ Graph3D.OnKeyDown(e.Key);
+ e.Handled := True;
+ end;
+
+ procedure SystemOnKeyUp(sender: Object; e: System.Windows.Input.KeyEventArgs) :=
+ begin
+ if Graph3D.OnKeyUp <> nil then
+ Graph3D.OnKeyUp(e.Key);
+ e.Handled := True;
+ end;
+
+ /// --- SystemMouseEvents
+ procedure SystemOnMouseDown(sender: Object; e: System.Windows.Input.MouseButtonEventArgs);
+ begin
+ var mb := 0;
+ var p := e.GetPosition(hvp);
+ if e.LeftButton = MouseButtonState.Pressed then
+ mb := 1
+ else if e.RightButton = MouseButtonState.Pressed then
+ mb := 2;
+ if Graph3D.OnMouseDown <> nil then
+ Graph3D.OnMouseDown(p.x, p.y, mb);
+ end;
+
+ procedure SystemOnMouseUp(sender: Object; e: MouseButtonEventArgs);
+ begin
+ var mb := 0;
+ var p := e.GetPosition(hvp);
+ if e.LeftButton = MouseButtonState.Pressed then
+ mb := 1
+ else if e.RightButton = MouseButtonState.Pressed then
+ mb := 2;
+ if Graph3D.OnMouseUp <> nil then
+ Graph3D.OnMouseUp(p.x, p.y, mb);
+ end;
+
+ procedure SystemOnMouseMove(sender: Object; e: MouseEventArgs);
+ begin
+ var mb := 0;
+ var p := e.GetPosition(hvp);
+ if e.LeftButton = MouseButtonState.Pressed then
+ mb := 1
+ else if e.RightButton = MouseButtonState.Pressed then
+ mb := 2;
+ if Graph3D.OnMouseMove <> nil then
+ Graph3D.OnMouseMove(p.x, p.y, mb);
+ end;
+
+ procedure InitHandlers; override;
+ begin
+ hvp.PreviewMouseDown += (o, e) -> SystemOnMouseDown(o, e);
+ hvp.PreviewMouseUp += (o, e) -> SystemOnMouseUp(o, e);
+ hvp.PreviewMouseMove += (o, e) -> SystemOnMouseMove(o, e);
+
+ hvp.PreviewKeyDown += (o, e)-> SystemOnKeyDown(o, e);
+ hvp.PreviewKeyUp += (o, e)-> SystemOnKeyUp(o, e);
+
+ hvp.Focus();
+ Closed += procedure(sender, e) -> begin Halt; end;
+ end;
+ end;
+
+var
+ mre := new ManualResetEvent(false);
+
+procedure InitApp;
+begin
+ app := new Application;
+
+ app.Dispatcher.UnhandledException += (o, e) -> begin
+ Println(e.Exception.Message);
+ if e.Exception.InnerException <> nil then
+ Println(e.Exception.InnerException.Message);
+ halt;
+ end;
+
+ MainWindow := new Graph3DWindow;
+ //MainWindow.MainPanel;
+
+ mre.Set();
+
+ app.Run(MainWindow);
+end;
+
+procedure InitMainThread;
+begin
+ var MainFormThread := new System.Threading.Thread(InitApp);
+ MainFormThread.SetApartmentState(ApartmentState.STA);
+ MainFormThread.Start;
+
+ mre.WaitOne; // Основная программа не начнется пока не будут инициализированы все компоненты приложения
+end;
+
+var
+ ///--
+ __initialized := false;
+
+var
+ ///--
+ __finalized := false;
+
+procedure __InitModule;
+begin
+ InitMainThread;
+end;
+
+///--
+procedure __InitModule__;
+begin
+ if not __initialized then
+ begin
+ __initialized := true;
+ __InitModule;
+ end;
+end;
+
+///--
+procedure __FinalizeModule__;
+begin
+ if not __finalized then
+ begin
+ __finalized := true;
+ end;
+end;
+
+initialization
+ __InitModule;
+
+finalization
+end.
\ No newline at end of file
diff --git a/TestSuite/match_yield1.pas b/TestSuite/match_yield1.pas
new file mode 100644
index 000000000..e3fb2f85e
--- /dev/null
+++ b/TestSuite/match_yield1.pas
@@ -0,0 +1,12 @@
+function f1: sequence of byte;
+begin
+ match new Object with
+ integer(var i): yield i;
+ byte(var i): yield i;
+ object(var i): yield 66;
+ end;
+end;
+
+begin
+ Assert(f1.First = 66);
+end.
\ No newline at end of file
diff --git a/TestSuite/yield_autotype.pas b/TestSuite/yield_autotype.pas
new file mode 100644
index 000000000..0707cd322
--- /dev/null
+++ b/TestSuite/yield_autotype.pas
@@ -0,0 +1,10 @@
+function f1: sequence of byte;
+begin
+ var ii := 66;
+ var o := ii;
+ yield ii;
+end;
+
+begin
+ Assert(f1.First = 66);
+end.
\ No newline at end of file
diff --git a/bin/Lib/PABCSystem.pas b/bin/Lib/PABCSystem.pas
index 4533d382d..63a0a2b77 100644
--- a/bin/Lib/PABCSystem.pas
+++ b/bin/Lib/PABCSystem.pas
@@ -8690,7 +8690,7 @@ begin
yield func(x, y)
end;
-/// Разбивает последовательности на две в позиции ind
+/// Разбивает последовательность на две в позиции ind. Реализуется двухпроходным алгоритмом
function SplitAt(Self: sequence of T; ind: integer): (sequence of T, sequence of T); extensionmethod;
begin
Result := (Self.Take(ind), Self.Skip(ind));
@@ -8700,13 +8700,13 @@ end;
// ToDo: SequenceCompare
-/// Разделяет последовательности на две по заданному условию
+/// Разделяет последовательность на две по заданному условию. Реализуется двухпроходным алгоритмом
function Partition(Self: sequence of T; cond: T->boolean): (sequence of T, sequence of T); extensionmethod;
begin
Result := (Self.Where(cond), Self.Where(x -> not cond(x)));
end;
-/// Разделяет последовательности на две по заданному условию, в котором участвует индекс
+/// Разделяет последовательность на две по заданному условию, в котором участвует индекс. Реализуется двухпроходным алгоритмом
function Partition(Self: sequence of T; cond: (T,integer)->boolean): (sequence of T, sequence of T); extensionmethod;
begin
Result := (Self.Where(cond), Self.Where((x, i)-> not cond(x, i)));
@@ -8742,19 +8742,19 @@ begin
Result := Self.Zip(a, (x, y)-> (x, y)).Zip(b, (p, z)-> (p[0], p[1], z)).Zip(c, (p, z)-> (p[0], p[1], p[2], z));
end;
-/// Разъединяет последовательность двухэлементных кортежей на две последовательности
+/// Разъединяет последовательность двухэлементных кортежей на две последовательности. Реализуется двухпроходным алгоритмом
function UnZipTuple(Self: sequence of (T, T1)): (sequence of T, sequence of T1); extensionmethod;
begin
Result := (Self.Select(x -> x[0]), Self.Select(x -> x[1]))
end;
-/// Разъединяет последовательность трехэлементных кортежей на три последовательности
+/// Разъединяет последовательность трехэлементных кортежей на три последовательности. Реализуется многопроходным алгоритмом
function UnZipTuple(Self: sequence of (T, T1, T2)): (sequence of T, sequence of T1, sequence of T2); extensionmethod;
begin
Result := (Self.Select(x -> x[0]), Self.Select(x -> x[1]), Self.Select(x -> x[2]))
end;
-/// Разъединяет последовательность четырехэлементных кортежей на четыре последовательности
+/// Разъединяет последовательность четырехэлементных кортежей на четыре последовательности. Реализуется многопроходным алгоритмом
function UnZipTuple(Self: sequence of (T, T1, T2, T3)): (sequence of T, sequence of T1, sequence of T2, sequence of T3); extensionmethod;
begin
Result := (Self.Select(x -> x[0]), Self.Select(x -> x[1]), Self.Select(x -> x[2]), Self.Select(x -> x[3]))