administrator/pascalabcnet
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' of github.com:pascalabcnet/pascalabcnet

Browse source
This commit is contained in:
Бондарев Иван 2020-08-12 13:45:05 +02:00
parent 2c88c15b47 434f846ee4
commit 2e678e19a7
102 changed files with 17911 additions and 13062 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
CodeCompletion/DomSyntaxTreeVisitor.cs
View file

@ -2736,9 +2736,13 @@ namespace CodeCompletion
}
if (cur_scope != null && _program_module.program_block.program_code != null)
{
cur_scope.body_loc = new location(_program_module.program_block.program_code.left_logical_bracket.source_context.end_position.line_num,
_program_module.program_block.program_code.left_logical_bracket.source_context.end_position.column_num,
_program_module.program_block.program_code.source_context.end_position.line_num, _program_module.program_block.program_code.source_context.end_position.column_num,
var left_line_num = _program_module.program_block.program_code.left_logical_bracket.source_context.end_position.line_num;
var left_column_num = _program_module.program_block.program_code.left_logical_bracket.source_context.end_position.column_num;
var right_line_num = _program_module.program_block.program_code.source_context.end_position.line_num;
var right_column_num = _program_module.program_block.program_code.source_context.end_position.column_num;
cur_scope.body_loc = new location(left_line_num,
left_column_num,
right_line_num, right_column_num,
doc);
_program_module.program_block.program_code.visit(this);
}

2
Configuration/GlobalAssemblyInfo.cs
View file

@ -15,7 +15,7 @@ internal static class RevisionClass
public const string Major = "3";
public const string Minor = "6";
public const string Build = "3";
public const string Revision = "2595";
public const string Revision = "2617";
public const string MainVersion = Major + "." + Minor;
public const string FullVersion = Major + "." + Minor + "." + Build + "." + Revision;

2
Configuration/Version.defs
View file

@ -1,4 +1,4 @@
%MINOR%=6
%REVISION%=2595
%REVISION%=2617
%COREVERSION%=3
%MAJOR%=3

13
InstallerSamples/Algorithms/SortArrays/QuickSortFunctional.pas
View file

@ -1,13 +1,10 @@
// Быстрая сортировка Ч. Хоара
// Неэффективный алгоритм, иллюстрирующмй суть
function QS(a: array of integer): array of integer;
begin
// Неэффективный код, иллюстрирующий суть алгоритма
function QS(a: array of integer): array of integer :=
if a.Length < 2 then
Result := a
else Result := QS(a[1:].Where(y->y<=a[0]).ToArray) + |a[0]| + QS(a[1:].Where(y->y>a[0]).ToArray)
//QS(ArrGen(a[1:],y->y<=a[0]))
//QS(|y:y in a[1:] where y<=a[0]|)
end;
a
else
QS(a[1:].FindAll(y->y<=a[0])) + a[:1] + QS(a[1:].FindAll(y->y>a[0]));
begin
var a := ArrRandom(20);

4
InstallerSamples/Algorithms/Sqrt2.pas Normal file
View file

@ -0,0 +1,4 @@
##
var x := 2.0;
SeqGen(6,x,a → (a + x/a) / 2).Last.Println;
x.Sqrt.Print;

27
InstallerSamples/Graphics/Controls/cc10_ComboBox.pas Normal file
View file

@ -0,0 +1,27 @@
// Модуль Controls - элемент управления "Список" и использование словаря
uses Controls,GraphWPF;
begin
Window.Title := 'Столицы стран';
LeftPanel(150,Colors.Orange);
var l := ComboBox('Список стран');
l.Tooltip := 'Выбери страну - отобразится столица';
l.Add('Россия');
l.Add('США');
l.Add('Китай');
l.Add('Германия');
l.Add('Франция');
var d := Dict(('Россия','Москва'),
('США','Вашингтон'),
('Китай','Пекин'),
('Германия','Берлин'),
('Франция','Париж')
);
Font.Size := 70;
l.SelectionChanged := procedure -> begin
Window.Clear;
DrawText(GraphWindow.ClientRect,d[l.SelectedText]);
end;
end.

22
InstallerSamples/Graphics/Controls/cc11_ComboBox2.pas Normal file
View file

@ -0,0 +1,22 @@
// Модуль Controls - элемент управления "ComboBox" и графики функций
uses GraphWPF,Controls;
begin
Window.Title := 'Модуль Controls - элемент управления "ComboBox" и графики функций';
LeftPanel(150, Colors.Orange);
var cb := ComboBox('Графики функций');
cb.AddRange('x*sin(x)','exp(x)','x*x','sin(x)-cos(2.5*x)');
var Redraw: procedure := () -> begin
case cb.SelectedIndex of
0: DrawGraph(x->x*sin(x));
1: DrawGraph(x->exp(x));
2: DrawGraph(x->x*x);
3: DrawGraph(x->sin(x)-cos(2.5*x));
end;
end;
cb.SelectionChanged := Redraw;
OnResize := Redraw;
Redraw;
end.

18
InstallerSamples/Graphics/Controls/cc12_Wrapping.pas Normal file
View file

@ -0,0 +1,18 @@
// Модуль Controls - режим Wrapping для TextBlock
uses GraphWPF,Controls;
function R := Random(-7,7);
begin
Window.Title := 'Модуль Controls - режим Wrapping для TextBlock';
LeftPanel(150,Colors.Orange);
var b := Button('No Wrap');
b.Tooltip := 'Нажмите для изменения режима переноса слов';
var tb1 := TextBlock('Этот текст не помещается на одной строке и в режиме Wrapping автоматически переносится');
b.Click := procedure → begin
tb1.Wrapping := not tb1.Wrapping;
b.Text := if tb1.Wrapping then 'Wrap' else 'No Wrap';
end;
var tb := TextBlock('Этот текст усекается,'#10'но можно явно'#10'разделять на строки');
end.

32
InstallerSamples/Graphics/Controls/cc13_Заголовки.pas Normal file
View file

@ -0,0 +1,32 @@
// Модуль Controls - элементы управления с заголовками
uses Controls, GraphWPF;
begin
Window.Title := 'Модуль Controls - все элементы управления с заголовками';
LeftPanel(170, Colors.Orange);
var b := Button('Заголовки включены');
var tb := new TextBoxWPF('TextBox');
tb.Height := 40;
tb.Text := 'Несколько строк текста';
tb.Wrapping := True;
var ib := new IntegerBoxWPF('IntegerBox', 0, 10);
var lb := new ListBoxWPF('ListBox',100);
lb.AddRange('1 2 3 4 5'.ToWords);
var cb := new ComboBoxWPF('ComboBox');
cb.AddRange('1 2 3 4 5'.ToWords);
var sl := new SliderWPF('Slider:');
b.Click := procedure -> begin
if b.Text = 'Заголовки включены' then
b.Text := 'Заголовки выключены'
else b.Text := 'Заголовки включены';
tb.TitleVisible := not tb.TitleVisible;
ib.TitleVisible := not ib.TitleVisible;
lb.TitleVisible := not lb.TitleVisible;
cb.TitleVisible := not cb.TitleVisible;
sl.TitleVisible := not sl.TitleVisible;
end;
end.

17
InstallerSamples/Graphics/Controls/cc14_Canvas.pas Normal file
View file

@ -0,0 +1,17 @@
// Модуль Controls - замена графической панели на элемент управления "Канва"
uses Controls,GraphWPF;
begin
Window.Title := 'Модуль Controls - замена графической панели на элемент управления "Канва"';
var left := LeftPanel(150,Colors.Orange);
var can := SetMainControl.AsCanvas;
can.Color := Colors.AntiqueWhite;
Button(100,100,'На Канве можно располагать элементы');
Button(50,300,'в любом месте,');
TextBlock(150,500,'указывая их координаты');
// Смена активной панели
SetActivePanel(left);
Button('Закрыть').Click := procedure → Window.Close;
end.

23
InstallerSamples/Graphics/Controls/cc15_ListView.pas Normal file
View file

@ -0,0 +1,23 @@
// Модуль Controls - замена графического окна элементом "ListView"
uses Controls,GraphWPF;
type My = class
public
auto property Поле1: integer;
auto property Поле2: integer;
constructor (п1,п2: integer) := (Поле1,Поле2) := (п1,п2);
end;
begin
Window.Title := 'Модуль Controls - замена графического окна элементом "ListView"';
LeftPanel(150,Colors.Orange);
var l := SetMainControl.AsListView;
// Заполнение объектами класса, у которых есть публичные свойства
l.Fill(Arr(new My(2,5),new My(4,6)));
Button('Очистить список').Click := procedure -> l.Clear;
Button('Заполнить данными').Click := procedure -> l.Fill(|('Иванов',20),('Петров',19)|);
Button('Заполнить заголовки').Click := procedure -> l.SetHeaders('Фамилия','Возраст');
end.

19
InstallerSamples/Graphics/Controls/cc16_Countries.pas Normal file
View file

@ -0,0 +1,19 @@
// Модуль Controls - визуализация запросов к базе данных
uses GraphWPF,Controls,ABCDatabases;
begin
Window.Title := 'Модуль Controls - визуализация запросов к базе данных';
LeftPanel(150,Colors.Orange);
var l := SetMainControl.AsListView;
var страны := ЗаполнитьМассивСтран;
l.Fill(страны);
Button('Все').Click := procedure -> l.Fill(страны);
Button('Азия').Click := procedure ->
l.Fill(страны.Where(страна -> страна.Континент='Азия'));
Button('Сорт по населению').Click := procedure ->
l.Fill(страны.OrderByDescending(s -> s.Население));
end.

20
InstallerSamples/Graphics/Controls/cc16a_CountyCapital.pas Normal file
View file

@ -0,0 +1,20 @@
uses GraphWPF, Controls, ABCDatabases;
begin
Window.Title := 'Столицы стран';
LeftPanel(220, Colors.LightGoldenrodYellow);
var страны := ЗаполнитьМассивСтран;
var a := ListBox('Страны',550);
a.AddRange(страны.ConvertAll(страна -> страна.Название));
var d := DictStr;
foreach var страна in страны do
d[страна.Название] := страна.Столица;
Font.Size := 70;
a.SelectionChanged := procedure -> begin
Window.Clear;
DrawText(GraphWindow.ClientRect,d[a.SelectedText])
end;
end.

14
InstallerSamples/Graphics/Controls/cc17_CalcIdea.pas Normal file
View file

@ -0,0 +1,14 @@
// Модуль Controls - Калькулятор Light
uses Controls,GraphWPF;
begin
Window.Title := 'Калькулятор Light';
LeftPanel(150, Colors.Orange);
var tb := SetMainControl.AsTextBox;
tb.FontSize := 30;
var x := IntegerBox('X:',1,9);
var y := IntegerBox('Y:',1,9);
Button('Sum').Click := procedure -> begin
tb.Println($'{x.Value} + {y.Value} = {x.Value + y.Value}');
end;
end.

44
InstallerSamples/Graphics/Controls/cc18_SimpleCalc.pas Normal file
View file

@ -0,0 +1,44 @@
// Модуль Controls - Калькулятор
uses Controls,GraphWPF;
begin
Window.Title := 'Калькулятор с выводом в TextBox';
LeftPanel(150, Colors.Orange);
var tb := SetMainControl.AsTextBox;
tb.FontSize := 30;
var x := IntegerBox('X:');
var y := IntegerBox('Y:');
x.Value := Random(0,10);
y.Value := Random(0,10);
var cb := new ComboBoxWPF('Операция');
cb.AddRange('+','-','*','/');
var count := 0;
var sb := StatusBar;
sb.Text := 'Количество вычислений: ' + count;
var b := Button('+');
b.Click := procedure -> begin
case cb.SelectedText of
'+': tb.Println($'{x.Value} + {y.Value} = {x.Value + y.Value}');
'-': tb.Println($'{x.Value} - {y.Value} = {x.Value - y.Value}');
'*': tb.Println($'{x.Value} * {y.Value} = {x.Value * y.Value}');
'/': tb.Println($'{x.Value} / {y.Value} = {x.Value / y.Value}');
end;
x.Value := Random(0,10);
y.Value := Random(0,10);
count += 1;
sb.Text := 'Количество вычислений: ' + count;
end;
Button('Очистить').Click := () -> begin
count := 0;
sb.Text := 'Количество вычислений: ' + count;
tb.Clear;
end;
cb.SelectionChanged := procedure -> begin
b.Text := cb.SelectedText
end;
end.

17
InstallerSamples/Graphics/Controls/cc19_StatusBar.pas Normal file
View file

@ -0,0 +1,17 @@
// Модуль Controls - StatusBar
uses Controls,GraphWPF;
begin
Window.Title := 'Модуль Controls - StatusBar';
var l := LeftPanel(150,Colors.Orange);
l.Tooltip := 'Измените размеры окна';
var sb := StatusBar(24,55);
sb.AddText('',55);
Button('Очистить поле W').Click := procedure -> sb.ItemText[0] := '';
Button('Очистить поле H').Click := procedure -> sb.ItemText[1] := '';
OnResize := () -> begin
sb.ItemText[0] := 'W=' + Window.Width.Round;
sb.ItemText[1] := 'H=' + Window.Height.Round;
end;
OnResize();
end.

33
InstallerSamples/Graphics/Controls/cc1_All.pas Normal file
View file

@ -0,0 +1,33 @@
// Модуль Controls - все элементы управления
uses GraphWPF,Controls;
begin
Window.Title := 'Модуль Controls - все элементы управления';
// Обычно элементы управления размещаются на панели - левой или правой
LeftPanel(160,Colors.Orange);
Button('Кнопка');
CheckBox('Флажок');
RadioButton('Переключатель 1');
RadioButton('Переключатель 2');
TextBox('Поле ввода текста');
var ib := IntegerBox('Поле ввода целого',0,10);
ib.Tooltip := 'Покрутите колёсико мыши для изменения значения';
var l := ListBox('Список стран');
l.Height := 110;
l.Add('Россия');
l.Add('США');
l.Add('Китай');
l.Add('Германия');
l.Add('Франция');
var cb := ComboBox('Выпадающий список');
cb.AddRange('Россия','США','Китай','Германия','Франция');
Slider('Слайдер:',0,10);
TextBlock('Блок текста');
IntegerBlock('Блок целого:',64);
RealBlock('Блок вещественного:',3.5);
var s := StatusBar;
s.Text := 'Строка статуса';
end.

17
InstallerSamples/Graphics/Controls/cc20_Menu.pas Normal file
View file

@ -0,0 +1,17 @@
// Модуль Controls - меню
uses Controls,GraphWPF;
begin
LeftPanel(150, Colors.Orange);
var m := new MenuWPF;
var mi1 := m.Add('File');
mi1.Add('New');
mi1.Add('Open');
mi1.Add('Save');
mi1.AddSeparator;
mi1.Add('Exit').Click := procedure->Window.Close;
//mi1.Add('Exit',procedure->Window.Close);
m.Add('Edit');
m.Add('Options');
var mi := m.Add('Help');
end.

10
InstallerSamples/Graphics/Controls/cc20_Menu2.pas Normal file
View file

@ -0,0 +1,10 @@
// Модуль Controls - меню 2
uses Controls,GraphWPF;
begin
LeftPanel(150, Colors.Orange);
var m := new MenuWPF;
m.AddRange('File','Edit','Options','Help');
m[0].AddRange('New','Open','Save','-','Exit');
m[0][3].Click := procedure->Window.Close;
end.

39
InstallerSamples/Graphics/Controls/cc21_FileDialogs.pas Normal file
View file

@ -0,0 +1,39 @@
// Модуль Controls - OpenFileDialog и SaveFileDialog
uses Controls,GraphWPF;
begin
Window.Title := 'Модуль Controls - OpenFileDialog и SaveFileDialog';
LeftPanel(150, Colors.Orange);
var tb := SetMainControl.AsTextBox;
tb.FontSize := 16;
tb.ReadOnly := False;
tb.FontName := 'Courier new Cyr';
var dopen := new OpenFileDialogWPF('c:\PABCWork.NET','Программы|*.pas');
var dSave := new SaveFileDialogWPF('c:\PABCWork.NET','Программы|*.pas');
var OpenHandler: procedure := procedure -> begin
var res := dopen.ShowDialog;
if res then
tb.Text := ReadAllText(dopen.FileName);
end;
var SaveHandler: procedure := procedure -> begin
var res := dSave.ShowDialog;
if res then
WriteAllText(dSave.FileName,tb.Text);
end;
var bOpen := Button('Open');
bOpen.Click := OpenHandler;
var bSave := Button('Save');
bSave.Click := SaveHandler;
var m := Menu;
var m1 := m.Add('File');
var mm1 := m1.Add('Open');
mm1.Click := OpenHandler;
m1.Add('Save',SaveHandler);
m1.AddSeparator;
m1.Add('Exit',procedure->Window.Close);
end.

19
InstallerSamples/Graphics/Controls/cc22_MsgBox.pas Normal file
View file

@ -0,0 +1,19 @@
// Модуль Controls - MessageBox
uses GraphWPF,Controls;
begin
Window.Title := 'Модуль Controls - MessageBox';
LeftPanel(150, Colors.Orange);
Button('MsgBoxOK').Click := () -> MessageBox.Show('Сообщение','Заголовок');
Button('MsgBoxYesNo').Click := () -> begin
if MessageBox.Show('Сообщение','Заголовок',MessageBoxButton.YesNo) = MessageBoxResult.Yes then
Print('Yes')
else Print('No');
end;
Button('MsgBoxWithQuestion').Click := () -> begin
if MessageBox.Show('Вы уверены?','Заголовок',MessageBoxButton.YesNo,MessageBoxImage.Question)
= MessageBoxResult.Yes then
Print('Уверен')
else Print('Нет');
end;
end.

13
InstallerSamples/Graphics/Controls/cc23_Random3DSpheres.pas Normal file
View file

@ -0,0 +1,13 @@
// Случайные шары
uses Graph3D,Controls;
function R := Random(-7,7);
begin
Window.Title := 'Случайные шары';
LeftPanel(150,Colors.Orange);
var b := new ButtonWPF('Создать шар');
b.Click := () → begin
Sphere(P3D(R,R,R),1);
end;
end.

24
InstallerSamples/Graphics/Controls/cc24_RGB.pas Normal file
View file

@ -0,0 +1,24 @@
// Смешение цветов RGB
uses GraphWPF,Controls;
begin
Window.Title := 'Цвета';
Font.Size := 40;
LeftPanel(150);
var r := Slider('Красный: ',0,255,255,16);
var g := Slider('Зеленый: ',0,255,255,16);
var b := Slider('Синий: ',0,255,255,16);
Button('Выход').Click := procedure → Window.Close;
var p: procedure := () → begin
var c := RGB(r.Value,g.Value,b.Value);
Window.Clear(c);
DrawText(GraphWindow.ClientRect,$'R={c.R}, G={c.G}, B={c.B}');
end;
r.ValueChanged := p;
g.ValueChanged := p;
b.ValueChanged := p;
p;
end.

28
InstallerSamples/Graphics/Controls/cc25_Gr3DProperties.pas Normal file
View file

@ -0,0 +1,28 @@
// Модуль Controls
uses Graph3D, Controls;
begin
var l := LeftPanel(200, Colors.LightGoldenrodYellow);
var height := IntegerBox('Высота:', 1, 15);
height.Value := 5;
height.Tooltip := 'Покрутите колёсико мыши';
var radius := IntegerBox('Радиус:', 1, 6);
radius.Value := 2;
radius.Tooltip := 'Покрутите колёсико мыши';
var sides := Slider('Количество сторон: ', 3, 20);
sides.Frequency := 1;
sides.Value := 5;
var p := Pyramid(Origin, sides.Value, height.Value, radius.Value, Colors.Green);
height.ValueChanged := procedure -> begin
p.Height := height.Value;
end;
radius.ValueChanged := procedure -> begin
p.Radius := radius.Value;
end;
sides.ValueChanged := procedure -> begin
p.Sides := sides.Value;
end;
end.

57
InstallerSamples/Graphics/Controls/cc2_All2.pas Normal file
View file

@ -0,0 +1,57 @@
// Модуль Controls - элементы управления на основной панели
uses GraphWPF,Controls;
begin
Window.Title := 'Модуль Controls - элементы управления на основной панели';
var x := 10;
var w := 140;
Button(x,10,'Кнопка',w);
CheckBox(x,43,'Флажок');
RadioButton(x,70,'Переключатель 1');
RadioButton(x,97,'Переключатель 2');
TextBox(x,120,'Поле ввода текста',w);
var ib0 := IntegerBox(x,172,'Поле ввода целого',0,10,w);
ib0.Tooltip := 'Покрутите колёсико мыши для изменения значения';
var l0 := ListBox(x,221,'Список стран',w);
l0.Height := 110;
l0.Add('Россия');
l0.Add('США');
l0.Add('Китай');
l0.Add('Германия');
l0.Add('Франция');
var cb0 := ComboBox(x,362,'Выпадающий список',w);
cb0.AddRange('Россия','США','Китай','Германия','Франция');
Slider(x,414,'Слайдер:',0,10,w);
TextBlock(x,469,'Блок текста',w);
IntegerBlock(x,497,'Блок целого:',w,64);
RealBlock(x,526,'Блок вещественного:',w,3.5);
LeftPanel(160,Colors.Orange);
Button('Кнопка');
CheckBox('Флажок');
RadioButton('Переключатель 1');
RadioButton('Переключатель 2');
TextBox('Поле ввода текста');
var ib := IntegerBox('Поле ввода целого',0,10);
ib.Tooltip := 'Покрутите колёсико мыши для изменения значения';
var l := ListBox('Список стран');
l.Height := 110;
l.Add('Россия');
l.Add('США');
l.Add('Китай');
l.Add('Германия');
l.Add('Франция');
var cb := ComboBox('Выпадающий список');
cb.AddRange('Россия','США','Китай','Германия','Франция');
Slider('Слайдер:',0,10);
TextBlock('Блок текста');
IntegerBlock('Блок целого:',64);
RealBlock('Блок вещественного:',3.5);
var s := StatusBar;
s.Text := 'Строка статуса';
end.

33
InstallerSamples/Graphics/Controls/cc3_All3.pas Normal file
View file

@ -0,0 +1,33 @@
// Модуль Controls - создание элементов вызовом конструктора
uses GraphWPF,Controls;
begin
Window.Title := 'Модуль Controls - создание элементов вызовом конструктора + правая панель';
// Размещение элементов на правой ранели
new RightPanelWPF(160,Colors.Orange);
new ButtonWPF('Кнопка');
new CheckBoxWPF('Флажок');
new RadioButtonWPF('Переключатель 1');
new RadioButtonWPF('Переключатель 2');
new TextBoxWPF('Поле ввода текста');
var ib := new IntegerBoxWPF('Поле ввода целого',0,10);
ib.Tooltip := 'Покрутите колёсико мыши для изменения значения';
var l := new ListBoxWPF('Список стран');
l.Height := 110;
l.Add('Россия');
l.Add('США');
l.Add('Китай');
l.Add('Германия');
l.Add('Франция');
var cb := new ComboBoxWPF('Выпадающий список');
cb.AddRange('Россия','США','Китай','Германия','Франция');
new SliderWPF('Слайдер:',0,10);
new TextBlockWPF('Блок текста');
new IntegerBlockWPF('Блок целого:',64);
new RealBlockWPF('Блок вещественного:',3.5);
var s := new StatusBarWPF;
s.Text := 'Строка статуса';
end.

19
InstallerSamples/Graphics/Controls/cc4_ButtonClick.pas Normal file
View file

@ -0,0 +1,19 @@
// Модуль Controls - кнопки и их обработчики
uses GraphWPF,Controls;
begin
Window.Title := 'Модуль Controls - кнопки и их обработчики';
var p := LeftPanel;
p.Color := Colors.Orange;
Button('Случайный цвет').Click := () -> begin
Window.Clear(RandomColor);
end;
var b2 := Button('Плюс');
b2.Click := procedure ->
if b2.Text = 'Плюс' then b2.Text := 'Минус' else b2.Text := 'Плюс';
var b1 := Button('Закрыть окно');
b1.Click := procedure -> Window.Close;
end.

20
InstallerSamples/Graphics/Controls/cc5_CheckBoxes.pas Normal file
View file

@ -0,0 +1,20 @@
// Модуль Controls - флажки
uses GraphWPF,Controls;
begin
Window.Title := 'Модуль Controls - флажки';
var p := LeftPanel(170,Colors.Orange);
var b1 := Button('Переключить флажок 1');
var b2 := Button('Переключить флажок 2');
var b3 := Button('Переключить флажок 3');
var cb1 := new CheckBoxWPF('Флажок 1');
var cb2 := new CheckBoxWPF('Флажок 2');
var cb3 := new CheckBoxWPF('Флажок 3');
b1.Click := procedure -> cb1.Checked := not cb1.Checked;
b2.Click := procedure -> cb2.Checked := not cb2.Checked;
b3.Click := procedure -> cb3.Checked := not cb3.Checked;
end.

33
InstallerSamples/Graphics/Controls/cc6_CheckBoxes2.pas Normal file
View file

@ -0,0 +1,33 @@
// Модуль Controls - флажки
uses WPFObjects,Controls;
begin
Window.Title := 'Модуль Controls - флажки';
LeftPanel(170);
var tb := TextBlock('Параметры круга:');
tb.Margin := 12;
var cb1 := new CheckBoxWPF('Заливка');
var cb2 := new CheckBoxWPF('Жирная граница');
var cb3 := new CheckBoxWPF('С текстом');
var c := new CircleWPF(GraphWindow.Center,60,Colors.White,1);
cb1.Click := procedure -> begin
if cb1.Checked then
c.Color := Colors.Green
else c.Color := Colors.White
end;
cb2.Click := procedure -> begin
if cb2.Checked then
c.BorderWidth := 4
else c.BorderWidth := 1
end;
cb3.Click := procedure -> begin
if cb3.Checked then
c.Text := 'Текст'
else c.Text := ''
end;
end.

26
InstallerSamples/Graphics/Controls/cc7_RadioButtons.pas Normal file
View file

@ -0,0 +1,26 @@
// Модуль Controls - переключатели
uses WPFObjects,Controls;
begin
Window.Title := 'Модуль Controls - переключатели';
LeftPanel(150,Colors.Beige);
var tb := TextBlock('Цвет круга:');
//tb.Margin := 12;
var rb1 := new RadioButtonWPF('Красный');
var rb2 := new RadioButtonWPF('Зелёный');
var rb3 := new RadioButtonWPF('Синий');
var c := new CircleWPF(GraphWindow.Center,60,Colors.White,1);
rb1.Click := procedure -> begin
c.Color := Colors.Red;
end;
rb2.Click := procedure -> begin
c.Color := Colors.Green;
end;
rb3.Click := procedure -> begin
c.Color := Colors.Blue;
end;
end.

28
InstallerSamples/Graphics/Controls/cc8_MoveObject.pas Normal file
View file

@ -0,0 +1,28 @@
// Модуль Controls - кнопки управления перемещением + клавиатура
uses WPFObjects,Controls;
begin
Window.Title := 'Модуль Controls - кнопки управления перемещением + клавиатура';
LeftPanel;
var c := new CircleWPF(GraphWindow.Center,30,Colors.Blue);
OnKeyDown := k -> begin
case k of
Key.Left: c.MoveOn(-2,0);
Key.Right: c.MoveOn(2,0);
Key.Up: c.MoveOn(0,-2);
Key.Down: c.MoveOn(0,2);
end;
end;
var l := Button('Left');
var r := Button('Right');
var u := Button('Up');
var d := Button('Down');
l.Click := ()->c.MoveOn(-2,0);
r.Click := ()->c.MoveOn(2,0);
u.Click := ()->c.MoveOn(0,-2);
d.Click := ()->c.MoveOn(0,2);
end.

27
InstallerSamples/Graphics/Controls/cc8a_MoveObject.pas Normal file
View file

@ -0,0 +1,27 @@
// Модуль Controls - IntegerBlock, IntegerBox и перемещение объекта
uses WPFObjects,Controls;
begin
Window.Title := 'Модуль Controls - IntegerBlock, IntegerBox и перемещение объекта';
LeftPanel;
var c := new CircleWPF(300,300,30,Colors.Blue);
var X := IntegerBox('X:',0,600);
X.Value := 300;
var Y := IntegerBox('Y:',0,600);
Y.Value := 300;
var XX := IntegerBlock('X:',300);
var YY := IntegerBlock('Y:',300);
X.ValueChanged := procedure → begin
c.Center := Pnt(X.Value,Y.Value);
XX.Value := X.Value;
end;
Y.ValueChanged := procedure → begin
c.Center := Pnt(X.Value,Y.Value);
YY.Value := Y.Value;
end;
end.

28
InstallerSamples/Graphics/Controls/cc9_ListBox.pas Normal file
View file

@ -0,0 +1,28 @@
// Модуль Controls - элемент управления "Список" и использование словаря
uses Controls,GraphWPF;
begin
Window.Title := 'Столицы стран';
LeftPanel(150,Colors.Orange);
var l := ListBox('Список стран');
//l.Tooltip := 'Выбери страну - отобразится столица';
l.Height := 110;
l.Add('Россия');
l.Add('США');
l.Add('Китай');
l.Add('Германия');
l.Add('Франция');
var d := Dict(('Россия','Москва'),
('США','Вашингтон'),
('Китай','Пекин'),
('Германия','Берлин'),
('Франция','Париж')
);
Font.Size := 70;
l.SelectionChanged := procedure -> begin
Window.Clear;
DrawText(GraphWindow.ClientRect,'Столица:'+#10+d[l.SelectedText]);
end;
end.

4
InstallerSamples/Graphics/WPFObjects/Shooter.pas
View file

@ -26,7 +26,7 @@ begin
var kl,kr,ku,kd: boolean;
BeginFrameBasedAnimationTime(dt->begin
OnDrawFrame := dt -> begin
Window.Title := 'Количество объектов: '+Objects.Count;
// Перемещение игрока
if kr then
@ -53,7 +53,7 @@ begin
// Конец игры
end;
end);
end;
CreateTimerAndStart(100,procedure -> // Таймер убивания монстров и умирания объектов за пределами экрана
begin

197
InstallerSamples/Graphics/WPFObjects/ShooterWithInterface.pas Normal file
View file

@ -0,0 +1,197 @@
uses WPFObjects, Timers, Controls;
type
BulletWPF = class(CircleWPF) end;
MonsterWPF = class(SquareWPF) end;
PlayerWPF = class(EllipseWPF) end;
TGameState = (Paused, Started, EndOfGame);
var
// Состояние игры
GameState: TGameState := Paused;
// Глобальные интерфейсные объекты
sb: StatusBarWPF;
bstart, bstop, bnewgame: ButtonWPF;
// Глобальные игровые объекты
Player: PlayerWPF;
// Клавиатура
kl, kr, ku, kd: boolean;
procedure InitGame;
begin
Player := new PlayerWPF(GraphWindow.Center, 30, 50, RandomColor);
Player.Velocity := 100;
Player.Number := 0;
loop 10 do
begin
var m := new MonsterWPF(750, Random(10, 550), 30, RandomColor);
m.Velocity := 50;
end;
end;
procedure NewGame;
begin
sb.Text := '';
Objects.Clear;
InitGame;
end;
// Конец игры - игрок погиб
procedure GameOver;
begin
sb.Text := 'Игрок погиб';
GameState := EndOfGame;
bstart.Enabled := False;
bstop.Enabled := False;
bnewgame.Enabled := True;
Player.Color := Colors.Black;
end;
// Конец игры - победа!
procedure GameOverWin;
begin
sb.Text := 'Победа!';
GameState := EndOfGame;
bstart.Enabled := False;
bstop.Enabled := False;
bnewgame.Enabled := True;
Player.Color := Colors.Yellow;
end;
procedure InitInterface;
begin
Window.SetSize(1000, 600);
LeftPanel(200, Colors.Orange);
bstart := Button('Start');
bstop := Button('Stop');
bnewgame := Button('Новая игра');
bstop.Enabled := False;
bstart.Enabled := False;
bstart.Click := procedure → begin
GameState := Started;
bstart.Enabled := False;
bstop.Enabled := True;
end;
bstop.Click := procedure → begin
GameState := Paused;
bstart.Enabled := True;
bstop.Enabled := False;
end;
bNewGame.Click := procedure → begin
GameState := Started;
bnewgame.Enabled := False;
bstart.Enabled := False;
bstop.Enabled := True;
NewGame;
end;
sb := StatusBar;
end;
// Обработчик таймера убивания монстров и умирания объектов за пределами экрана
procedure KillMonstersHandler;
begin
if GameState <> Started then
exit;
// Удалить пули, вылетевшие за экран
Objects.DestroyAll(o → o.OutOfGraphWindow and not (o is PlayerWPF));
// Удалить монстра, убитого пулей, вместе с пулей
foreach var o in Objects do
begin
if o is BulletWPF then
foreach var x in o.IntersectionList do
if x is MonsterWPF then
begin
x.Destroy;
o.Destroy;
Player.Number += 1;
break;
end;
end;
end;
// Обработчик перерисовки экрана
procedure DrawFrame(dt: real);
begin
if GameState <> Started then exit;
Window.Title := 'Количество объектов: ' + Objects.Count;
// Перемещение игрока
if kr then
Player.Dx := 1
else if kl then
Player.Dx := -1
else Player.Dx := 0;
if ku then
Player.Dy := -1
else if kd then
Player.Dy := 1
else Player.Dy := 0;
// Перемещение остальных объектов
foreach var o in Objects do // все перемещаются в своём направлении со своей скоростью
begin
if o is MonsterWPF then
o.Direction := (Player.Center.X - o.Center.X, Player.Center.Y - o.Center.Y);
o.MoveTime(dt);
end;
// Проверка гибели игрока
if Player.IntersectionList.Any(o → o is MonsterWPF) then
GameOver;
// Проверка выигрыша игрока
if Player.Number >= 10 then
GameOverWin;
end;
/// Обработчик таймера рождения монстров
procedure CreateMonstersHandler;
begin
if GameState <> Started then exit;
var x := if Random(2) = 0 then 750 else 50;
var m := new MonsterWPF(x, Random(10, 550), 30, RandomColor);
m.Velocity := 50;
end;
begin
InitInterface;
CreateTimerAndStart(100, KillMonstersHandler);
CreateTimerAndStart(1000, CreateMonstersHandler);
// Обработчик перерисовки кадров
OnDrawFrame := DrawFrame;
// Обработчики мыши и клавиатуры
OnMouseMove := (x, y, mb) → begin
if GameState <> Started then exit;
Player.RotateToPoint(x, y);
end;
OnMouseDown := (x, y, mb) → begin
if GameState <> Started then exit;
var cc := new BulletWPF(Player.CenterTop, 5, Colors.Red);
cc.Direction := (x - Player.Center.X, y - Player.Center.Y);
cc.Velocity := 300;
end;
OnKeyDown := k → begin
case k of
Key.w, Key.Up: begin ku := true; kd := false; end;
Key.s, Key.Down: begin kd := true; ku := false; end;
Key.a, Key.Left: begin kl := true; kr := false; end;
Key.d, Key.Right: begin kr := true; kl := false end;
end;
end;
OnKeyUp := k → begin
case k of
Key.w, Key.Up: ku := false;
Key.s, Key.Down: kd := false;
Key.a, Key.Left: kl := false;
Key.d, Key.Right: kr := false;
end;
end;
end.

32
InstallerSamples/Graphics/WPFObjects/StartStopMoveRotation.pas Normal file
View file

@ -0,0 +1,32 @@
// Модуль Controls - StatusBar
uses Controls,WPFObjects;
// Управление свойствами объекта, связанными с перемещением и поворотом.
// В OnDrawFrame объект сам себя перерисовывает
begin
Window.Title := 'Модуль Controls - StatusBar';
var l := LeftPanel(180,Colors.Orange);
var c := new RectangleWPF(50,200,80,50,Colors.Green);
c.Direction := (1,0);
c.Velocity := 0;
c.Tag := 0; // скорость поворота
OnDrawFrame := dt -> begin
c.MoveTime(dt);
c.RotateAngle += integer(c.Tag) * dt;
end;
Button('Начать перемещение').Click := procedure -> begin
c.Velocity := 30;
end;
Button('Закончить перемещение').Click := procedure -> begin
c.Velocity := 0;
end;
Button('Начать поворот').Click := procedure -> begin
c.Tag := 30;
end;
Button('Закончить поворот').Click := procedure -> begin
c.Tag := 0;
end;
end.

6
InstallerSamples/OpenGL и OpenCL/OpenCL/MatrMlt.cl
View file

@ -1,11 +1,10 @@

__kernel void MatrMltMatr(__global double* A, __global double* B, __global double* C, __global int* gW)
__kernel void MatrMltMatr(__global double* A, __global double* B, __global double* C, int W)
{
int cX = get_global_id(0);
int cY = get_global_id(1);
int W = *gW;
double sum = 0.0;
for (int i=0; i<W; i++)
@ -14,10 +13,9 @@ __kernel void MatrMltMatr(__global double* A, __global double* B, __global doubl
C[cX + cY*W] = sum;
}
__kernel void MatrMltVec(__global double* C, __global double* V1, __global double* V2, __global int* gW)
__kernel void MatrMltVec(__global double* C, __global double* V1, __global double* V2, int W)
{
int i = get_global_id(0);
int W = *gW;
double sum = 0.0;
for (int j=0; j<W; j++)

15
InstallerSamples/OpenGL и OpenCL/OpenCL/MatrMlt.pas
View file

@ -19,8 +19,7 @@ begin
cl.GetPlatformIDs(1, platform, IntPtr.Zero).RaiseIfError;
var device: cl_device_id;
cl.GetDeviceIDs(platform, DeviceType.DEVICE_TYPE_DEFAULT, 1,device,IntPtr.Zero).RaiseIfError;
// cl.GetDeviceIDs(platform, DeviceType.DEVICE_TYPE_ALL, 1,device,IntPtr.Zero).RaiseIfError;
cl.GetDeviceIDs(platform, DeviceType.DEVICE_TYPE_ALL, 1,device,IntPtr.Zero).RaiseIfError;
var context := cl.CreateContext(nil, 1,device, nil,IntPtr.Zero, ec);
ec.RaiseIfError;
@ -31,7 +30,9 @@ begin
// Чтение и компиляция .cl файла
{$resource MatrMlt.cl}
var prog_str := System.IO.StreamReader.Create(GetResourceStream('MatrMlt.cl')).ReadToEnd;
var prog_str := System.IO.StreamReader.Create(
System.Reflection.Assembly.GetCallingAssembly.GetManifestResourceStream('MatrMlt.cl')
).ReadToEnd;
var prog := cl.CreateProgramWithSource(
context,
1,
@ -80,15 +81,13 @@ begin
ec.RaiseIfError;
var MatrWParam := MatrW;
var W_buf := cl.CreateBuffer(context, MemFlags.MEM_READ_WRITE or MemFlags.MEM_USE_HOST_PTR, new UIntPtr(sizeof(integer)),new IntPtr(@MatrWParam), ec);
ec.RaiseIfError;
// Выполнение C := A*B
cl.SetKernelArg(MatrMltMatrKernel, 0, new UIntPtr(UIntPtr.Size), A_buf).RaiseIfError;
cl.SetKernelArg(MatrMltMatrKernel, 1, new UIntPtr(UIntPtr.Size), B_buf).RaiseIfError;
cl.SetKernelArg(MatrMltMatrKernel, 2, new UIntPtr(UIntPtr.Size), C_buf).RaiseIfError;
cl.SetKernelArg(MatrMltMatrKernel, 3, new UIntPtr(UIntPtr.Size), W_buf).RaiseIfError;
cl.SetKernelArg(MatrMltMatrKernel, 3, new UIntPtr(sizeof(integer)), @MatrWParam).RaiseIfError;
var k1_ev: cl_event;
cl.EnqueueNDRangeKernel(command_queue, MatrMltMatrKernel, 2, nil,new UIntPtr[](new UIntPtr(MatrW),new UIntPtr(MatrW)),nil, 0,nil,k1_ev).RaiseIfError;
@ -98,7 +97,7 @@ begin
cl.SetKernelArg(MatrMltVecKernel, 0, new UIntPtr(UIntPtr.Size), C_buf).RaiseIfError;
cl.SetKernelArg(MatrMltVecKernel, 1, new UIntPtr(UIntPtr.Size), V1_buf).RaiseIfError;
cl.SetKernelArg(MatrMltVecKernel, 2, new UIntPtr(UIntPtr.Size), V2_buf).RaiseIfError;
cl.SetKernelArg(MatrMltVecKernel, 3, new UIntPtr(UIntPtr.Size), W_buf).RaiseIfError;
cl.SetKernelArg(MatrMltVecKernel, 3, new UIntPtr(sizeof(integer)), @MatrWParam).RaiseIfError;
var k2_ev: cl_event;
cl.EnqueueNDRangeKernel(command_queue, MatrMltVecKernel, 1, nil,new UIntPtr[](new UIntPtr(MatrW)),nil, 1,k1_ev,k2_ev).RaiseIfError;
@ -113,7 +112,7 @@ begin
A.Println;
Writeln;
cl.EnqueueReadBuffer(command_queue, V2_buf, Bool.NON_BLOCKING, new UIntPtr(0), new UIntPtr(VecByteSize), V1[0], 1,k2_ev,IntPtr.Zero).RaiseIfError;
cl.EnqueueReadBuffer(command_queue, V2_buf, Bool.BLOCKING, new UIntPtr(0), new UIntPtr(VecByteSize), V1[0], 1,k2_ev,IntPtr.Zero).RaiseIfError;
Writeln('Вектор V2 = C*V1:');
V1.Println;

15
InstallerSamples/OpenGL и OpenCL/OpenCL/SimpleAddition.pas
View file

@ -15,15 +15,8 @@ begin
cl.GetPlatformIDs(1, platform, IntPtr.Zero).RaiseIfError;
var device: cl_device_id;
cl.GetDeviceIDs(platform, DeviceType.DEVICE_TYPE_DEFAULT, 1,device,IntPtr.Zero).RaiseIfError;
// DEVICE_TYPE_DEFAULT это, обычно, GPU
// Но, к примеру, в ноутбуке его может не быть
// Тогда надо хоть для чего то попытаться инициализировать
// DEVICE_TYPE_ALL выберет первое любое устройство, поддерживающее OpenCL
// cl.GetDeviceIDs(platform, DeviceType.DEVICE_TYPE_ALL, 1,device,IntPtr.Zero).RaiseIfError;
// Если всё ещё пишет что устройств нет - обновите драйверы,
// потому что даже встроенные видеокарты поддерживают OpenCL
cl.GetDeviceIDs(platform, DeviceType.DEVICE_TYPE_ALL, 1,device,IntPtr.Zero).RaiseIfError;
// Если пишет что устройств нет - обновите драйверы
var context := cl.CreateContext(nil, 1,device, nil,IntPtr.Zero, ec);
ec.RaiseIfError;
@ -34,7 +27,9 @@ begin
// Чтение и компиляция .cl файла
{$resource SimpleAddition.cl} // эта строчка засовывает SimpleAddition.cl внутрь .exe, чтоб не надо было таскать его вместе с .exe
var prog_str := System.IO.StreamReader.Create(GetResourceStream('SimpleAddition.cl')).ReadToEnd;
var prog_str := System.IO.StreamReader.Create(
System.Reflection.Assembly.GetCallingAssembly.GetManifestResourceStream('SimpleAddition.cl')
).ReadToEnd;
var prog := cl.CreateProgramWithSource(
context,
1,

6
InstallerSamples/OpenGL и OpenCL/OpenCLABC/0Простейшие примеры/MatrMlt.cl
View file

@ -1,11 +1,10 @@

__kernel void MatrMltMatr(__global double* A, __global double* B, __global double* C, __global int* gW)
__kernel void MatrMltMatr(__global double* A, __global double* B, __global double* C, int W)
{
int cX = get_global_id(0);
int cY = get_global_id(1);
int W = *gW;
double sum = 0.0;
for (int i=0; i<W; i++)
@ -14,10 +13,9 @@ __kernel void MatrMltMatr(__global double* A, __global double* B, __global doubl
C[cX + cY*W] = sum;
}
__kernel void MatrMltVec(__global double* C, __global double* V1, __global double* V2, __global int* gW)
__kernel void MatrMltVec(__global double* C, __global double* V1, __global double* V2, int W)
{
int i = get_global_id(0);
int W = *gW;
double sum = 0.0;
for (int j=0; j<W; j++)

20
InstallerSamples/OpenGL и OpenCL/OpenCLABC/0Простейшие примеры/MatrMlt.pas
View file

@ -19,9 +19,9 @@ begin
// Вообще лучше прекомпилировать .cl файл (загружать в переменную ProgramCode)
// И сохранять с помощью метода ProgramCode.SerializeTo
// А полученный бинарник уже подключать через $resource
var code := new ProgramCode(
var code := new ProgramCode(Context.Default,
System.IO.StreamReader.Create(
GetResourceStream('MatrMlt.cl')
System.Reflection.Assembly.GetExecutingAssembly.GetManifestResourceStream('MatrMlt.cl')
).ReadToEnd
);
@ -47,7 +47,7 @@ begin
var V2 := new Buffer(VecByteSize);
var N := new Buffer(4);
var W := KernelArg.FromRecord(MatrW);
// (запись значений в параметры - позже, в очередях)
@ -55,14 +55,14 @@ begin
var Calc_C_Q :=
code['MatrMltMatr'].NewQueue.AddExec2(MatrW, MatrW, // Выделяем ядра в форме квадрата, всего MatrW*MatrW ядер
A.NewQueue.AddWriteArray(A_Matr) as CommandQueue<Buffer>,
B.NewQueue.AddWriteArray(B_Mart) as CommandQueue<Buffer>,
A.NewQueue.AddWriteArray2&<real>(A_Matr),
B.NewQueue.AddWriteArray2&<real>(B_Mart),
C,
N.NewQueue.AddWriteValue(MatrW) as CommandQueue<Buffer>
W
) as CommandQueue<Kernel>;
var Otp_C_Q :=
C.NewQueue.AddReadArray(A_Matr) as CommandQueue<Buffer> +
C.NewQueue.AddReadArray2&<real>(A_Matr) +
HPQ(()->
lock output do
begin
@ -74,13 +74,13 @@ begin
var Calc_V2_Q :=
code['MatrMltVec'].NewQueue.AddExec1(MatrW,
C,
V1.NewQueue.AddWriteArray(V1_Arr) as CommandQueue<Buffer>,
V1.NewQueue.AddWriteArray1&<real>(V1_Arr),
V2,
N // значение записывается в Calc_C_Q, тут можно использовать уже готовое
W
) as CommandQueue<Kernel>;
var Otp_V2_Q :=
V2.NewQueue.AddReadArray(V1_Arr) as CommandQueue<Buffer> +
V2.NewQueue.AddReadArray1&<real>(V1_Arr) +
HPQ(()->
lock output do
begin

11
InstallerSamples/OpenGL и OpenCL/OpenCLABC/0Простейшие примеры/SimpleAddition.pas
View file

@ -4,23 +4,24 @@ begin
// Чтение и компиляция .cl файла
var prog := new ProgramCode(ReadAllText('SimpleAddition.cl'));
var prog := new ProgramCode(Context.Default, ReadAllText('SimpleAddition.cl'));
// Подготовка параметров
var A := new Buffer( 10 * sizeof(integer) ); // Буфер достаточно размера, чтоб хранить 10 элементов типа "integer"
var A := new Buffer( 10 * sizeof(integer) ); // Буфер достаточного размера, чтобы хранить 10 элементов типа "integer"
// Выполнение
prog['TEST'].Exec1(10, // используем 10 ядер
A.NewQueue.AddFillValue(1) // заполняем весь буфер значениями (1), прямо перед выполнением. Тип значения integer, потому что это тип по-умолчанию для целых чисел
as CommandQueue<Buffer> //ToDo нужно только из за issue компилятора #1981, иначе получаем странную ошибку. Когда исправят - можно будет убрать
// Заполняем весь буфер значениями (1), прямо перед выполнением
// Тип значения integer, потому что это тип по-умолчанию для целых чисел
A.NewQueue.AddFillValue(1)
);
// Чтение и вывод результата
A.GetArray1&<integer>.Println; // читаем всё содержимое как одномерный массив с элементами типа "integer"
A.GetArray1&<integer>.Println; // Читаем всё содержимое как одномерный массив с элементами типа "integer"
end.

20
InstallerSamples/OpenGL и OpenCL/OpenCLABC/Wait очереди/2.pas
View file

@ -4,24 +4,28 @@ uses NamedQData;
begin
// График выполнения очередей:
//
// A1--B1--C1------D1
// A1--B1--C1------E1
// \ /
// \ /
// A2------B2--C2--D2
// A2------C2--D2--E2
//
var A1 := NamedQ('A1');
var B1 := NamedQ('B1');
var C1 := NamedQ('C1');
var D1 := NamedQ('D1');
var A2 := NamedQ('A2');
var B2 := NamedQ('B2');
var B1 := NamedQ('B1');
var C1 := NamedQ('C1');
var C2 := NamedQ('C2');
var D2 := NamedQ('D2');
var E1 := NamedQ('E1');
var E2 := NamedQ('E2');
Context.Default.SyncInvoke(
( A1 + B1 + C1 + WaitFor(C2) + D1 ) *
( A2 + WaitFor(B1) + B2 + C2 + D2 )
( A1 + B1 + C1 + WaitFor(D2) + E1 ) *
( A2 + WaitFor(B1) + C2 + D2 + E2 )
);
end.

11
InstallerSamples/OpenGL и OpenCL/OpenCLABC/Прекомпиляция ProgramCode/0.cl Normal file
View file

@ -0,0 +1,11 @@

__kernel void TEST(__global int* message)
{
int gid = get_global_id(0); // номер текущего вызова TEST
message[gid] += gid;
}

24
InstallerSamples/OpenGL и OpenCL/OpenCLABC/Прекомпиляция ProgramCode/Использовать.pas Normal file
View file

@ -0,0 +1,24 @@
uses OpenCLABC;
begin
// Запустите "Прекомпилировать.pas", чтобы создать этот файл
{$resource 0.cl.temp_bin}
var prog := ProgramCode.DeserializeFrom(Context.Default,
System.Reflection.Assembly.GetExecutingAssembly.GetManifestResourceStream('0.cl.temp_bin')
);
// Дальше всё так же как в "0Простейшие примеры\SimpleAddition"
var A := new Buffer( 10 * sizeof(integer) );
prog['TEST'].Exec1(10,
A.NewQueue.AddFillValue(1)
);
A.GetArray1&<integer>.Println;
end.

8
InstallerSamples/OpenGL и OpenCL/OpenCLABC/Прекомпиляция ProgramCode/Прекомпилировать.pas Normal file
View file

@ -0,0 +1,8 @@
uses OpenCLABC;
begin
var prog := new ProgramCode(Context.Default, ReadAllText('0.cl'));
var f := System.IO.File.Create('0.cl.temp_bin');
prog.SerializeTo(f);
f.Close;
end.

87
InstallerSamples/OpenGL и OpenCL/Гайд по использованию OpenGL и OpenCL.html
View file

@ -71,13 +71,27 @@ body {
}
.ps-page-name {
cursor: pointer;
padding: 1;
padding: 1;
}
/* ============================== *\
page display
\* ============================== */
blockquote > *:first-child {
margin-top: 0;
}
blockquote > *:last-child {
margin-bottom: 0;
}
blockquote {
margin-left: 0;
margin-right: 0;
padding: 12px;
border-left: 5px solid #d0d0d0;
background-color: #f7f7f7;
}
.smart-link {
color: blue;
cursor: pointer;
@ -99,7 +113,6 @@ body {
.code-block {
display: inline-block;
cursor: text;
background: #F0F0F0;
border-radius: 3px;
padding: 4px;
@ -121,9 +134,13 @@ body {
box-shadow: -2px 2px 3px #0000004a;
background: linear-gradient(0deg, #f0f0f0, white);
}
.inline-code {
.inline-code, .code-block {
background: #F0F0F0;
}
blockquote .inline-code,
blockquote .code-block {
background: #DEDEDE;
}
.code-keyword {
font-weight: bold;
@ -903,7 +920,8 @@ window.onload = ()=>{
<p>Если в кратце:</p>
<p>Есть платформа .Net, объединяющая много языков программирования. В том числе C# и PascalABC.NET.</p>
<p>.exe и .dll созданные такими языками содержат код в особом виде, позволяющем легко подключать
.dll (и теоретически .exe, но это плохо) созданные на 1 .Net языке к программе на любом другом .Net языке.</p>
.dll (и теоретически .exe, но это плохо) созданные на 1 .Net языке к программе на любом другом .Net языке.<br />
(в паскале это делается с помощью <code>$reference</code>)</p>
<p>Такие .exe и .dll называются управляемыми. .exe и .dll созданные на любом другом (то есть не .Net) языке называются неуправляемыми.</p>
<p>OpenCL.dll и OpenGL.dll созданы на- и для языков C/C++, поэтому являются неуправляемыми.</p>
</div>
@ -911,7 +929,7 @@ window.onload = ()=>{
<div id="page-3" page_name="Участие в разработке н.у. модулей" hidden=true>
<p>Большинство функций из н.у. модулей требует какой-либо чистки. В основном потому что
при переводе с C++ тип <code>int*</code> может оказаться и указателем, и <code>var</code>-параметром, и массивом.</p>
<p>При автоматическом переводе кода с C++ на паскаль - создаются все возможные перегркзки.
<p>При автоматическом переводе кода с C++ на паскаль - создаются все возможные перегрузки.
А те перегрузки, которые не подходят конкретным подпрограммам - надо убирать вручную.
В этом и состоит чистка подпрограмм.</p>
<p>Все разом функции не почистишь, в одном только <code>OpenGL</code> их &gt;3000. Но сделать это, всё же, надо.
@ -920,9 +938,9 @@ window.onload = ()=>{
<hr />
<p>Чтоб чистить подпрограммы было проще - я написал несколько инструментов.
Вся упаковка н.у. модулей находится <a href="https://github.com/SunSerega/POCGL/tree/master/Packing/Template">тут</a>.
Откройте папку <code>CL</code> или <code>GL</code>. Они устроены одинаково, поэтому объяснять можно на любой из них.</p>
<p>Все файлы (кроме .exe и .pdb, которые создаёт паскаль) в этих папках
открываются любым текстовым редактором (но я рекомендую Notepad++).</p>
Откройте папку <code>OpenCL</code> или <code>OpenGL</code>. Они устроены одинаково, поэтому объяснять можно на любой из них.</p>
<p>Все файлы (кроме .exe и .pdb, которые создаёт паскаль) в
этих папках открываются любым текстовым редактором.</p>
<hr />
<h3>Fixers</h3>
<p>Контроль содержимого модуля находится в папке <code>Fixers</code>. В этой папке есть следующие подпапки:</p>
@ -985,6 +1003,7 @@ window.onload = ()=>{
public constructor(val: UInt32) := self.val := val;
public static property Zero: BufferName read default(BufferName);
public static property Size: integer read Marshal.SizeOf&amp;&lt;UInt32&gt;;
public function ToString: string; override := $'BufferName[{val}]';
end;
</code></pre>
<p>Такой подход не замедляет готовую программу, но позволяет отловить некоторые ошибки на этапе компиляции.</p>
@ -1020,7 +1039,7 @@ MyProc(default(BufferName));
</div>
<script>on_page_added(document.getElementById("page-5"))</script>
<div id="page-6" page_name="Записи-перечисления" hidden=true>
<p>Многие параметры подпрограмм в исходных библиотеках принимают перечисления (enum's).</p>
<p>Многие параметры подпрограмм в исходных библиотеках принимают перечисления (enum'ы).</p>
<p>Перечисления, как и имена, это числа. Но в отличии от имён - перечисления принимают заданные заранее константные значения.</p>
<p>В качестве примера:</p>
<pre><code>procedure gl.BeginQuery(target: QueryTarget; id: QueryName);
@ -1068,8 +1087,8 @@ gl.BeginQuery(QueryTarget.VERTICES_SUBMITTED, name);
<pre><code>procedure gl.Clear(mask: ClearBufferMask);
</code></pre>
<pre><code>gl.Clear(
ClearBufferMask.COLOR_BUFFER_BIT or // очистка поверхности рисования одним цветом
ClearBufferMask.DEPTH_BUFFER_BIT // очистка буфера глубины - обязательна при рисовании 3D
ClearBufferMask.COLOR_BUFFER_BIT or // очистка поверхности рисования одним цветом
ClearBufferMask.DEPTH_BUFFER_BIT // очистка буфера глубины - обязательна при рисовании 3D
);
</code></pre>
<p><code>or</code>, в данном случае, побитовое, а не логическое.</p>
@ -1155,7 +1174,7 @@ glDebugOutputAMD.DebugMessageEnableAMD(...);
<div class="spoiler" summary="Как это читать?" hidden="true"><p>Каждый тип вектора берёт по 1 из значений, перечисленных в <code>[]</code>, через запятую.</p>
<p>К примеру, есть типы <code>Vec2d</code> и <code>Vec4ui64</code>.</p>
<p>Число в первых скобках - значит кол-во измерений вектора.</p>
<p>Буква (буквы) в следующих скобках - значит тип координат вектора:</p>
<p>Буква (буквы) в следующих скобках - значат тип координат вектора:</p>
<ul>
<li><p><code>b=shortint</code>, <code>s=smallint</code>, <code>i=integer</code>, <code>i64=int64</code>: Все 4 типа - целые числа, имеющие бит знака (±) и занимающие 1, 2, 4 и 8 байт соответственно;</p>
</li>
@ -1171,9 +1190,9 @@ glDebugOutputAMD.DebugMessageEnableAMD(...);
и возвращает или задаёт значение вектора для соответствующего измерения.</p>
<p>К примеру:</p>
<pre><code>var v: Vec4d;
v[0] := 123.456; // записываем 123.456 по индексу 0
v[1].Println; // читаем и выводим значение по индексу 1
v.val[2] := 1; // можно так же писать и имя свойства
v[0] := 123.456; // Записываем 123.456 по индексу 0
v[1].Println; // Читаем и выводим значение по индексу 1
v.val[2] := 1; // Можно так же писать и имя свойства
</code></pre>
<p>Но использование этого свойства не рекомендуется. Прямое обращение
к полю всегда будет быстрее. То есть аналогично предыдущему коду:</p>
@ -1189,7 +1208,7 @@ v.val2 := 1;
// v1 будет иметь ту же длину, но
// противоположное v0 направление
var v1 := -v0;
// а унарный + не делает ничего, он только
// А унарный + не делает ничего, он только
// для красоты. То есть v2 будет =v0
var v2 := +v0;
</code></pre>
@ -1197,29 +1216,29 @@ var v2 := +v0;
<pre><code>var v1: Vec3d;
var v2: Vec3i;
...
// выведет вектор, имеющий то же
// Выведет вектор, имеющий то же
// направление что v1, но в 2 раза длиннее
(v1*2).Println;
// выведет вектор, имеющий то же
// Выведет вектор, имеющий то же
// направление что v1, но в 2 раза короче
(v1/2).Println;
// к целочисленным векторам вместо
// К целочисленным векторам вместо
// обычного деления надо применять div
(v2 div 2).Println;
</code></pre>
<h3>Операции с 2 векторами</h3>
<pre><code>var v1, v2: Vec3d;
...
// скалярное произведение векторов
// Скалярное произведение векторов
(v1*v2).Println;
// сумма векторов, складывает
// Сумма векторов, складывает
// отдельно каждый элемент вектора
(v1+v2).Println;
// разность векторов, тоже работает
// Разность векторов, тоже работает
// отдельно на каждый элемент вектора
(v1-v2).Println;
</code></pre>
@ -1236,8 +1255,8 @@ var v2: Vec2i;
Каким образом находить корень полученного значения - дело программиста.</p>
<pre><code>var v1: Vec3d;
...
v1.SqrLength.Println; // квадрат длины
v1.SqrLength.Sqrt.Println; // сама длина
v1.SqrLength.Println; // Квадрат длины
v1.SqrLength.Sqrt.Println; // Сама длина
</code></pre>
<h3>Normalized</h3>
<p>Метод <code>.Normalized</code> возвращает нормализированную (с длиной =1) версию вектора.<br />
@ -1248,7 +1267,7 @@ v1.Println;
v1.SqrLength.Sqrt.Println;
var v2 := v1.Normalized;
v2.Println;
v2.SqrLength.Sqrt.Println; // обязательно будет 1
v2.SqrLength.Sqrt.Println; // Обязательно будет 1
</code></pre>
<h3>Cross</h3>
<p>Статичный метод <code>.Cross</code> возвращает произведение векторов (Cross product, не путать со скалярным произведением).
@ -1273,7 +1292,7 @@ v2.SqrLength.Sqrt.Println; // обязательно будет 1
<h3>Превращение в строку</h3>
<pre><code>var v1: Vec4d;
...
v1.Println; // вывод вектора
v1.Println; // Вывод вектора
// s присвоит ту же строку, что выводит .Println
var s := v1.ToString;
</code></pre>
@ -1311,7 +1330,7 @@ m.val31 := 1;
<p>Но у матриц так же есть свойства для столбцов и строк:</p>
<pre><code>var m: Mtr3d;
...
m.Row0.Println; // вывод нулевой строчки в виде вектора
m.Row0.Println; // Вывод нулевой строчки в виде вектора
m.Row1 := new Vec3d(1,2,3);
m.Col2.Println;
</code></pre>
@ -1319,7 +1338,7 @@ m.Col2.Println;
получать по динамическому индексу (но, опять же, это медленнее):</p>
<pre><code>var m: Mtr3d;
...
m.Row[0].Println; // вывод нулевой строчки в виде вектора
m.Row[0].Println;
m.Row[1] := new Vec3d(1,2,3);
m.Col[2].Println;
</code></pre>
@ -1340,7 +1359,7 @@ var ptr2 := m.ColPtr[3];
<p><code>Identity</code> создаёт новую единичную матрицу. То есть матрицу, у
которой главная диагональ заполнена 1, а всё останое заполнено 0.</p>
<pre><code>Mtr3d.Identity.Println;
// работает и для не_квадратных матриц
// Работает и для не_квадратных матриц
Mtr2x3d.Identity.Println;
</code></pre>
<h3>UseColPtr*</h3>
@ -1378,8 +1397,8 @@ var v := new Vec3d(1,2,3);
умножении на которую к вектору добавляется заданное значение.</p>
<pre><code>var m := Mtr4d.Translate(1,2,3);
// последний элемент должен быть 1,
// чтоб матрица из .Translate правильно работала
// Последний элемент должен быть 1,
// чтобы матрица из .Translate правильно работала
var v := new Vec4d(0,0,0,1);
(m*v).Println; // (1;2;3)
@ -1407,7 +1426,7 @@ var v := new Vec4d(0,0,0,1);
1,2,3,
4,5,6
);
m.Transpose.Println; // выводит:
m.Transpose.Println; // Выводит:
// 1 4
// 2 5
// 3 6
@ -1423,7 +1442,7 @@ m.Transpose.Println; // выводит:
<p>Как и у векторов - матрицы можно выводить и превращать в строку</p>
<pre><code>var m: Mtr4d;
...
m.Println; // вывод матрицы
m.Println; // Вывод матрицы
// s присвоит ту же строку, что выводит .Println
var s := m.ToString;
</code></pre>
@ -1828,7 +1847,7 @@ begin
cl.SetEventCallback(ev, CommandExecutionStatus.COMPLETE, cb,IntPtr.Zero).RaiseIfError;
end.
</code></pre>
<p>Этот код будет может время от времени вылетать, потому что:</p>
<p>Этот код может время от времени вылетать, потому что:</p>
<ol>
<li><p><code>cl.SetEventCallback</code> вызывает свой коллбек тогда, когда посчитает нужным (но обычно после того как вызов <code>cl.SetEventCallback</code> завершился);</p>
</li>

921
InstallerSamples/OpenGL и OpenCL/Справка OpenCLABC.html
View file

File diff suppressed because it is too large Load diff

27
InstallerSamples/OpenGL и OpenCL/Справка OpenGLABC.html
View file

@ -71,13 +71,27 @@ body {
}
.ps-page-name {
cursor: pointer;
padding: 1;
padding: 1;
}
/* ============================== *\
page display
\* ============================== */
blockquote > *:first-child {
margin-top: 0;
}
blockquote > *:last-child {
margin-bottom: 0;
}
blockquote {
margin-left: 0;
margin-right: 0;
padding: 12px;
border-left: 5px solid #d0d0d0;
background-color: #f7f7f7;
}
.smart-link {
color: blue;
cursor: pointer;
@ -99,7 +113,6 @@ body {
.code-block {
display: inline-block;
cursor: text;
background: #F0F0F0;
border-radius: 3px;
padding: 4px;
@ -121,9 +134,13 @@ body {
box-shadow: -2px 2px 3px #0000004a;
background: linear-gradient(0deg, #f0f0f0, white);
}
.inline-code {
.inline-code, .code-block {
background: #F0F0F0;
}
blockquote .inline-code,
blockquote .code-block {
background: #DEDEDE;
}
.code-keyword {
font-weight: bold;
@ -859,9 +876,9 @@ window.onload = ()=>{
}
</script>
<div id="page-1" page_name="" hidden=true>
<p><code>ToDo</code> модуля <code>OpenGLABC</code> пока что не существует. Когда то он появится, но пока что есть только это сообщение.</p>
<p><code>ToDo</code> модуль <code>OpenGLABC</code> пока что не существует. Когда то он появится, но пока что есть только это сообщение.</p>
<p>Если хотите понять, было ли это сообщение оставлено тут 10 лет назад и забыто - вот дата, когда автор сообщения последний раз прочитал его:<br />
24.02.2020</p>
03.08.2020</p>
</div>
<script>on_start_folder("GL ABC", document.getElementById("page-1"))</script>
<script>on_end_folder()</script>

BIN
Localization/DefaultLang.resources
View file

Binary file not shown.

1524
Parsers/PascalABCParserNewSaushkin/ABCPascal.cs
View file

File diff suppressed because it is too large Load diff

4
Parsers/PascalABCParserNewSaushkin/ABCPascal.lex
View file

@ -218,7 +218,9 @@ UNICODEARROW \x890
"<>" { yylval = new Union(); yylval.op = new op_type_node(Operators.NotEqual); return (int)Tokens.tkNotEqual; }
"^" { yylval = new Union(); yylval.op = new op_type_node(Operators.Deref); return (int)Tokens.tkDeref; }
"->" { yylval = new Union(); yylval.ti = new token_info(yytext); return (int)Tokens.tkArrow; }
\x2192 { yylval = new Union(); yylval.ti = new token_info(yytext); return (int)Tokens.tkArrow; }
\u2192 { yylval = new Union(); yylval.ti = new token_info(yytext); return (int)Tokens.tkArrow; }
\<\<expression\>\> { return (int)Tokens.tkParseModeExpression; }
\<\<statement\>\> { return (int)Tokens.tkParseModeStatement; }
\<\<type\>\> { return (int)Tokens.tkParseModeType; }

8
Parsers/PascalABCParserNewSaushkin/ABCPascal.y
View file

@ -3934,10 +3934,6 @@ factor
{
$$ = new pascal_set_constant($2 as expression_list, @$);
}
| tkVertParen elem_list tkVertParen
{
$$ = new array_const_new($2 as expression_list, @$);
}
| tkNot factor
{
$$ = new un_expr($2, $1.type, @$);
@ -4110,6 +4106,10 @@ variable
}
$$ = new slice_expr_question($1 as addressed_value,fe.expr,fe.format1,fe.format2,@$);
}
| tkVertParen elem_list tkVertParen
{
$$ = new array_const_new($2 as expression_list, @$);
}
| variable tkRoundOpen optional_expr_list tkRoundClose
{
$$ = new method_call($1 as addressed_value,$3 as expression_list, @$);

946
Parsers/PascalABCParserNewSaushkin/ABCPascalYacc.cs
View file

File diff suppressed because it is too large Load diff

1
Parsers/PascalABCParserNewSaushkin/PABC.ymc
View file

@ -275,5 +275,6 @@ script=

2
Release/pabcversion.txt
View file

@ -1 +1 @@
3.6.3.2595
3.6.3.2617

2
ReleaseGenerators/PascalABCNET_version.nsh
View file

@ -1 +1 @@
!define VERSION '3.6.3.2595'
!define VERSION '3.6.3.2617'

4
ReleaseGenerators/RebuildStandartModules.pas
View file

@ -13,8 +13,8 @@
RobotTaskMaker, RobotZadan, Sockets, Utils, VCL, Timers, PT4Exam, PT4TaskMakerNET, RBDMUtils,
Collections, Arrays, Core, FormsABC, MPI, ClientServer, Speech, Sounds, Countries,
ABCDatabases,BlockFileOfT,Controls,
OpenCL, OpenCLABC,
OpenGL, OpenGLABC,
OpenCL, OpenCLABCBase, OpenCLABC,
OpenGL, OpenGLABCBase, OpenGLABC,
BBCMicroBit, School, SF, TwoPanelsWindow
;

9
ReleaseGenerators/sect_Core.nsh
View file

@ -129,8 +129,10 @@
File ..\bin\Lib\Sounds.pcu
File ..\bin\Lib\BlockFileOfT.pcu
File ..\bin\Lib\OpenCL.pcu
File ..\bin\Lib\OpenCLABCBase.pcu
File ..\bin\Lib\OpenCLABC.pcu
File ..\bin\Lib\OpenGL.pcu
File ..\bin\Lib\OpenGLABCBase.pcu
File ..\bin\Lib\OpenGLABC.pcu
File ..\bin\Lib\School.pcu
File ..\bin\Lib\SF.pcu
@ -199,8 +201,10 @@
${AddFile} "Sounds.pcu"
${AddFile} "BlockFileOfT.pcu"
${AddFile} "OpenCL.pcu"
${AddFile} "OpenCLABCBase.pas"
${AddFile} "OpenCLABC.pcu"
${AddFile} "OpenGL.pcu"
${AddFile} "OpenGLABCBase.pas"
${AddFile} "OpenGLABC.pcu"
${AddFile} "School.pcu"
${AddFile} "SF.pcu"
@ -281,8 +285,10 @@
File ..\bin\Lib\Sounds.pas
File ..\bin\Lib\BlockFileOfT.pas
File ..\bin\Lib\OpenCL.pas
File ..\bin\Lib\OpenCLABCBase.pas
File ..\bin\Lib\OpenCLABC.pas
File ..\bin\Lib\OpenGL.pas
File ..\bin\Lib\OpenGLABCBase.pas
File ..\bin\Lib\OpenGLABC.pas
File ..\bin\Lib\School.pas
File ..\bin\Lib\SF.pas
@ -342,14 +348,15 @@
${AddFile} "Core.pas"
${AddFile} "MPI.pas"
${AddFile} "ClientServer.pas"
${AddFile} "OpenGL.pas"
${AddFile} "PT4MakerNetX.pas"
${AddFile} "Speech.pas"
${AddFile} "Sounds.pas"
${AddFile} "BlockFileOfT.pas"
${AddFile} "OpenCL.pas"
${AddFile} "OpenCLABCBase.pas"
${AddFile} "OpenCLABC.pas"
${AddFile} "OpenGL.pas"
${AddFile} "OpenGLABCBase.pas"
${AddFile} "OpenGLABC.pas"
${AddFile} "School.pas"
${AddFile} "SF.pas"

14
SyntaxTree/tree/NodesBuilder.cs
View file

@ -215,6 +215,20 @@ namespace PascalABCCompiler.SyntaxTree
}
}
// добавление свойств - временно убрал т.к. свойства нельзя передавать как var-параметры
// По идее если это делать, то поля переименовывать везде в классе!!!
/*for (var i=0; i<names.Count; i++)
{
if (names[i].name.StartsWith("#"))
continue;
var propName = names[i].TypedClone();
names[i].name = "!" + names[i].name;
var simpleProp = BuildSimpleReadWriteProperty(propName, names[i].name, types[i]);
var cm = BuildOneMemberSection(simpleProp);
cb.Add(cm);
}*/
if (!HasConstructor)
{
var fnames = names.Select(x => new ident("f" + x.name.ToLower(), x.source_context)).ToList();

2
SyntaxTree/tree/SyntaxTreeStreamReader.cs
View file

@ -4426,7 +4426,7 @@ namespace PascalABCCompiler.SyntaxTree
public void read_array_const_new(array_const_new _array_const_new)
{
read_expression(_array_const_new);
read_addressed_value(_array_const_new);
_array_const_new.elements = _read_node() as expression_list;
}

2
SyntaxTree/tree/SyntaxTreeStreamWriter.cs
View file

@ -6917,7 +6917,7 @@ namespace PascalABCCompiler.SyntaxTree
public void write_array_const_new(array_const_new _array_const_new)
{
write_expression(_array_const_new);
write_addressed_value(_array_const_new);
if (_array_const_new.elements == null)
{
bw.Write((byte)0);

2
SyntaxTree/tree/Tree.cs
View file

@ -54037,7 +54037,7 @@ namespace PascalABCCompiler.SyntaxTree
///
///</summary>
[Serializable]
public partial class array_const_new : expression
public partial class array_const_new : addressed_value
{
///<summary>

2
SyntaxTree/tree/tree.xml
View file

@ -3270,7 +3270,7 @@
<TagIndices />
</Tags>
</SyntaxNode>
<SyntaxNode Name="array_const_new" BaseName="expression">
<SyntaxNode Name="array_const_new" BaseName="addressed_value">
<Fields>
<SyntaxField Name="elements" SyntaxType="expression_list" />
</Fields>

2
SyntaxTreeConverters/StandardSyntaxConverter.cs
View file

@ -45,7 +45,7 @@ namespace PascalABCCompiler.SyntaxTreeConverters
IndexVisitor.New.ProcessNode(root);
// assign_tuple и assign_var_tuple
AssignTuplesDesugarVisitor.New.ProcessNode(root);
//AssignTuplesDesugarVisitor.New.ProcessNode(root);
// slice_expr и slice_expr_question
SliceDesugarVisitor.New.ProcessNode(root);

31
TestSuite/CompilationSamples/GraphWPF.pas
View file

@ -58,7 +58,6 @@ type
//{{{--doc: Конец секции 1 }}}
function GetBrush(c: Color): GBrush;
function GetFontFamily(name: string): FontFamily;
@ -630,20 +629,8 @@ procedure __FinalizeModule__;
implementation
var BrushesDict := new Dictionary<Color,GBrush>;
var FontFamiliesDict := new Dictionary<string,FontFamily>;
function GetBrush(c: Color): GBrush;
begin
if not (c in BrushesDict) then
begin
var b := new SolidColorBrush(c);
BrushesDict[c] := b;
Result := b
end
else Result := BrushesDict[c];
end;
function GetFontFamily(name: string): FontFamily;
begin
if not (name in FontFamiliesDict) then
@ -1494,6 +1481,7 @@ type
Pen.Color := Colors.Black;
var n := Round(w / 1);
if n<=0 then exit;
var pp := PartitionPoints(a, b, n);
var fff: real -> Point := xx -> Pnt(x + mx * (xx - a), y + my * (max - f(xx).Clamp(min,max)));
//pp.Select(x->(x,f(x))).PrintLines;
@ -1523,8 +1511,11 @@ procedure DrawGraph(f: real -> real; a, b, min, max: real; title: string) := Dra
procedure DrawGraph(f: real -> real; a, b: real; x, y, w, h: real; title: string);
begin
var n := Round(w / 1);
var q := PartitionPoints(a, b, n);
DrawGraph(f, a, b, q.Min(f), q.Max(f), x, y, w, h, title)
if n<=0 then exit;
var q := PartitionPoints(a, b, n).ToArray;
var mi := q.Min(f);
var ma := q.Max(f);
DrawGraph(f, a, b, mi, ma, x, y, w, h, title);
end;
procedure DrawGraph(f: real -> real; a, b: real; r: GRect; title: string) := DrawGraph(f, a, b, r.X, r.Y, r.Width, r.Height, title);
@ -1929,8 +1920,13 @@ GraphWPFWindow = class(GMainWindow)
public
procedure InitMainGraphControl; override;
begin
var g := Content as DockPanel;
host1 := new Canvas;
host := new MyVisualHost();
// Попытка отсекать рисование частей объектов за пределами host. Актуально при наличии панелей.
// К сожалению, почему-то при использовании WPFObjects объекты GraphWPF становятся не видны
// Выход - в WPFObjects host1.ClipToBounds := False
host1.ClipToBounds := True;
host1.SizeChanged += (s,e) ->
begin
@ -1938,7 +1934,6 @@ public
host.DataContext := sz;
end;
// Всегда последнее
var g := MainPanel;
var dpiXProperty := typeof(SystemParameters).GetProperty('DpiX', BindingFlags.NonPublic or BindingFlags.Static);
var dpiYProperty := typeof(SystemParameters).GetProperty('Dpi', BindingFlags.NonPublic or BindingFlags.Static);
@ -1952,6 +1947,8 @@ public
RTbmap := new RenderTargetBitmap(Round(SystemParameters.PrimaryScreenWidth * scalex), Round(SystemParameters.PrimaryScreenHeight * scaley), dpiX, dpiY, PixelFormats.Pbgra32);
im.Source := RTbmap;
// Рисуем на host
// Когда накопится много объектов, переносим их на im
host1.Children.Add(im);
host1.Children.Add(host);
@ -2004,7 +2001,7 @@ begin
app.Dispatcher.UnhandledException += (o, e) -> begin
Println(e.Exception.Message);
if e.Exception.InnerException<>nil then
if e.Exception.InnerException <> nil then
Println(e.Exception.InnerException.Message);
halt;
end;

21
TestSuite/CompilationSamples/GraphWPFBase.pas
View file

@ -11,12 +11,14 @@ unit GraphWPFBase;
uses System.Windows;
uses System.Windows.Controls;
uses System.Windows.Media;
type
/// Тип цвета
GColor = System.Windows.Media.Color;
/// Тип прямоугольника
GRect = System.Windows.Rect;
GBrush = System.Windows.Media.Brush;
GWindow = System.Windows.Window;
GMainWindow = class(GWindow)
@ -56,6 +58,19 @@ var
app: Application;
MainWindow: GMainWindow;
var BrushesDict := new Dictionary<GColor,GBrush>;
function GetBrush(c: GColor): GBrush;
begin
if not (c in BrushesDict) then
begin
var b := new SolidColorBrush(c);
BrushesDict[c] := b;
Result := b
end
else Result := BrushesDict[c];
end;
procedure Invoke(d: System.Delegate; params args: array of object) := app.Dispatcher.Invoke(d, args);
procedure InvokeP(p: procedure(r: real); r: real) := Invoke(p,r);
@ -108,7 +123,7 @@ type
property IsFixedSize: boolean read GetFixedSize write SetFixedSize;
/// Очищает графическое окно белым цветом
procedure Clear; virtual;
/// Очищает графическое окно цветом c
/// Очищает графическое окно указанным цветом
procedure Clear(c: GColor); virtual;
/// Устанавливает размеры клиентской части главного окна
procedure SetSize(w, h: real);
@ -303,6 +318,8 @@ begin
end;
end;
begin
initialization
__InitModule;
finalization
end.

1330
TestSuite/CompilationSamples/OpenCL.pas
View file

File diff suppressed because it is too large Load diff

4089
TestSuite/CompilationSamples/OpenCLABC.pas
View file

File diff suppressed because it is too large Load diff

3326
TestSuite/CompilationSamples/OpenGL.pas
View file

File diff suppressed because it is too large Load diff

4
TestSuite/CompilationSamples/OpenGLABC.pas
View file

@ -1,5 +1,4 @@

///
///
///Модуль, зарезервированный для высокоуровневой оболочки модуля OpenGL
///
unit OpenGLABC;
@ -7,6 +6,7 @@ unit OpenGLABC;
interface
uses OpenGL;
uses OpenGLABCBase;
implementation

59
TestSuite/CompilationSamples/PABCSystem.pas
View file

@ -1760,7 +1760,7 @@ function CplxFromPolar(magnitude, phase: real): Complex;
/// Возвращает квадратный корень из комплексного числа
function Sqrt(c: Complex): Complex;
/// Возвращает модуль комплексного числа
function Abs(c: Complex): Complex;
function Abs(c: Complex): real;
/// Возвращает комплексно сопряженное число
function Conjugate(c: Complex): Complex;
/// Возвращает косинус комплексного числа
@ -1941,7 +1941,7 @@ function TryReadIntegerFromString(s: string; var from: integer; var res: integer
function TryReadRealFromString(s: string; var from: integer; var res: real): boolean;
///-procedure Val(s: string; var value: число; var err: integer);
/// Преобразует строковое представление s целого числа к числовому значению и записывает его в переменную value.
/// Преобразует строковое представление s целого или вещественного числа к числовому значению и записывает его в переменную value.
///Если преобразование успешно, то err=0, иначе err>0
procedure Val(s: string; var value: integer; var err: integer);
///--
@ -2122,6 +2122,9 @@ procedure Reverse(var s: string);
procedure Reverse(var s: string; index, count: integer);
/// Перемешивает динамический массив случайным образом
procedure Shuffle<T>(a: array of T);
/// Возвращает, совпадают ли массивы
function ArrEqual<T>(a, b: array of T): boolean;
/// Сравнивает матрицы на равенство
function MatrEqual<T>(a, b: array [,] of T): boolean;
/// Перемешивает список случайным образом
@ -2224,6 +2227,13 @@ function ArrGen<T>(count: integer; first, second: T; next: (T,T) ->T): array of
/// Возвращает массив из count элементов x
function ArrFill<T>(count: integer; x: T): array of T;
// Возвращает массив из элементов массива a, удовлетворяющих условию condition
// a.FindAll
//function ArrFilter<T>(a: array of T; condition: T->boolean): array of T;
// Возвращает по массиву a массив, преобразованный по правилу convert
// a.ConvertAll
//function ArrTransform<T,T1>(a: array of T; convert: T->T1): array of T1;
/// Возвращает массив из n целых, введенных с клавиатуры
function ReadArrInteger(n: integer): array of integer;
/// Возвращает массив из n целых int64, введенных с клавиатуры
@ -2247,8 +2257,6 @@ function ReadArrReal(prompt: string; n: integer): array of real;
/// Выводит приглашение к вводу и возвращает массив из n строк, введенных с клавиатуры
function ReadArrString(prompt: string; n: integer): array of string;
/// Возвращает, совпадают ли массивы
function ArrEqual<T>(a, b: array of T): boolean;
// -----------------------------------------------------
//>> Подпрограммы для создания двумерных динамических массивов # Subroutines for matrixes
@ -4537,9 +4545,9 @@ end;
function Range(a, b: real; n: integer): sequence of real;
begin
if n = 0 then
raise new System.ArgumentException('n=0');
raise new System.ArgumentException('Range: n=0');
if n < 0 then
raise new System.ArgumentException('n<0');
raise new System.ArgumentException('Range: n<0');
var r := a;
var h := (b - a) / n;
for var i := 0 to n do
@ -4732,31 +4740,28 @@ begin
Result := a;
end;
{function ListWhile<T>(first: T; next: Func<T,T>; pred: Predicate<T>): List<T>;
{function ArrTransform<T,T1>(a: array of T; convert: T->T1): array of T1;
begin
var a := new List<T>;
var x := first;
while pred(x) do
begin
a.Add(x);
x := next(x);
end;
Result := a;
var n := a.Length;
var a1 := new T1[n];
for var i:=0 to n-1 do
a1[i] := convert(a[i]);
Result := a1;
end;
function ListWhile<T>(first,second: T; next: Func2<T,T,T>; pred: Predicate<T>): List<T>;
function ArrFilter<T>(a: array of T; condition: T->boolean): array of T;
begin
var a := new List<T>;
var x := first;
var y := second;
while pred(x) do
begin
a.Add(x);
var z := next(x,y);
x := y;
y := z;
end;
Result := a;
var n := a.Length;
var a1 := new T[n];
var j := 0;
for var i:=0 to n-1 do
if condition(a[i]) then
begin
a1[j] := a[i];
j += 1;
end;
SetLength(a1,j);
Result := a1;
end;}
function ArrFill<T>(count: integer; x: T): array of T;

91
TestSuite/CompilationSamples/SF.pas
View file

@ -11,6 +11,7 @@ function RI64 := ReadInt64;
function RR := ReadReal;
function RC := ReadChar;
function RS := ReadString;
function RL := ReadLexem;
function RlnI := ReadlnInteger;
function RlnBI := ReadlnBigInteger;
@ -68,36 +69,126 @@ function Prln(Self: char): char; extensionmethod := Self.Println;
function Prln(Self: boolean): boolean; extensionmethod := Self.Println;
function Prln(Self: string): string; extensionmethod := Self.Println;
/// Записывает в min значение x если x<min
procedure ReMin(var min: integer; x: integer);
begin
if x < min then
min := x
end;
/// Записывает в max значение x если x>max
procedure ReMax(var max: integer; x: integer);
begin
if x > max then
max := x
end;
/// Записывает в min значение x если x<min
procedure ReMin(var min: real; x: real);
begin
if x < min then
min := x
end;
/// Записывает в max значение x если x>max
procedure ReMax(var max: real; x: real);
begin
if x > max then
max := x
end;
/// Преобразует строку в целое
function ToI(Self: string); extensionmethod := Self.ToInteger;
/// Преобразует строку в вещественное
function ToR(Self: string); extensionmethod := Self.ToReal;
/// Преобразует строку в массив целых
function ToIs(Self: string); extensionmethod := Self.ToIntegers;
/// Преобразует строку в массив вещественных
function ToRs(Self: string); extensionmethod := Self.ToReals;
function operator-(c,c1: char): integer; extensionmethod := Ord(c) - Ord(c1);
/// Возвращает длину строки
function Len(Self: string): integer; extensionmethod := Self.Length;
/// Возвращает длину массива
function Len<T>(Self: array of T): integer; extensionmethod := Self.Length;
/// Возвращает среднее элементов последовательности
function Av(Self: sequence of integer): real; extensionmethod := Self.Average;
/// Возвращает среднее элементов последовательности
function Av(Self: sequence of real): real; extensionmethod := Self.Average;
function Dst<T>(Self: sequence of T): sequence of T; extensionmethod := Self.Distinct;
function Ord<T>(Self: sequence of T): sequence of T; extensionmethod := Self.Order;
function OrdD<T>(Self: sequence of T): sequence of T; extensionmethod := Self.OrderDescending;
/// Преобразует последовательность в строку
function Str<T>(Self: sequence of T): string; extensionmethod := Self.JoinToString;
/// Выводит последовательность, разделяя элементы пробелами
function Pr<T>(Self: sequence of T): sequence of T; extensionmethod := Self.Print;
/// Выводит последовательность, разделяя элементы пробелами, и переходит на новую строку
function Prln<T>(Self: sequence of T): sequence of T; extensionmethod := Self.Println;
/// Возвращает инвертированную последовательность
function Rev<T>(Self: sequence of T): sequence of T; extensionmethod := Self.Reverse;
/// Преобразует последовательность, используя функцию transform
function Sel<T,T1>(Self: sequence of T; transform: T->T1): sequence of T1; extensionmethod := Self.Select(transform);
/// Фильтрует последовательность по условию cond
function Wh<T>(Self: sequence of T; cond: T->boolean): sequence of T; extensionmethod := Self.Where(cond);
/// Преобразует последовательность в массив
function ToA<T>(Self: sequence of T): array of T; extensionmethod := Self.ToArray;
/// Преобразует последовательность в список
function ToL<T>(Self: sequence of T): List<T>; extensionmethod := Self.ToList;
/// Преобразует последовательность в HashSet
function ToHS<T>(Self: sequence of T): HashSet<T>; extensionmethod := Self.ToHashSet;
/// Преобразует последовательность в SortedSet
function ToSS<T>(Self: sequence of T): SortedSet<T>; extensionmethod := Self.ToSortedSet;
/// Преобразует последовательность в HashSet
function HS<T>(s: sequence of T): HashSet<T> := s.ToHashSet;
/// Преобразует последовательность в SortedSet
function SS<T>(s: sequence of T): SortedSet<T> := s.ToSortedSet;
/// Инвертирует последовательность
procedure Rev<T>(a: array of T) := Reverse(a);
/// Возвращает индекс минимального элемента
function IMin<T>(Self: array of T): integer; extensionmethod; where T: IComparable<T>;
begin
Result := Self.IndexMin;
end;
/// Возвращает индекс максимального элемента
function IMax<T>(Self: array of T): integer; extensionmethod; where T: IComparable<T>;
begin
Result := Self.IndexMax;
end;
/// Возвращает True если массивы равны
function Eq<T>(Self,b: array of T): boolean; extensionmethod := Self.ArrEqual(b);
/// Возвращает в виде массива все элементы, удовлетворяющие cond
function Filt<T>(Self: array of T; cond: T->boolean): array of T; extensionmethod := Self.FindAll(cond);
/// Возвращает массив с элементами, преобразованными по правилу transform
function Tr<T>(Self: array of T; transform: T->T): array of T; extensionmethod := Self.ConvertAll(transform);
/// Преобразует массив по правилу transform
procedure Tr<T>(a: array of T; transform: T->T) := a.Transform(transform);
/// Возвращает индекс последнего элемента массива
function H<T>(Self: array of T): integer; extensionmethod := Self.High;
end.

1
TestSuite/CompilationSamples/Timers.pas
View file

@ -38,6 +38,7 @@ type
property TimerProc: ()->() read _procedure write _procedure;
end;
/// Создать и запустить таймер, вызывающий процедуру TimerProc каждые ms миллисекунд
function CreateTimerAndStart(ms: integer; TimerProc: procedure): Timer;
implementation

17
TestSuite/CompilationSamples/WPFObjects.pas
View file

@ -140,6 +140,19 @@ type
begin
Result := l.GetEnumerator;
end;
/// Очистить список игровых объектов
procedure Clear;
begin
for var i:=Count-1 downto 0 do
Destroy(Items[i]);
end;
/// Удалить все игровые объекты, удовлетворяющие условию
procedure DestroyAll(condition: ObjectWPF -> boolean);
begin
for var i := Count - 1 downto 0 do
if condition(Items[i]) then
Destroy(Items[i]);
end;
end;
@ -404,6 +417,8 @@ type
begin
Result := (Left < 0) or (Top < 0) or (Right > GraphWindow.Width) or (Bottom > GraphWindow.Height);
end;
/// Tag хранит любые присоединённые характеристики объекта
auto property Tag: object;
end;
// -----------------------------------------------------
@ -1595,12 +1610,14 @@ begin
GraphWindow := GraphWPF.GraphWindow;
host := new Canvas();
host.ClipToBounds := True;
{host.SizeChanged += (s,e) ->
begin
var sz := e.NewSize;
host.DataContext := sz;
end;}
var g := MainWindow.Content as DockPanel;
(g.children[0] as Canvas).ClipToBounds := False; // SSM 04/08/20 - возвращаем в False иначе графику GraphWPF становится не видно
g.children.Add(host); // Слой графики WPF - последний
end;
app.Dispatcher.Invoke(AdditionalInit);

40
TestSuite/CompilationSamples/graph3d.pas
View file

@ -2206,15 +2206,15 @@ type
procedure SetN(n: integer);
function GetN: integer;
protected
function CreateObject: Object3D; override := new PrismT(X, Y, Z, N, Radius, Height, Material.Clone);
function CreateObject: Object3D; override := new PrismT(X, Y, Z, Sides, 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;
/// Количество боковых граней правильной призмы
property Sides: integer read GetN write SetN;
/// Возвращает клон правильной призмы
function Clone := (inherited Clone) as PrismT;
end;
@ -2226,15 +2226,15 @@ type
PyramidT = class(PrismT)
private
protected
function CreateObject: Object3D; override := new PyramidT(X, Y, Z, N, Radius, Height, Material.Clone);
function CreateObject: Object3D; override := new PyramidT(X, Y, Z, Sides, 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;
/// Количество боковых граней правильной пирамиды
property Sides: integer read GetN write SetN;
/// Возвращает клон правильной пирамиды
function Clone := (inherited Clone) as PyramidT;
end;
@ -2288,8 +2288,8 @@ type
begin
var pc := new Point3DCollection;
var a := PartitionPoints(0, 2 * Pi, N).Select(x -> P3D(fr * cos(x), fr * sin(x), 0)).ToArray;
var b := PartitionPoints(0, 2 * Pi, N).Select(x -> P3D(fr * cos(x), fr * sin(x), fh)).ToArray;
var a := PartitionPoints(0, 2 * Pi, Sides).Select(x -> P3D(fr * cos(x), fr * sin(x), 0)).ToArray;
var b := PartitionPoints(0, 2 * Pi, Sides).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]);
@ -2320,12 +2320,12 @@ type
end;
protected
function CreateObject: Object3D; override := new PrismTWireframe(X, Y, Z, N, Radius, Height, (model as LinesVisual3D).Thickness, (model as LinesVisual3D).Color);
function CreateObject: Object3D; override := new PrismTWireframe(X, Y, Z, Sides, Radius, Height, (model as LinesVisual3D).Thickness, (model as LinesVisual3D).Color);
public
function Points: Point3DCollection; virtual;
begin
var a := PartitionPoints(0, 2 * Pi, N).Select(x -> P3D(fr * cos(x), fr * sin(x), 0)).SkipLast;
var b := PartitionPoints(0, 2 * Pi, N).Select(x -> P3D(fr * cos(x), fr * sin(x), fh)).SkipLast;
var a := PartitionPoints(0, 2 * Pi, Sides).Select(x -> P3D(fr * cos(x), fr * sin(x), 0)).SkipLast;
var b := PartitionPoints(0, 2 * Pi, Sides).Select(x -> P3D(fr * cos(x), fr * sin(x), fh)).SkipLast;
var pc := new Point3DCollection(a + b);
Result := pc;
@ -2338,8 +2338,8 @@ type
property Radius: real read fr write SetR;
/// Высота проволочной правильной призмы
property Height: real read fh write SetH;
/// Количество углов проволочной правильной призмы
property N: integer read fn write SetN;
/// Количество боковых граней проволочной правильной призмы
property Sides: integer read fn write SetN;
/// Цвет проволоки правильной призмы
property Color: GColor read GetC write SetC; override;
/// Толщина проволоки правильной призмы
@ -2352,13 +2352,13 @@ type
/// Класс проволочной правильной пирамиды
PyramidTWireframe = class(PrismTWireframe)
protected
function CreateObject: Object3D; override := new PyramidTWireframe(X, Y, Z, N, Radius, Height, (model as LinesVisual3D).Thickness, (model as LinesVisual3D).Color);
function CreateObject: Object3D; override := new PyramidTWireframe(X, Y, Z, Sides, Radius, Height, (model as LinesVisual3D).Thickness, (model as LinesVisual3D).Color);
private
function CreatePoints: Point3DCollection; override;
begin
var pc := new Point3DCollection;
var a := PartitionPoints(0, 2 * Pi, N).Select(x -> P3D(fr * cos(x), fr * sin(x), 0)).ToArray;
var a := PartitionPoints(0, 2 * Pi, Sides).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
@ -2377,8 +2377,8 @@ type
property Radius: real read fr write SetR;
/// Высота проволочной правильной пирамиды
property Height: real read fh write SetH;
/// Количество углов проволочной правильной пирамиды
property N: integer read fn write SetN;
/// Количество боковых граней проволочной правильной пирамиды
property Sides: integer read fn write SetN;
/// Цвет проволоки правильной пирамиды
property Color: GColor read GetC write SetC; override;
/// Толщина проволоки правильной пирамиды
@ -3373,15 +3373,15 @@ function FileModel3D(p: Point3D; fname: string; m: Material): FileModelT := File
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 Prism(p: Point3D; Sides: integer; Height, Radius: real; m: Material): PrismT := Prism(p.X, p.Y, p.Z, Sides, Height, Radius, 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 PrismWireFrame(p: Point3D; Sides: integer; Height, Radius: real; Thickness: real; c: Color): PrismTWireFrame := PrismWireFrame(p.x, p.y, p.z, Sides, Height, Radius, 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 Pyramid(p: Point3D; Sides: integer; Height, Radius: real; m: Material): PyramidT := Pyramid(p.X, p.Y, p.Z, Sides, Height, Radius, 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));

13
TestSuite/asT.pas Normal file
View file

@ -0,0 +1,13 @@
type
t1 = class end;
procedure p1<T>; where T: class;
begin
var a := new t1;
var b := a as T;
Assert(b <> nil);
end;
begin
p1&<t1>();
end.

18
TestSuite/class_interf.pas Normal file
View file

@ -0,0 +1,18 @@
type
i1 = interface
procedure p;
end;
c1 = abstract class(i1)
public
procedure p;
begin
Assert(111=111);
end;
end;
c2 = sealed class(c1) end;
begin
var a := new c2 as i1;
a.P
end.

9
TestSuite/opImplicit.pas Normal file
View file

@ -0,0 +1,9 @@
type
t1<T> = class
static function operator implicit(o: T): t1<T> := new t1<T>;
end;
begin
var a: t1<string> := 'abcde';
Assert(a <> nil);
end.

5
TreeConverter/LambdaExpressions/Closure/CapturedVariablesTreeBuilder.cs
View file

@ -69,6 +69,11 @@ namespace TreeConverter.LambdaExpressions.Closure
// Не обходить проверочные узлы в визиторе строительства дерева - SSM 1.05.17
}
public override void visit(assign_var_tuple assvartup)
{
_visitor.ProcessNode(assvartup);
}
public override void visit(var_def_statement varDefStmt)
{
if (varDefStmt.inital_value != null)

10
TreeConverter/TreeConversion/convertion_data_and_alghoritms.cs
View file

@ -1561,6 +1561,16 @@ namespace PascalABCCompiler.TreeConverter
return eq_type_nodes(tn1, tn2, false);
}
public static bool type_or_base_type_implements_interface(type_node tn, type_node interf)
{
do {
if (tn.ImplementingInterfaces.Contains(interf))
return true;
tn = tn.base_type;
} while (tn != null);
return false;
}
//Этот метод сверяет не только параметры, но и возвращаемое значение
public static bool function_eq_params_and_result(function_node left, function_node right, bool weak = false)
{

223
TreeConverter/TreeConversion/syntax_tree_visitor.cs
View file

@ -3066,6 +3066,7 @@ namespace PascalABCCompiler.TreeConverter
weak_node_test_and_visit(_interface_node.interface_definitions);
}
public override void visit(SyntaxTree.typecast_node node)
{
@ -3086,12 +3087,16 @@ namespace PascalABCCompiler.TreeConverter
AddError(loc, "OPERATOR_{0}_CAN_NOT_BE_APPLIED_TO_POINTER_TYPE", compiler_string_consts.as_name);
}
else
if (!(type_table.is_derived(en.type, tp) || type_table.is_derived(tp, en.type) || en.type == tp || en.type == SystemLibrary.SystemLibrary.object_type
|| en.type.IsInterface || tp.IsInterface))
if (!(type_table.is_derived(en.type, tp) || type_table.is_derived(tp, en.type)
|| en.type == tp || en.type == SystemLibrary.SystemLibrary.object_type
|| en.type.IsInterface || tp.IsInterface || tp.is_generic_parameter)
)
{
AddError(loc, "EXPECTED_DERIVED_CLASSES");
}
if (en.type.IsSealed && tp.IsInterface && !en.type.ImplementingInterfaces.Contains(tp))
if (en.type.IsSealed && tp.IsInterface && /*!en.type.ImplementingInterfaces.Contains(tp)*/
!convertion_data_and_alghoritms.type_or_base_type_implements_interface(en.type,tp)
)
{
AddError(loc, "CAN_NOT_CONVERT_TYPE_{0}_TO_INTERFACE_{1}", en.type.PrintableName, tp.PrintableName);
}
@ -10583,6 +10588,8 @@ namespace PascalABCCompiler.TreeConverter
foreach (SyntaxTree.expression expr in cv.conditions.expressions)
{
expression_node cn = convert_strong(expr);
if (cn.type == SystemLibrary.SystemLibrary.char_type)
cn = convertion_data_and_alghoritms.convert_type(cn, SystemLibrary.SystemLibrary.string_type);
if (cn.type != SystemLibrary.SystemLibrary.string_type)
AddError(new CanNotConvertTypes(cn, cn.type, SystemLibrary.SystemLibrary.string_type, cn.location));
string_const_node scn = convert_string_const_to_switch(cn, cn.location);
@ -16384,6 +16391,15 @@ namespace PascalABCCompiler.TreeConverter
if (_var_def_statement.vars_type != null)
{
tn = convert_strong(_var_def_statement.vars_type);
if (tn.type_special_kind != SemanticTree.type_special_kind.array_kind &&
tn.type_special_kind != SemanticTree.type_special_kind.array_wrapper &&
!tn.BaseFullName.StartsWith("System.Tuple") &&
_var_def_statement.inital_value is SyntaxTree.array_const ac)
{
AddError(get_location(_var_def_statement), "IMPOSSIBLE_TO_CONVERT_ARRAY_CONST_TO_{0}", tn);
}
//LambdaHelper.InferTypesFromVarStmt(tn, _var_def_statement.inital_value as SyntaxTree.function_lambda_definition, this); //lroman//
if (tn.IsStatic && _var_def_statement.vars.idents[0].name != YieldHelpers.YieldConsts.Self) // SSM 10/07/19 fix #1639 в статическом классе можно только фиктивное поле с именем YieldHelpers.YieldConsts.Self описать - для того чтобы посмотреть на семантике его тип!!!
AddError(get_location(_var_def_statement), "VARIABLES_OF_STATIC_CLASS_NOT_ALLOWED");
@ -17439,6 +17455,44 @@ namespace PascalABCCompiler.TreeConverter
throw new NotSupportedError(get_location(_expression));
}
public void visit_statement_list_internal(SyntaxTree.statement_list _statement_list)
{
statements_list stl = new statements_list(get_location(_statement_list), get_location_with_check(_statement_list.left_logical_bracket), get_location_with_check(_statement_list.right_logical_bracket));
for (var i = 0; i < _statement_list.subnodes.Count; i++) // SSM 13.10.16 - поменял т.к. собираюсь менять узлы в процессе обхода
{
statement syntax_statement = _statement_list.subnodes[i];
try
{
statement_node semantic_statement = convert_strong(syntax_statement);
if (semantic_statement != null)
{
if (stl.statements.Count > 0 && stl.statements[0] is basic_function_call && i == 2)
{
base_function_call bfc = stl.statements[0] as basic_function_call;
if (bfc.type != null && bfc.type.name.Contains("<>local_variables_class") && (semantic_statement is compiled_constructor_call || semantic_statement is common_constructor_call)
&& !context.converted_func_stack.Empty && context.converted_func_stack.top() is common_method_node && (context.converted_func_stack.top() as common_method_node).is_constructor)
stl.statements.AddElementFirst(semantic_statement);
else
stl.statements.AddElement(semantic_statement);
}
else
stl.statements.AddElement(semantic_statement);
}
context.allow_inherited_ctor_call = false;
}
catch (Errors.Error ex)
{
if (ThrowCompilationError || ex is MemberIsNotDeclaredInType || ex is UndefinedNameReference)//TODO: add interface
throw ex;
else
ErrorsList.Add(ex);
}
}
return_value(stl);
}
public override void visit(SyntaxTree.statement_list _statement_list)
{
#region MikhailoMMX, обработка omp parallel section
@ -20658,89 +20712,186 @@ namespace PascalABCCompiler.TreeConverter
ProcessNode(av.new_addr_value); // обойти десахарное
}
private void CheckUnpacking(expression ex, out expression_node sem_ex, out bool IsTuple, out bool IsSequence, int countvars, syntax_tree_node stn)
{
sem_ex = convert_strong(ex);
sem_ex = convert_if_typed_expression_to_function_call(sem_ex);
var t = ConvertSemanticTypeNodeToNETType(sem_ex.type);
if (t == null)
AddError(sem_ex.location, "TUPLE_OR_SEQUENCE_EXPECTED");
IsTuple = false;
IsSequence = false;
if (t.FullName.StartsWith("System.Tuple"))
IsTuple = true;
if (!IsTuple)
{
if (t.Name.Equals("IEnumerable`1") || t.GetInterface("IEnumerable`1") != null)
IsSequence = true;
}
if (!IsTuple && !IsSequence)
{
AddError(sem_ex.location, "TUPLE_OR_SEQUENCE_EXPECTED");
}
if (IsTuple)
{
if (countvars > t.GetGenericArguments().Count())
AddError(get_location(stn), "TOO_MANY_ELEMENTS_ON_LEFT_SIDE_OF_TUPLE_ASSIGNMRNT");
}
}
private addressed_value UnpackingExpr(int i, bool IsTuple, bool IsSequence, string tname)
{
addressed_value dn = null;
if (IsTuple)
dn = new dot_node(new ident(tname), new ident("Item" + (i + 1).ToString()));
else if (IsSequence)
{
dn = new dot_node(new ident(tname), new ident("ElementAt"));
var pars = new SyntaxTree.expression_list(new int32_const(i));
dn = new method_call(dn, pars);
}
return dn;
}
public override void visit(SyntaxTree.assign_tuple asstup) // сахарный узел
{
AddError(get_location(asstup), "SUGARED_NODE_{0}_IN_SYNTAX_TREE_VISITOR", asstup.GetType().Name);
//AddError(get_location(asstup), "SUGARED_NODE_{0}_IN_SYNTAX_TREE_VISITOR", asstup.GetType().Name);
/*semantic_check_assign_tuple(asstup);
CheckUnpacking(asstup.expr, out var sem_ex, out var IsTuple, out var IsSequence, asstup.vars.variables.Count(), asstup.vars);
var sem_node = new SyntaxTree.semantic_addr_value(sem_ex); // чтобы два раза не делать convert_strong
//semantic_check_assign_tuple(asstup.vars, asstup.expr);
var tname = "#temp_var" + UniqueNumStr();
//var tt = new var_statement(new ident(tname), new semantic_addr_value(expr)); // тут semantic_addr_value хранит на самом деле expr - просто неудачное название
var tt = new var_statement(new ident(tname), asstup.expr); // тут semantic_addr_value хранит на самом деле expr - просто неудачное название
var st = new statement_list(new SyntaxTree.empty_statement());
var tt = new var_statement(new ident(tname), sem_node /*asstup.expr*/); // тут semantic_addr_value хранит на самом деле expr - просто неудачное название
var st = new statement_list();
st.Add(tt);
var n = asstup.vars.variables.Count();
for (var i = 0; i < n; i++)
{
var a = new assign(asstup.vars.variables[i], new dot_node(new ident(tname),
new ident("Item" + (i + 1).ToString())), Operators.Assignment,
var a = new assign(asstup.vars.variables[i],
//new dot_node(new ident(tname), new ident("Item" + (i + 1).ToString())),
UnpackingExpr(i, IsTuple, IsSequence, tname),
Operators.Assignment,
asstup.vars.variables[i].source_context);
st.Add(a);
}
//visit(st);
// Замена 1 оператор на 1 оператор - всё OK
ReplaceUsingParent(asstup, st);*/
visit(st);
}
public override void visit(SyntaxTree.assign_var_tuple assvartup) // сахарный узел
{
AddError(get_location(assvartup), "SUGARED_NODE_{0}_IN_SYNTAX_TREE_VISITOR", assvartup.GetType().Name);
//AddError(get_location(assvartup), "SUGARED_NODE_{0}_IN_SYNTAX_TREE_VISITOR", assvartup.GetType().Name);
/*check_sugared(assvartup);
CheckUnpacking(assvartup.expr, out var sem_ex, out var IsTuple, out var IsSequence, assvartup.idents.idents.Count(), assvartup.idents);
/*var sem_ex = convert_strong(assvartup.expr);
sem_ex = convert_if_typed_expression_to_function_call(sem_ex);
var t = ConvertSemanticTypeNodeToNETType(sem_ex.type);
if (t == null)
AddError(sem_ex.location, "TUPLE_OR_SEQUENCE_EXPECTED");
var IsTuple = false;
var IsSequence = false;
if (t.FullName.StartsWith("System.Tuple"))
IsTuple = true;
if (!IsTuple)
{
if (t.Name.Equals("IEnumerable`1") || t.GetInterface("IEnumerable`1") != null)
IsSequence = true;
}
if (!IsTuple && !IsSequence)
{
AddError(sem_ex.location, "TUPLE_OR_SEQUENCE_EXPECTED");
}
if (IsTuple)
{
var nn = assvartup.idents.idents.Count();
if (nn > t.GetGenericArguments().Count())
AddError(get_location(assvartup.idents), "TOO_MANY_ELEMENTS_ON_LEFT_SIDE_OF_TUPLE_ASSIGNMRNT");
}*/
// В зависимости от типа выражения по-разному распаковывать
// Распаковывать можно только для кортежей или последовательностей
// if IsTuple ...
// if IsSequence ...
// else AddError(либо кортеж либо последовательность)
var sem_node = new SyntaxTree.semantic_addr_value(sem_ex); // чтобы два раза не делать convert_strong
//semantic_check_assign_var_tuple(assvartup.idents, sem_node /*assvartup.expr*/);
var tname = "#temp_var" + UniqueNumStr();
var tt = new var_statement(new ident(tname), assvartup.expr); // тут для assvartup.expr внутри повторно вызывается convert_strong, это плохо, но если там лямбда, то иначе - с semantic_addr_value - не работает!!!
//var tt = new var_statement(new ident(tname), new semantic_addr_value(expr)); // тут semantic_addr_value хранит на самом деле expr - просто неудачное название
//visit(tt); // обходится первый элемент - вместо asstup
var tt = new var_statement(new ident(tname), sem_node /*assvartup.expr*/);
var sl = new List<statement>();
sl.Add(new SyntaxTree.empty_statement());
sl.Add(tt); // он же помещается в новое синтаксическое дерево
var sl = new statement_list();
sl.Add(tt);
var n = assvartup.idents.idents.Count();
for (var i = 0; i < n; i++)
{
/*addressed_value dn = null;
if (IsTuple)
dn = new dot_node(new ident(tname), new ident("Item" + (i + 1).ToString()));
else if (IsSequence)
{
dn = new dot_node(new ident(tname), new ident("ElementAt"));
var pars = new SyntaxTree.expression_list(new int32_const(i));
dn = new method_call(dn,pars);
}*/
var rr = assvartup.idents.idents[i] as ident;
var a = new var_statement(rr,
new dot_node(new ident(tname),new ident("Item" + (i + 1).ToString())),
var a = new var_statement(rr,
//new dot_node(new ident(tname),new ident("Item" + (i + 1).ToString())),
//dn,
UnpackingExpr(i, IsTuple, IsSequence, tname),
assvartup.idents.idents[i].source_context
);
// Остальные элементы обходить не надо (!!!уже надо!) - они обходятся на следующих итерациях при обходе внешнего statement_list
//visit(a);
sl.Add(a);
}
ReplaceStatementUsingParent(assvartup, sl);*/
visit_statement_list_internal(sl);
}
public override void visit(var_tuple_def_statement vtd)
{
AddError(get_location(vtd), "SUGARED_NODE_{0}_IN_SYNTAX_TREE_VISITOR", vtd.GetType().Name);
//AddError(get_location(vtd), "SUGARED_NODE_{0}_IN_SYNTAX_TREE_VISITOR", vtd.GetType().Name);
// Состоит из var_def_statements. Некоторые являются var_tuple_def_statement
// Их надо найти и сделать несколько секций variable_definitions - без семантических проверок.
// Каждую var_tuple_def_statement надо заменить на assign_var_tuple - одну на секцию variable_definitions
// А потом оставшаяся часть визитора сделает семантические проверки
/*var tname = "#temp_var" + UniqueNumStr();
var vd = new List<var_def_statement>();
vd.Add(new semantic_check_sugared_var_def_statement_node(typeof(assign_var_tuple), new List<syntax_tree_node> { vtd.vars, vtd.inital_value }, vtd.source_context)); // Это нужно для проверок на этапе преобразования в семантику
visit(vd[0]);
CheckUnpacking(vtd.inital_value, out var sem_ex, out var IsTuple, out var IsSequence, vtd.vars.idents.Count(), vtd.vars);
var sem_node = new SyntaxTree.semantic_addr_value(sem_ex); // чтобы два раза не делать convert_strong
//semantic_check_assign_var_tuple(vtd.vars, vtd.inital_value);
var tname = "#temp_var" + UniqueNumStr();
//var vd = new List<var_def_statement>();
//vd.Add(new semantic_check_sugared_var_def_statement_node(typeof(assign_var_tuple), new List<syntax_tree_node> { vtd.vars, vtd.inital_value }, vtd.source_context)); // Это нужно для проверок на этапе преобразования в семантику
//visit(vd[0]);
var tt1 = new var_def_statement(new ident(tname), vtd.inital_value);
vd.Add(tt1);
ProcessNode(tt1);
var nn = vtd.vars.idents.Count();
for (var i = 0; i < nn; i++)
{
var a = new var_def_statement(vtd.vars.idents[i],
new dot_node(new ident(tname), new ident("Item" + (i + 1).ToString())),
UnpackingExpr(i, IsTuple, IsSequence, tname),
//new dot_node(new ident(tname), new ident("Item" + (i + 1).ToString())),
vtd.vars.idents[i].source_context);
vd.Add(a);
ProcessNode(a);
}
ReplaceVarTupleDefStatementUsingParent(vtd, vd);*/
}
public void ReplaceVarTupleDefStatementUsingParent(var_tuple_def_statement from, IEnumerable<var_def_statement> to)
{
foreach (var x in to)

1
TreeConverter/TreeRealization/generics.cs
View file

@ -1629,6 +1629,7 @@ namespace PascalABCCompiler.TreeRealization
{
cmn.return_variable = (orig_fn as common_function_node)?.return_variable;
}
cmn.IsOperator = orig_fn.IsOperator;
return cmn;
}

304
bin/Lib/Controls.pas
View file

@ -1,11 +1,11 @@
// Copyright (©) Ivan Bondarev, Stanislav Mikhalkovich (for details please see \doc\copyright.txt)
// This code is distributed under the GNU LGPL (for details please see \doc\license.txt)
///Модуль элементов управления для GraphWPF и WPFObjects
///Модуль элементов управления для GraphWPF, WPFObjects и Graph3D
unit Controls;
interface
uses GraphWPFBase,GraphWPF;
uses GraphWPFBase;
uses System.Windows;
uses System.Windows.Media;
uses System.Windows.Media.Imaging;
@ -24,6 +24,7 @@ type
GPanel = System.Windows.Controls.Panel;
GControl = System.Windows.Controls.Control;
GStatusBar = System.Windows.Controls.Primitives.StatusBar;
Orientation = System.Windows.Controls.Orientation;
MessageBox = System.Windows.MessageBox;
MessageBoxButton = System.Windows.MessageBoxButton;
MessageBoxResult = System.Windows.MessageBoxResult;
@ -33,8 +34,11 @@ type
Key = System.Windows.Input.Key;
var
ActivePanel: GPanel;
_ActivePanel: GPanel;
GlobalHMargin := 12;
function __ActivePanelInternal: GPanel;
procedure __SetActivePanelInternal(p: GPanel);
procedure Invoke(d: System.Delegate; params args: array of object);
procedure InvokeP(p: procedure(r: real); r: real);
@ -67,7 +71,8 @@ type
end;
DockPanel.SetDock(bb, d);
MainDockPanel.children.Insert(0, bb);
ActivePanel := p;
//ActivePanel := p;
__SetActivePanelInternal(p);
end;
procedure SetColorP(c: GColor);
begin
@ -75,15 +80,23 @@ type
bb.Background := p.Background
end;
function GetColorP := (p.Background as SolidColorBrush).Color;
procedure SetTTP(s: string);
begin
p.ToolTip := s;
end;
public
constructor Create(wh: real := 150; d: Dock := Dock.Left; c: Color := PanelsColor; internalMargin: real := 10);
begin
Invoke(CreateP,wh,d,c,internalMargin);
end;
/// Цвет
property Color: GColor read Invoke&<GColor>(GetColorP) write Invoke(SetColorP, value);
/// Ширина внутренней границы
property InternalMargin: real
read InvokeReal(()->p.Margin.Left)
write Invoke(procedure -> p.Margin := new System.Windows.Thickness(internalMargin), value);
/// Всплывающая подсказка
property Tooltip: string read Invokestring(()->p.ToolTip as string) write Invoke(SetTTP, value);
end;
/// Класс левой панели
@ -113,7 +126,7 @@ type
begin
element := el;
element.Focusable := False;
if ActivePanel is StackPanel(var sp) then
if __ActivePanelInternal is StackPanel(var sp) then
if sp.Orientation = Orientation.Vertical then
element.Margin := new Thickness(0,0,0,GlobalHMargin);
//else element.Margin := new Thickness(0,0,GlobalHMargin,0);
@ -124,12 +137,13 @@ type
end;
if width>0 then
element.Width := width;
ActivePanel.Children.Add(element);
__ActivePanelInternal.Children.Add(element);
end;
procedure SetWP(w: real) := element.Width := w;
procedure SetHP(h: real) := element.Height := h;
procedure SetMP(m: real) := element.Margin := new Thickness(0,0,0,m);
procedure SetTTP(s: string) := element.Tooltip := s;
procedure SetEP(enabled: boolean) := element.IsEnabled := enabled;
public
/// Ширина элемента управления
@ -140,6 +154,8 @@ type
property Margin: real read InvokeReal(()->element.Margin.Bottom) write Invoke(SetMP, value);
/// Активирован ли элемент управления
property Enabled: boolean read InvokeBoolean(()->element.IsEnabled) write Invoke(SetEP, value);
/// Всплывающая подсказка
property Tooltip: string read Invokestring(()->element.ToolTip as string) write Invoke(SetTTP, value);
end;
CommonControlWPF = class(CommonElementWPF)
@ -166,6 +182,35 @@ type
/// Событие нажатия на элемент управления
Click: procedure;
end;
StackPanelWPF = class(CommonControlWPF)
private
property sp: StackPanel read element as StackPanel;
procedure CreateP(Orient: Orientation; width,height: real);
begin
element := new StackPanel;
element.Focusable := False;
if width>0 then
element.Width := width;
if height>0 then
element.Height := height;
sp.Orientation := Orient;
__ActivePanelInternal.Children.Add(sp);
_ActivePanel := sp;
end;
procedure SetColorP(c: GColor);
begin
sp.Background := GetBrush(c);
end;
function GetColorP := (sp.Background as SolidColorBrush).Color;
procedure SetTTP(s: string);
begin
sp.ToolTip := s;
end;
public
constructor (Orient: Orientation; width: real := 0; height: real := 0) := Invoke(CreateP,Orient,width,height);
property Color: GColor read Invoke&<GColor>(GetColorP) write Invoke(SetColorP, value);
end;
/// Элемент управления "Изображение"
ImageWPF = class(CommonControlWPF)
@ -185,7 +230,6 @@ type
MainDockPanel.children.RemoveAt(MainDockPanel.children.Count-1);
MainDockPanel.children.Add(im);
end;
private
function GetNameP: string;
begin
Result := (im.Source as BitmapImage).UriSource.AbsolutePath
@ -234,7 +278,7 @@ type
procedure CreatePXY(x, y: real; Txt: string; width: real; fontsize: real);
begin
Init0(new GTextBlock, width, x, y);
Margin := 3;
//Margin := 3;
Text := Txt;
Self.FontSize := fontSize;
end;
@ -243,6 +287,8 @@ type
procedure SetTextP(t: string) := tb.Text := t;
procedure SetFontSizeP(sz: real) := tb.FontSize := sz;
procedure SetFontNameP(name: string) := tb.FontFamily := new FontFamily(name);
procedure SetTextWrappingP(value: boolean) := if value then tb.TextWrapping := TextWrapping.Wrap else
tb.TextWrapping := TextWrapping.NoWrap;
public
constructor Create(Txt: string; fontsize: real := 12):= Invoke(CreateP, Txt, fontsize);
constructor Create(x, y: real; Txt: string; width: real := 0; fontSize: real := 12):= Invoke(CreatePXY, x, y, Txt, width, fontSize);
@ -253,6 +299,9 @@ type
property FontSize: real read InvokeReal(()->tb.FontSize) write Invoke(SetFontSizeP, value); virtual;
/// Имя шрифта
property FontName: string write Invoke(SetFontNameP, value); virtual;
/// Включён ли режим переноса слов
property Wrapping: boolean read InvokeBoolean(()->tb.TextWrapping = TextWrapping.Wrap)
write Invoke(SetTextWrappingP, value); virtual;
end;
/// Элемент управления "Целое число"
@ -282,7 +331,7 @@ type
message: string;
procedure CreatePXY(x, y: real; message: string; width: real; initValue: real := 0; fontSize: real := 12);
begin
inherited CreatePXY(x,y,message + ' ' + initValue, width, fontSize);
inherited CreatePXY(x,y,message + ' ' + initValue.ToString(FracDigits), width, fontSize);
Self.message := message;
val := initValue;
end;
@ -351,7 +400,7 @@ type
/// Очистка текста в текстовом поле
procedure Clear := Text := '';
/// Разрешено ли ручное редактирование текста
property Focusable: boolean read InvokeBoolean(()->not element.Focusable) write Invoke(SetReadOnlyP,value);
property ReadOnly: boolean read InvokeBoolean(()->not element.Focusable) write Invoke(SetReadOnlyP,value);
end;
///!#
@ -366,6 +415,12 @@ type
else tb.Visibility := System.Windows.Visibility.Visible;
tb.Text := t;
end;
procedure SetTitleVisibilityP(v: boolean);
begin
if v then
tb.Visibility := System.Windows.Visibility.Visible
else tb.Visibility := System.Windows.Visibility.Collapsed;
end;
procedure SetHP(h: real) := MainElement.Height := h;
function CreateStackPanel(el: FrameworkElement; title: string): StackPanel;
@ -398,7 +453,10 @@ type
end;
public
/// Заголовок
property Title: string read InvokeString(()->tb.Text) write Invoke(SetTitleP, value);
property Title: string read InvokeString(()->tb.Text) write Invoke(SetTitleP, value); virtual;
/// Видим ли заголовок
property TitleVisible: boolean read InvokeBoolean(()->tb.Visibility <> System.Windows.Visibility.Collapsed)
write Invoke(SetTitleVisibilityP, value); virtual;
/// Высота элемента управления
property Height: real read InvokeReal(()->MainElement.ActualHeight) write Invoke(SetHP, value); override;
/// Размер шрифта
@ -420,21 +478,21 @@ type
Init1(new TextBox, title, width, x, y);
//tbx.TextWrapping := TextWrapping.Wrap;
tbx.Text := txt;
tbx.TextChanged += (o,e) -> if TextChanged <> nil then TextChanged;
tbx.TextChanged += (o,e) -> if ValueChanged <> nil then ValueChanged;
end;
procedure CreateAsMainControlP;
begin
element := CreateStackPanel(new TextBox,'');
Multiline := True;
tbx.TextChanged += (o,e) -> if TextChanged <> nil then TextChanged;
Wrapping := True;
tbx.TextChanged += (o,e) -> if ValueChanged <> nil then ValueChanged;
MainDockPanel.children.RemoveAt(MainDockPanel.children.Count-1);
MainDockPanel.children.Add(element);
end;
procedure CreateP(title,text: string) := CreatePXY(-1,-1,title,text,0);
constructor Create(i: integer) := Invoke(CreateAsMainControlP);
public
/// Событие "текст изменился"
TextChanged: procedure;
/// Событие "значение изменилось"
ValueChanged: procedure;
constructor Create(title: string := '') := Invoke(CreateP, title, '');
constructor Create(x,y: real; title: string := ''; width: real := 120) := Invoke(CreatePXY, x, y, title,'', width);
@ -442,8 +500,8 @@ type
procedure Clear := Text := '';
/// Текст в текстовом поле
property Text: string read InvokeString(()->tbx.Text) write Invoke(SetTextP, value);
/// Разрешено ли несколько строк в текстовом поле
property MultiLine: boolean read InvokeBoolean(()->tbx.TextWrapping = TextWrapping.Wrap) write Invoke(SetMultiLineP, value);
/// Включён ли режим переноса слов
property Wrapping: boolean read InvokeBoolean(()->tbx.TextWrapping = TextWrapping.Wrap) write Invoke(SetMultiLineP, value);
end;
/// Элемент управления "Целое поле"
@ -572,20 +630,23 @@ type
/// Событие, возникающее при изменении текущего выделения
SelectionChanged: procedure;
constructor Create(title: string := '') := Invoke(CreateP, title);
constructor Create(x,y: real; title: string := ''; width: real := 120) := Invoke(CreatePXY, x, y, title,'', width);
constructor Create(x,y: real; title: string := ''; width: real := 120) := Invoke(CreatePXY, x, y, title, width);
/// Добавляет элемент в список
procedure Add(s: string) := Invoke(AddP, s);
/// Добавляет набор элементов в список
procedure AddRange(params ss: array of string) := Invoke(AddRangeP, ss);
/// Выбранная строка
function SelectedString := InvokeString(()->cb.SelectedItem as string);
function SelectedText := InvokeString(()->cb.SelectedItem as string);
/// Индекс выбранной строки
function SelectedIndex := InvokeInteger(()->cb.SelectedIndex);
property Items[i: integer]: string read InvokeString(()->cb.Items[i] as string); default;
end;
/// Элемент управления "Слайдер"
SliderWPF = class(CommonControlWPF)
SliderBase = class(ControlWithTitleWPF)
private
function sl: Slider := element as Slider;
titl: string; // часть заголовка без числа
function sl: Slider := MainElement as Slider;
function GetMinimum: real := InvokeReal(()->sl.Minimum);
procedure SetMinimumP(r: real) := sl.Minimum := r;
procedure SetMinimum(r: real) := Invoke(SetMinimumP, r);
@ -598,11 +659,18 @@ type
function GetFrequency: real := InvokeReal(()->sl.TickFrequency);
procedure SetFrequencyP(r: real) := sl.TickFrequency := r;
procedure SetFrequency(r: real) := Invoke(SetFrequencyP, r);
protected
procedure CreatePXY(x,y: real; min, max, val, freq: real; width: real);
private
procedure CreatePXY(x,y: real; title: string; min, max, val, freq: real; width: real);
begin
Init0(new Slider,width,x,y);
sl.ValueChanged += procedure(o, e) -> ValueChangedP;
Init1(new Slider,title,width,x,y);
Remainder(title,min, max, val, freq);
end;
procedure Remainder(tit: string; min, max, val, freq: real);
begin
titl := tit;
sl.ValueChanged += procedure(o, e) -> if ValueChanged <> nil then ValueChanged;
sl.ValueChanged += procedure(o, e) -> if title <> '' then tb.Text := Title + ' ' + sl.Value;
if titl <> '' then tb.Text := Title + ' ' + sl.Value;
sl.TickPlacement := System.Windows.Controls.Primitives.TickPlacement.BottomRight;
sl.Minimum := min;
sl.Maximum := max;
@ -611,15 +679,62 @@ type
sl.TickFrequency := (max-min)/10
else sl.TickFrequency := freq;
sl.Foreground := Brushes.Black;
sl.IsSnapToTickEnabled := True;
end;
procedure CreateP(title: string; min, max, val, freq: real) := CreatePXY(-1, -1, title, min, max, val, freq, 0);
procedure SetTitleP1(tit: string);
begin
titl := tit;
SetTitleP(tit +' ' + sl.Value);
end;
procedure CreateP(min, max, val, freq: real) := CreatePXY(-1,-1,min, max, val, freq, 0);
procedure ValueChangedP := if ValueChanged <> nil then ValueChanged;
public
/// Событие, возникающее при изменении значения
ValueChanged: procedure;
constructor Create(min, max: real; val: real := real.MinValue; freq: real := 0) := Invoke(CreateP, min, max, val, freq);
constructor Create(x,y: real; min, max: real; width: real; val: real := real.MinValue; freq: real := 0) := Invoke(CreatePXY, x,y,min, max, val, freq, width);
/// Заголовок
property Title: string read InvokeString(()->titl) write Invoke(SetTitleP1, value); override;
end;
/// Элемент управления "Слайдер" с целыми значениями
SliderWPF = class(SliderBase)
private
procedure CreatePXYI(x,y: real; title: string; min, max, val, freq: integer; width: integer);
begin
Init1(new Slider,title,width,x,y);
if freq<=0 then
freq := (max-min) div 10;
if freq = 0 then
freq := 1;
Remainder(title,min, max, val, freq);
end;
procedure CreatePI(title: string; min, max, val, freq: integer) := CreatePXYI(-1, -1, title, min, max, val, freq, 0);
public
constructor Create(min, max: integer; val: integer := integer.MinValue; freq: integer := 0)
:= Invoke(CreatePI, '', min, max, val, freq);
constructor Create(title: string := '');
begin
Create(title, 0, 10, 0);
end;
constructor Create(title: string; min, max: integer; val: integer := integer.MinValue; freq: integer := 0)
:= Invoke(CreatePI, title, min, max, val, freq);
constructor Create(x,y: real; title: string; min, max: integer; width: integer; val: integer := integer.MinValue; freq: integer := 0)
:= Invoke(CreatePXYI, x,y,title,min, max, val, freq, width);
/// Минимальное значение
property Minimum: integer read GetMinimum.Round write SetMinimum(value);
/// Максимальное значение
property Maximum: integer read GetMaximum.Round write SetMaximum(value);
/// Текущее значение
property Value: integer read GetValue.Round write SetValue(value);
/// Интервал между делениями
property Frequency: integer read GetFrequency.Round write SetFrequency(value);
end;
/// Элемент управления "Слайдер" с вещественными значениями
SliderRealWPF = class(SliderBase)
public
constructor Create(min, max: real; val: real := real.MinValue; freq: real := 0) := Invoke(CreateP, '', min, max, val, freq);
constructor Create(title: string := '') := Create(title, 0, 10, 0);
constructor Create(title: string; min, max: real; val: real := real.MinValue; freq: real := 0) := Invoke(CreateP, title, min, max, val, freq);
constructor Create(x,y: real; title: string; min, max: real; width: real; val: real := real.MinValue; freq: real := 0) := Invoke(CreatePXY, x,y,title,min, max, val, freq, width);
/// Минимальное значение
property Minimum: real read GetMinimum write SetMinimum;
/// Максимальное значение
@ -652,7 +767,7 @@ type
property Checked: boolean read InvokeBoolean(()->cb.IsChecked.Value) write Invoke(procedure(t: boolean) -> cb.IsChecked := t, value);
end;
/// Элемент управления "Радиокнопка"
/// Элемент управления "Переключатель"
RadioButtonWPF = class(ClickableControlWPF)
private
property rb: RadioButton read element as RadioButton;
@ -731,7 +846,8 @@ type
element.Focusable := False;
MainDockPanel.children.RemoveAt(MainDockPanel.children.Count-1);
MainDockPanel.children.Add(can);
ActivePanel := can;
__SetActivePanelInternal(can);
//ActivePanel := can;
end;
constructor (i: integer) := Invoke(CreatePP); // фиктивный первый параметр
procedure SetColorP(c: GColor);
@ -977,6 +1093,17 @@ function RealBlock(message: string; initValue: real := 0; fontSize: real := 12):
/// Элемент управления "Вещественное число" с заданными координатами
function RealBlock(x, y: real; message: string; width: real := 0; initValue: real := 0; fontSize: real := 12): RealBlockWPF;
/// Элемент управления "Флажок"
function CheckBox(text: string): CheckBoxWPF;
/// Элемент управления "Флажок" с заданными координатами
function CheckBox(x, y: real; text: string; width: real := 0): CheckBoxWPF;
/// Элемент управления "Переключатель"
function RadioButton(text: string): RadioButtonWPF;
/// Элемент управления "Переключатель" с заданными координатами
function RadioButton(x, y: real; text: string; width: real := 0): RadioButtonWPF;
/// Элемент управления "Текстовое поле с заголовком"
function TextBox(text: string := ''): TextBoxWPF;
/// Элемент управления "Текстовое поле с заголовком" с заданными координатами
@ -994,12 +1121,23 @@ function ListBox(title: string := ''; height: real := 150): ListBoxWPF;
/// Элемент управления "Список" с заданными координатами
function ListBox(x,y: real; title: string := ''; width: real := 150; height: real := 150): ListBoxWPF;
/// Элемент управления "Слайдер с вещественными значениями"
function SliderReal(title: string := ''): SliderRealWPF;
/// Элемент управления "Слайдер с вещественными значениями" с заданным диапазоном значений и заголовком
function SliderReal(title: string; min,max: real; val: real := real.MinValue; freq: real := 0): SliderRealWPF;
/// Элемент управления "Слайдер с вещественными значениями" с заданным диапазоном значений
function SliderReal(min, max: real; val: real := real.MaxValue; freq: real := 0): SliderRealWPF;
/// Элемент управления "Слайдер с вещественными значениями" с заданными координатами
function SliderReal(x,y: real; title: string; min,max: real; width: real; val: real := real.MinValue; freq: real := 0): SliderRealWPF;
/// Элемент управления "Слайдер"
function Slider(): SliderWPF;
function Slider(title: string := ''): SliderWPF;
/// Элемент управления "Слайдер" с заданным диапазоном значений и заголовком
function Slider(title: string; min,max: integer; val: integer := integer.MinValue; freq: integer := 0): SliderWPF;
/// Элемент управления "Слайдер" с заданным диапазоном значений
function Slider(min,max: real; val: real := real.MinValue; freq: real := 0): SliderWPF;
function Slider(min, max: integer; val: integer := integer.MinValue; freq: integer := 0): SliderWPF;
/// Элемент управления "Слайдер" с заданными координатами
function Slider(x,y: real; min,max: real; width: real; val: real := real.MinValue; freq: real := 0): SliderWPF;
function Slider(x,y: real; title: string; min,max: integer; width: integer; val: integer := integer.MinValue; freq: integer := 0): SliderWPF;
/// Элемент управления "Изображение"
function Image(name: string): ImageWPF;
@ -1030,18 +1168,23 @@ function StatusBar(height: real := 24; itemWidth: real := 0): StatusBarWPF;
/// Пустой блок для задания промежутков между компонентами
procedure EmptyBlock(sz: integer := 16);
/// Установка активной панели, на которую размещаются элементы управления
procedure SetActivePanel(p: PanelWPF);
/// Графическое окно
function Window: WindowTypeWPF;
//function Window: WindowType;
implementation
uses GraphWPF;
//uses GraphWPF;
uses System.Windows;
uses System.Windows.Controls;
uses System.Windows.Controls.Primitives;
uses System.Windows.Media.Imaging;
function Window: WindowTypeWPF := GraphWPF.Window;
//function Window: WindowType := GraphWPF.Window;
function Button(Txt: string; fontSize: real): ButtonWPF := ButtonWPF.Create(Txt,fontSize);
function Button(x, y: real; Txt: string; width: real; fontSize: real): ButtonWPF := ButtonWPF.Create(x, y, Txt, width, fontSize);
@ -1055,6 +1198,12 @@ function IntegerBlock(x, y: real; message: string; width: real; initValue: integ
function RealBlock(message: string; initValue: real; fontSize: real): RealBlockWPF := RealBlockWPF.Create(message, initValue, fontSize);
function RealBlock(x, y: real; message: string; width: real; initValue: real; fontSize: real): RealBlockWPF := RealBlockWPF.Create(x,y,message,width,initValue,fontSize);
function CheckBox(text: string): CheckBoxWPF := CheckBoxWPF.Create(text);
function CheckBox(x, y: real; text: string; width: real): CheckBoxWPF := CheckBoxWPF.Create(x,y,text,width);
function RadioButton(text: string): RadioButtonWPF := RadioButtonWPF.Create(text);
function RadioButton(x, y: real; text: string; width: real): RadioButtonWPF := RadioButtonWPF.Create(x,y,text,width);
function TextBox(text: string): TextBoxWPF := TextBoxWPF.Create(text);
function TextBox(x, y: real; text: string; width: real): TextBoxWPF := TextBoxWPF.Create(x,y,text,width);
@ -1065,18 +1214,34 @@ function IntegerBox(x, y: real; title: string; min,max: integer; width: real) :=
function ListBox(title: string; height: real): ListBoxWPF := ListBoxWPF.Create(title,height);
function ListBox(x,y: real; title: string; width: real; height: real): ListBoxWPF := ListBoxWPF.Create(x,y,title,width,height);
function Slider: SliderWPF := SliderWPF.Create(0, 10, 0, 0);
function Slider(min, max, val, freq: real): SliderWPF;
function SliderReal(title: string): SliderRealWPF := SliderRealWPF.Create(title,0, 10, 0, 0);
function SliderReal(title: string; min, max, val, freq: real): SliderRealWPF;
begin
if val = real.MinValue then
val := min;
Result := SliderWPF.Create(min, max, val, freq);
Result := SliderRealWPF.Create(title, min, max, val, freq);
end;
function SliderReal(min, max, val, freq: real): SliderRealWPF := SliderReal('',min, max, val, freq);
function SliderReal(x,y: real; title: string; min,max,width,val,freq: real): SliderRealWPF;
begin
if val = real.MinValue then
val := min;
Result := SliderRealWPF.Create(x, y, title, min, max, width, val, freq);
end;
function Slider(x,y,min,max,width,val,freq: real): SliderWPF;
function Slider(title: string): SliderWPF := SliderWPF.Create(title);
function Slider(title: string; min, max, val, freq: integer): SliderWPF;
begin
if val = real.MinValue then
val := min;
Result := SliderWPF.Create(x, y, min, max, width, val, freq);
Result := SliderWPF.Create(title, min, max, val, freq);
end;
function Slider(min, max, val, freq: integer): SliderWPF := Slider('',min, max, val, freq);
function Slider(x,y: real; title: string; min,max,width,val,freq: integer): SliderWPF;
begin
if val = real.MinValue then
val := min;
Result := SliderWPF.Create(x, y, title, min, max, width, val, freq);
end;
function Image(name: string): ImageWPF := new ImageWPF(name);
@ -1116,15 +1281,54 @@ begin
Result := flds.OrderBy(f->f.CustomAttributes.FirstOrDefault?.ToString ?? 'NoAttr').Select(f->f.Name);
end;
procedure Invoke(d: System.Delegate; params args: array of object) := GraphWPFBase.Invoke(d, args);
procedure InvokeP(p: procedure(r: real); r: real) := GraphWPFBase.Invoke(p,r);
function Invoke<T>(d: Func0<T>): T := T(app.Dispatcher.Invoke(d));
type ControlsCannotBeRunWithoutGraphModules = class(System.ApplicationException) end;
procedure Invoke(d: System.Delegate; params args: array of object);
begin
if app = nil then
raise new ControlsCannotBeRunWithoutGraphModules('Модуль Controls должен испольоваться только совместно с модулями GraphWPF и WPFObjects либо Graph3D');
GraphWPFBase.Invoke(d, args);
end;
procedure InvokeP(p: procedure(r: real); r: real);
begin
if app = nil then
raise new ControlsCannotBeRunWithoutGraphModules('Модуль Controls должен испольоваться только совместно с модулями GraphWPF и WPFObjects либо Graph3D');
GraphWPFBase.Invoke(p,r);
end;
function Invoke<T>(d: Func0<T>): T;
begin
if app = nil then
raise new ControlsCannotBeRunWithoutGraphModules('Модуль Controls должен испольоваться только совместно с модулями GraphWPF и WPFObjects либо Graph3D');
Result := T(app.Dispatcher.Invoke(d));
end;
procedure __SetActivePanelInternal(p: GPanel);
begin
Invoke(()->begin
_ActivePanel := p;
end);
end;
procedure SetActivePanel(p: PanelWPF);
begin
__SetActivePanelInternal(p.p)
end;
procedure SetActivePanelInit;
begin
ActivePanel := MainWindow.MainPanel.Children[0] as GPanel
__SetActivePanelInternal(MainWindow.MainPanel.Children[0] as GPanel);
//ActivePanel := MainWindow.MainPanel.Children[0] as GPanel
end;
function __ActivePanelInternal: GPanel;
begin
Invoke(SetActivePanelInit);
if _ActivePanel = nil then
Invoke(SetActivePanelInit);
Result := _ActivePanel;
end;
initialization
finalization
end.

40
bin/Lib/Graph3D.pas
View file

@ -2206,15 +2206,15 @@ type
procedure SetN(n: integer);
function GetN: integer;
protected
function CreateObject: Object3D; override := new PrismT(X, Y, Z, N, Radius, Height, Material.Clone);
function CreateObject: Object3D; override := new PrismT(X, Y, Z, Sides, 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;
/// Количество боковых граней правильной призмы
property Sides: integer read GetN write SetN;
/// Возвращает клон правильной призмы
function Clone := (inherited Clone) as PrismT;
end;
@ -2226,15 +2226,15 @@ type
PyramidT = class(PrismT)
private
protected
function CreateObject: Object3D; override := new PyramidT(X, Y, Z, N, Radius, Height, Material.Clone);
function CreateObject: Object3D; override := new PyramidT(X, Y, Z, Sides, 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;
/// Количество боковых граней правильной пирамиды
property Sides: integer read GetN write SetN;
/// Возвращает клон правильной пирамиды
function Clone := (inherited Clone) as PyramidT;
end;
@ -2288,8 +2288,8 @@ type
begin
var pc := new Point3DCollection;
var a := PartitionPoints(0, 2 * Pi, N).Select(x -> P3D(fr * cos(x), fr * sin(x), 0)).ToArray;
var b := PartitionPoints(0, 2 * Pi, N).Select(x -> P3D(fr * cos(x), fr * sin(x), fh)).ToArray;
var a := PartitionPoints(0, 2 * Pi, Sides).Select(x -> P3D(fr * cos(x), fr * sin(x), 0)).ToArray;
var b := PartitionPoints(0, 2 * Pi, Sides).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]);
@ -2320,12 +2320,12 @@ type
end;
protected
function CreateObject: Object3D; override := new PrismTWireframe(X, Y, Z, N, Radius, Height, (model as LinesVisual3D).Thickness, (model as LinesVisual3D).Color);
function CreateObject: Object3D; override := new PrismTWireframe(X, Y, Z, Sides, Radius, Height, (model as LinesVisual3D).Thickness, (model as LinesVisual3D).Color);
public
function Points: Point3DCollection; virtual;
begin
var a := PartitionPoints(0, 2 * Pi, N).Select(x -> P3D(fr * cos(x), fr * sin(x), 0)).SkipLast;
var b := PartitionPoints(0, 2 * Pi, N).Select(x -> P3D(fr * cos(x), fr * sin(x), fh)).SkipLast;
var a := PartitionPoints(0, 2 * Pi, Sides).Select(x -> P3D(fr * cos(x), fr * sin(x), 0)).SkipLast;
var b := PartitionPoints(0, 2 * Pi, Sides).Select(x -> P3D(fr * cos(x), fr * sin(x), fh)).SkipLast;
var pc := new Point3DCollection(a + b);
Result := pc;
@ -2338,8 +2338,8 @@ type
property Radius: real read fr write SetR;
/// Высота проволочной правильной призмы
property Height: real read fh write SetH;
/// Количество углов проволочной правильной призмы
property N: integer read fn write SetN;
/// Количество боковых граней проволочной правильной призмы
property Sides: integer read fn write SetN;
/// Цвет проволоки правильной призмы
property Color: GColor read GetC write SetC; override;
/// Толщина проволоки правильной призмы
@ -2352,13 +2352,13 @@ type
/// Класс проволочной правильной пирамиды
PyramidTWireframe = class(PrismTWireframe)
protected
function CreateObject: Object3D; override := new PyramidTWireframe(X, Y, Z, N, Radius, Height, (model as LinesVisual3D).Thickness, (model as LinesVisual3D).Color);
function CreateObject: Object3D; override := new PyramidTWireframe(X, Y, Z, Sides, Radius, Height, (model as LinesVisual3D).Thickness, (model as LinesVisual3D).Color);
private
function CreatePoints: Point3DCollection; override;
begin
var pc := new Point3DCollection;
var a := PartitionPoints(0, 2 * Pi, N).Select(x -> P3D(fr * cos(x), fr * sin(x), 0)).ToArray;
var a := PartitionPoints(0, 2 * Pi, Sides).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
@ -2377,8 +2377,8 @@ type
property Radius: real read fr write SetR;
/// Высота проволочной правильной пирамиды
property Height: real read fh write SetH;
/// Количество углов проволочной правильной пирамиды
property N: integer read fn write SetN;
/// Количество боковых граней проволочной правильной пирамиды
property Sides: integer read fn write SetN;
/// Цвет проволоки правильной пирамиды
property Color: GColor read GetC write SetC; override;
/// Толщина проволоки правильной пирамиды
@ -3373,15 +3373,15 @@ function FileModel3D(p: Point3D; fname: string; m: Material): FileModelT := File
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 Prism(p: Point3D; Sides: integer; Height, Radius: real; m: Material): PrismT := Prism(p.X, p.Y, p.Z, Sides, Height, Radius, 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 PrismWireFrame(p: Point3D; Sides: integer; Height, Radius: real; Thickness: real; c: Color): PrismTWireFrame := PrismWireFrame(p.x, p.y, p.z, Sides, Height, Radius, 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 Pyramid(p: Point3D; Sides: integer; Height, Radius: real; m: Material): PyramidT := Pyramid(p.X, p.Y, p.Z, Sides, Height, Radius, 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));

31
bin/Lib/GraphWPF.pas
View file

@ -58,7 +58,6 @@ type
//{{{--doc: Конец секции 1 }}}
function GetBrush(c: Color): GBrush;
function GetFontFamily(name: string): FontFamily;
@ -630,20 +629,8 @@ procedure __FinalizeModule__;
implementation
var BrushesDict := new Dictionary<Color,GBrush>;
var FontFamiliesDict := new Dictionary<string,FontFamily>;
function GetBrush(c: Color): GBrush;
begin
if not (c in BrushesDict) then
begin
var b := new SolidColorBrush(c);
BrushesDict[c] := b;
Result := b
end
else Result := BrushesDict[c];
end;
function GetFontFamily(name: string): FontFamily;
begin
if not (name in FontFamiliesDict) then
@ -1494,6 +1481,7 @@ type
Pen.Color := Colors.Black;
var n := Round(w / 1);
if n<=0 then exit;
var pp := PartitionPoints(a, b, n);
var fff: real -> Point := xx -> Pnt(x + mx * (xx - a), y + my * (max - f(xx).Clamp(min,max)));
//pp.Select(x->(x,f(x))).PrintLines;
@ -1523,8 +1511,11 @@ procedure DrawGraph(f: real -> real; a, b, min, max: real; title: string) := Dra
procedure DrawGraph(f: real -> real; a, b: real; x, y, w, h: real; title: string);
begin
var n := Round(w / 1);
var q := PartitionPoints(a, b, n);
DrawGraph(f, a, b, q.Min(f), q.Max(f), x, y, w, h, title)
if n<=0 then exit;
var q := PartitionPoints(a, b, n).ToArray;
var mi := q.Min(f);
var ma := q.Max(f);
DrawGraph(f, a, b, mi, ma, x, y, w, h, title);
end;
procedure DrawGraph(f: real -> real; a, b: real; r: GRect; title: string) := DrawGraph(f, a, b, r.X, r.Y, r.Width, r.Height, title);
@ -1929,8 +1920,13 @@ GraphWPFWindow = class(GMainWindow)
public
procedure InitMainGraphControl; override;
begin
var g := Content as DockPanel;
host1 := new Canvas;
host := new MyVisualHost();
// Попытка отсекать рисование частей объектов за пределами host. Актуально при наличии панелей.
// К сожалению, почему-то при использовании WPFObjects объекты GraphWPF становятся не видны
// Выход - в WPFObjects host1.ClipToBounds := False
host1.ClipToBounds := True;
host1.SizeChanged += (s,e) ->
begin
@ -1938,7 +1934,6 @@ public
host.DataContext := sz;
end;
// Всегда последнее
var g := MainPanel;
var dpiXProperty := typeof(SystemParameters).GetProperty('DpiX', BindingFlags.NonPublic or BindingFlags.Static);
var dpiYProperty := typeof(SystemParameters).GetProperty('Dpi', BindingFlags.NonPublic or BindingFlags.Static);
@ -1952,6 +1947,8 @@ public
RTbmap := new RenderTargetBitmap(Round(SystemParameters.PrimaryScreenWidth * scalex), Round(SystemParameters.PrimaryScreenHeight * scaley), dpiX, dpiY, PixelFormats.Pbgra32);
im.Source := RTbmap;
// Рисуем на host
// Когда накопится много объектов, переносим их на im
host1.Children.Add(im);
host1.Children.Add(host);
@ -2004,7 +2001,7 @@ begin
app.Dispatcher.UnhandledException += (o, e) -> begin
Println(e.Exception.Message);
if e.Exception.InnerException<>nil then
if e.Exception.InnerException <> nil then
Println(e.Exception.InnerException.Message);
halt;
end;

21
bin/Lib/GraphWPFBase.pas
View file

@ -11,12 +11,14 @@ unit GraphWPFBase;
uses System.Windows;
uses System.Windows.Controls;
uses System.Windows.Media;
type
/// Тип цвета
GColor = System.Windows.Media.Color;
/// Тип прямоугольника
GRect = System.Windows.Rect;
GBrush = System.Windows.Media.Brush;
GWindow = System.Windows.Window;
GMainWindow = class(GWindow)
@ -56,6 +58,19 @@ var
app: Application;
MainWindow: GMainWindow;
var BrushesDict := new Dictionary<GColor,GBrush>;
function GetBrush(c: GColor): GBrush;
begin
if not (c in BrushesDict) then
begin
var b := new SolidColorBrush(c);
BrushesDict[c] := b;
Result := b
end
else Result := BrushesDict[c];
end;
procedure Invoke(d: System.Delegate; params args: array of object) := app.Dispatcher.Invoke(d, args);
procedure InvokeP(p: procedure(r: real); r: real) := Invoke(p,r);
@ -108,7 +123,7 @@ type
property IsFixedSize: boolean read GetFixedSize write SetFixedSize;
/// Очищает графическое окно белым цветом
procedure Clear; virtual;
/// Очищает графическое окно цветом c
/// Очищает графическое окно указанным цветом
procedure Clear(c: GColor); virtual;
/// Устанавливает размеры клиентской части главного окна
procedure SetSize(w, h: real);
@ -303,6 +318,8 @@ begin
end;
end;
begin
initialization
__InitModule;
finalization
end.

1330
bin/Lib/OpenCL.pas
View file

File diff suppressed because it is too large Load diff

4089
bin/Lib/OpenCLABC.pas
View file

File diff suppressed because it is too large Load diff

7687
bin/Lib/OpenCLABCBase.pas Normal file
View file

File diff suppressed because it is too large Load diff

3326
bin/Lib/OpenGL.pas
View file

File diff suppressed because it is too large Load diff

4
bin/Lib/OpenGLABC.pas
View file

@ -1,5 +1,4 @@

///
///
///Модуль, зарезервированный для высокоуровневой оболочки модуля OpenGL
///
unit OpenGLABC;
@ -7,6 +6,7 @@ unit OpenGLABC;
interface
uses OpenGL;
uses OpenGLABCBase;
implementation

4
bin/Lib/OpenGLABCBase.pas Normal file
View file

@ -0,0 +1,4 @@
/// Модуль для внутренних типов модуля OpenGLABC
unit OpenGLABCBase;
end.

59
bin/Lib/PABCSystem.pas
View file

@ -1760,7 +1760,7 @@ function CplxFromPolar(magnitude, phase: real): Complex;
/// Возвращает квадратный корень из комплексного числа
function Sqrt(c: Complex): Complex;
/// Возвращает модуль комплексного числа
function Abs(c: Complex): Complex;
function Abs(c: Complex): real;
/// Возвращает комплексно сопряженное число
function Conjugate(c: Complex): Complex;
/// Возвращает косинус комплексного числа
@ -1941,7 +1941,7 @@ function TryReadIntegerFromString(s: string; var from: integer; var res: integer
function TryReadRealFromString(s: string; var from: integer; var res: real): boolean;
///-procedure Val(s: string; var value: число; var err: integer);
/// Преобразует строковое представление s целого числа к числовому значению и записывает его в переменную value.
/// Преобразует строковое представление s целого или вещественного числа к числовому значению и записывает его в переменную value.
///Если преобразование успешно, то err=0, иначе err>0
procedure Val(s: string; var value: integer; var err: integer);
///--
@ -2122,6 +2122,9 @@ procedure Reverse(var s: string);
procedure Reverse(var s: string; index, count: integer);
/// Перемешивает динамический массив случайным образом
procedure Shuffle<T>(a: array of T);
/// Возвращает, совпадают ли массивы
function ArrEqual<T>(a, b: array of T): boolean;
/// Сравнивает матрицы на равенство
function MatrEqual<T>(a, b: array [,] of T): boolean;
/// Перемешивает список случайным образом
@ -2224,6 +2227,13 @@ function ArrGen<T>(count: integer; first, second: T; next: (T,T) ->T): array of
/// Возвращает массив из count элементов x
function ArrFill<T>(count: integer; x: T): array of T;
// Возвращает массив из элементов массива a, удовлетворяющих условию condition
// a.FindAll
//function ArrFilter<T>(a: array of T; condition: T->boolean): array of T;
// Возвращает по массиву a массив, преобразованный по правилу convert
// a.ConvertAll
//function ArrTransform<T,T1>(a: array of T; convert: T->T1): array of T1;
/// Возвращает массив из n целых, введенных с клавиатуры
function ReadArrInteger(n: integer): array of integer;
/// Возвращает массив из n целых int64, введенных с клавиатуры
@ -2247,8 +2257,6 @@ function ReadArrReal(prompt: string; n: integer): array of real;
/// Выводит приглашение к вводу и возвращает массив из n строк, введенных с клавиатуры
function ReadArrString(prompt: string; n: integer): array of string;
/// Возвращает, совпадают ли массивы
function ArrEqual<T>(a, b: array of T): boolean;
// -----------------------------------------------------
//>> Подпрограммы для создания двумерных динамических массивов # Subroutines for matrixes
@ -4537,9 +4545,9 @@ end;
function Range(a, b: real; n: integer): sequence of real;
begin
if n = 0 then
raise new System.ArgumentException('n=0');
raise new System.ArgumentException('Range: n=0');
if n < 0 then
raise new System.ArgumentException('n<0');
raise new System.ArgumentException('Range: n<0');
var r := a;
var h := (b - a) / n;
for var i := 0 to n do
@ -4732,31 +4740,28 @@ begin
Result := a;
end;
{function ListWhile<T>(first: T; next: Func<T,T>; pred: Predicate<T>): List<T>;
{function ArrTransform<T,T1>(a: array of T; convert: T->T1): array of T1;
begin
var a := new List<T>;
var x := first;
while pred(x) do
begin
a.Add(x);
x := next(x);
end;
Result := a;
var n := a.Length;
var a1 := new T1[n];
for var i:=0 to n-1 do
a1[i] := convert(a[i]);
Result := a1;
end;
function ListWhile<T>(first,second: T; next: Func2<T,T,T>; pred: Predicate<T>): List<T>;
function ArrFilter<T>(a: array of T; condition: T->boolean): array of T;
begin
var a := new List<T>;
var x := first;
var y := second;
while pred(x) do
begin
a.Add(x);
var z := next(x,y);
x := y;
y := z;
end;
Result := a;
var n := a.Length;
var a1 := new T[n];
var j := 0;
for var i:=0 to n-1 do
if condition(a[i]) then
begin
a1[j] := a[i];
j += 1;
end;
SetLength(a1,j);
Result := a1;
end;}
function ArrFill<T>(count: integer; x: T): array of T;

91
bin/Lib/SF.pas
View file

@ -11,6 +11,7 @@ function RI64 := ReadInt64;
function RR := ReadReal;
function RC := ReadChar;
function RS := ReadString;
function RL := ReadLexem;
function RlnI := ReadlnInteger;
function RlnBI := ReadlnBigInteger;
@ -68,36 +69,126 @@ function Prln(Self: char): char; extensionmethod := Self.Println;
function Prln(Self: boolean): boolean; extensionmethod := Self.Println;
function Prln(Self: string): string; extensionmethod := Self.Println;
/// Записывает в min значение x если x<min
procedure ReMin(var min: integer; x: integer);
begin
if x < min then
min := x
end;
/// Записывает в max значение x если x>max
procedure ReMax(var max: integer; x: integer);
begin
if x > max then
max := x
end;
/// Записывает в min значение x если x<min
procedure ReMin(var min: real; x: real);
begin
if x < min then
min := x
end;
/// Записывает в max значение x если x>max
procedure ReMax(var max: real; x: real);
begin
if x > max then
max := x
end;
/// Преобразует строку в целое
function ToI(Self: string); extensionmethod := Self.ToInteger;
/// Преобразует строку в вещественное
function ToR(Self: string); extensionmethod := Self.ToReal;
/// Преобразует строку в массив целых
function ToIs(Self: string); extensionmethod := Self.ToIntegers;
/// Преобразует строку в массив вещественных
function ToRs(Self: string); extensionmethod := Self.ToReals;
function operator-(c,c1: char): integer; extensionmethod := Ord(c) - Ord(c1);
/// Возвращает длину строки
function Len(Self: string): integer; extensionmethod := Self.Length;
/// Возвращает длину массива
function Len<T>(Self: array of T): integer; extensionmethod := Self.Length;
/// Возвращает среднее элементов последовательности
function Av(Self: sequence of integer): real; extensionmethod := Self.Average;
/// Возвращает среднее элементов последовательности
function Av(Self: sequence of real): real; extensionmethod := Self.Average;
function Dst<T>(Self: sequence of T): sequence of T; extensionmethod := Self.Distinct;
function Ord<T>(Self: sequence of T): sequence of T; extensionmethod := Self.Order;
function OrdD<T>(Self: sequence of T): sequence of T; extensionmethod := Self.OrderDescending;
/// Преобразует последовательность в строку
function Str<T>(Self: sequence of T): string; extensionmethod := Self.JoinToString;
/// Выводит последовательность, разделяя элементы пробелами
function Pr<T>(Self: sequence of T): sequence of T; extensionmethod := Self.Print;
/// Выводит последовательность, разделяя элементы пробелами, и переходит на новую строку
function Prln<T>(Self: sequence of T): sequence of T; extensionmethod := Self.Println;
/// Возвращает инвертированную последовательность
function Rev<T>(Self: sequence of T): sequence of T; extensionmethod := Self.Reverse;
/// Преобразует последовательность, используя функцию transform
function Sel<T,T1>(Self: sequence of T; transform: T->T1): sequence of T1; extensionmethod := Self.Select(transform);
/// Фильтрует последовательность по условию cond
function Wh<T>(Self: sequence of T; cond: T->boolean): sequence of T; extensionmethod := Self.Where(cond);
/// Преобразует последовательность в массив
function ToA<T>(Self: sequence of T): array of T; extensionmethod := Self.ToArray;
/// Преобразует последовательность в список
function ToL<T>(Self: sequence of T): List<T>; extensionmethod := Self.ToList;
/// Преобразует последовательность в HashSet
function ToHS<T>(Self: sequence of T): HashSet<T>; extensionmethod := Self.ToHashSet;
/// Преобразует последовательность в SortedSet
function ToSS<T>(Self: sequence of T): SortedSet<T>; extensionmethod := Self.ToSortedSet;
/// Преобразует последовательность в HashSet
function HS<T>(s: sequence of T): HashSet<T> := s.ToHashSet;
/// Преобразует последовательность в SortedSet
function SS<T>(s: sequence of T): SortedSet<T> := s.ToSortedSet;
/// Инвертирует последовательность
procedure Rev<T>(a: array of T) := Reverse(a);
/// Возвращает индекс минимального элемента
function IMin<T>(Self: array of T): integer; extensionmethod; where T: IComparable<T>;
begin
Result := Self.IndexMin;
end;
/// Возвращает индекс максимального элемента
function IMax<T>(Self: array of T): integer; extensionmethod; where T: IComparable<T>;
begin
Result := Self.IndexMax;
end;
/// Возвращает True если массивы равны
function Eq<T>(Self,b: array of T): boolean; extensionmethod := Self.ArrEqual(b);
/// Возвращает в виде массива все элементы, удовлетворяющие cond
function Filt<T>(Self: array of T; cond: T->boolean): array of T; extensionmethod := Self.FindAll(cond);
/// Возвращает массив с элементами, преобразованными по правилу transform
function Tr<T>(Self: array of T; transform: T->T): array of T; extensionmethod := Self.ConvertAll(transform);
/// Преобразует массив по правилу transform
procedure Tr<T>(a: array of T; transform: T->T) := a.Transform(transform);
/// Возвращает индекс последнего элемента массива
function H<T>(Self: array of T): integer; extensionmethod := Self.High;
end.

1
bin/Lib/Timers.pas
View file

@ -38,6 +38,7 @@ type
property TimerProc: ()->() read _procedure write _procedure;
end;
/// Создать и запустить таймер, вызывающий процедуру TimerProc каждые ms миллисекунд
function CreateTimerAndStart(ms: integer; TimerProc: procedure): Timer;
implementation

17
bin/Lib/WPFObjects.pas
View file

@ -140,6 +140,19 @@ type
begin
Result := l.GetEnumerator;
end;
/// Очистить список игровых объектов
procedure Clear;
begin
for var i:=Count-1 downto 0 do
Destroy(Items[i]);
end;
/// Удалить все игровые объекты, удовлетворяющие условию
procedure DestroyAll(condition: ObjectWPF -> boolean);
begin
for var i := Count - 1 downto 0 do
if condition(Items[i]) then
Destroy(Items[i]);
end;
end;
@ -404,6 +417,8 @@ type
begin
Result := (Left < 0) or (Top < 0) or (Right > GraphWindow.Width) or (Bottom > GraphWindow.Height);
end;
/// Tag хранит любые присоединённые характеристики объекта
auto property Tag: object;
end;
// -----------------------------------------------------
@ -1595,12 +1610,14 @@ begin
GraphWindow := GraphWPF.GraphWindow;
host := new Canvas();
host.ClipToBounds := True;
{host.SizeChanged += (s,e) ->
begin
var sz := e.NewSize;
host.DataContext := sz;
end;}
var g := MainWindow.Content as DockPanel;
(g.children[0] as Canvas).ClipToBounds := False; // SSM 04/08/20 - возвращаем в False иначе графику GraphWPF становится не видно
g.children.Add(host); // Слой графики WPF - последний
end;
app.Dispatcher.Invoke(AdditionalInit);

4
bin/Lng/Eng/SemanticErrors_ms.dat
View file

@ -1,6 +1,7 @@
%PREFIX%=SEMANTICERROR_
CAN_NOT_READ=Can not read data of this type
TUPLE_EXPECTED=Tuple expected
TUPLE_OR_SEQUENCE_EXPECTED=Tuple or sequence expected
TOO_MANY_ELEMENTS_ON_LEFT_SIDE_OF_TUPLE_ASSIGNMRNT=Too many elements on the left side of tuple assignment
ONLY_BASE_ASSIGNMENT_FOR_TUPLE=Tuple allows only base assignment :=
TUPLE_TYPE_ERROR=Bad element in Tuple type
@ -43,4 +44,5 @@ EXPLICIT_CASTS_FOR_LAMBDA_EXPRESSIONS_ARE_FORBIDDEN=Explicit type casts for lamb
STATIC_CLASS_CANNOT_HAVE_PREDEFINITION=Static class cannot be predefined
OPERATIONS_CANNOT_BE_CALLED_USING_THIS_SYNTAX=Operations cannot be called using this syntax
MEMBER_{0}_OF_TYPE_{1}_CANNOT_BE_FOUND_IN_THE_CONTEEXT_OF_FUNCTION_WITH_YIELD=Name {0} cannot be found in type {1} in the context of function with yield statement
UNCOMPARABLE_TYPES_IN_ARRAY_CONST=Uncomparable types in array initializers
UNCOMPARABLE_TYPES_IN_ARRAY_CONST=Uncomparable types in array initializers
IMPOSSIBLE_TO_CONVERT_ARRAY_CONST_TO_{0}=It is impossible to convert array initializer to type {0}

3
bin/Lng/Eng/SemanticErrors_nv.dat
View file

@ -3,6 +3,9 @@
NAME_CANNOT_HAVE_GENERIC_PARAMETERS_{0}=Name {0} can not have generic parameters
AUTO_CLASS_MUST_NOT_HAVE_POINTERS=Auto class can not have fields of pointer type
AUTO_CLASS_MUST_NOT_HAVE_PARENTS=Auto class can not have parents
AUTO_CLASS_MUST_NOT_HAVE_UNNAMED_ENUMS=Auto class can not have fields with unnamed enums type
AUTO_CLASS_MUST_NOT_HAVE_EVENTS=Auto class can not have events
AUTO_CLASS_MUST_NOT_HAVE_PROPERTIES=Auto class can not have properties
UNDEFINED_NAME_REFERENCE_{0}=Undefined name reference '{0}'
TWO_TYPE_CONVERTIONS_POSSIBLE_FIRST_TYPE_{0}_SECOND_TYE_{1}=Two type of convertions are possible: to type '{0}' and to type '{1}'
CAN_NOT_CONVERT_TYPES_FROM_{0}_TO_{1}=Incompatible types: '{0}' and '{1}'

4
bin/Lng/Rus/SemanticErrors_ms.dat
View file

@ -1,6 +1,7 @@
%PREFIX%=SEMANTICERROR_
CAN_NOT_READ=Нельзя считывать данные этого типа
TUPLE_EXPECTED=Ожидался кортеж
TUPLE_OR_SEQUENCE_EXPECTED=Ожидался кортеж или последовательность
TOO_MANY_ELEMENTS_ON_LEFT_SIDE_OF_TUPLE_ASSIGNMRNT=Слишком много элементов в левой части при присваивании кортежа
ONLY_BASE_ASSIGNMENT_FOR_TUPLE=Для кортежа допустимо только обычное присваивание :=
TUPLE_TYPE_ERROR=Ошибочная конструкция при построении типа кортежа
@ -43,4 +44,5 @@ EXPLICIT_CASTS_FOR_LAMBDA_EXPRESSIONS_ARE_FORBIDDEN=Явные приведен
STATIC_CLASS_CANNOT_HAVE_PREDEFINITION=Статический класс не может иметь предописание
OPERATIONS_CANNOT_BE_CALLED_USING_THIS_SYNTAX=Операции нельзя вызывать, используя данный синтаксис
MEMBER_{0}_OF_TYPE_{1}_CANNOT_BE_FOUND_IN_THE_CONTEEXT_OF_FUNCTION_WITH_YIELD=Имя {0} не удаётся найти в типе {1} в контексте функции с оператором yield
UNCOMPARABLE_TYPES_IN_ARRAY_CONST=Несовместимые типы при задании массива
UNCOMPARABLE_TYPES_IN_ARRAY_CONST=Несовместимые типы при задании массива
IMPOSSIBLE_TO_CONVERT_ARRAY_CONST_TO_{0}=Невозможно преобразовать инициализатор массива к типу {0}

Some files were not shown because too many files have changed in this diff Show more