Форум программистов, компьютерный форум, киберфорум
Наши страницы

PascalABC.NET

Войти
Регистрация
Восстановить пароль
 
 
Рейтинг: Рейтинг темы: голосов - 5, средняя оценка - 5.00
BaboshinSD
329 / 268 / 28
Регистрация: 15.11.2012
Сообщений: 477
Записей в блоге: 1
#1

Полезные коды для PascalABC.NET - PascalABC.NET

23.03.2013, 15:03. Просмотров 165885. Ответов 115

В этой теме размещаются полезные исходники программ, различные процедуры и функции, а так же готовые решения на часто задаваемые вопросы, написанные на PascalABC.NET.

Поддержать тему и добавить свои примеры, исходники и пр. может каждый, после того, как ознакомиться с правилами темы:
Правила темы!
  1. Запрещается добавлять коды программ никак не связанные с PascalABC.NET, для этих программ есть другие темы и разделы.
  2. Не рекомендуется добавлять слишком простые примеры, типа "Как добавить текст на кнопку?" и пр.
  3. Перед тем как выложить код, подумайте будет ли он кому-то интересен или полезен.
  4. Приветствуются сложные примеры или проекты, а так же программы с интересным принципом работы.
  5. Если программа использует сторонние ресурсы (изображения, библиотеки и пр.) обязательно прикрепляйте их во вложении
  6. Обязательно подробно комментируйте свой код, чтобы другим было проще разобраться в нём.
  7. Тема ведётся в формате Вопрос-Ответ, поэтому все сообщения оформляются в таком виде:
    В: Как что-то сделать?
    О:
    Делаем что-то
    Pascal
    1
    
    // Тут код
  8. Если вы хотите отредактировать свой код, можно обратиться к модераторам раздела или к ТС.


Путеводитель по теме:


Работа с формами:

Готовые решения:
Готовые решения на часто задаваемые вопросы.

Работа с графикой:
Исходники программ, работающих с графикой и графическими библиотеками (GraphABC, OpenGL и пр.).
Проектирование игр:
Инструкции, советы и пр.:
Инструкции, касающиеся работы с PascalABC.NET, советы для новичков и пр.
Работа со строками:
Базовые алгоритмы:
23
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
23.03.2013, 15:03
Здравствуйте! Я подобрал для вас темы с ответами на вопрос Полезные коды для PascalABC.NET (PascalABC.NET):

Модуль для PascalABC.NET - PascalABC.NET
Здравствуйте уважаемые форумчане, возник вопрос почему не работает модуль. Вот модуль unit Sockets; #reference 'System.dll' ...

В чем разница PascalABC.net и PascalABC - PascalABC.NET
Скажите в чем разница PascalABC.net И PascalABC. Помню когда-то давно программы работающие в PascalABC у меня не работали в .net

Процедура GetMem для PascalABC.NET - PascalABC.NET
Долго долго курил страницы форума, изучал динамические списки. Когда код для программы уже практически собрался в единое целое решил...

Исправить код для PascalABC.net - PascalABC.NET
как минимум, первое место которое ему не нравиться это как я обьявляю тип объект const size=10; type pvec=^vec; ...

Есть ли PascalABC.NET для Mac OS X? - PascalABC.NET
Есть ли PascalABC.NET для Mac OS X?

Создание своего модуля для PascalABC.net - PascalABC.NET
Здравствуйте уважаемые форумчане, подскажите как создать из файла Pas файл PCU. Чем и как его можно откомпилировать? Просто стоит задача...

115
BlackStoneBlack
3 / 3 / 1
Регистрация: 10.05.2016
Сообщений: 67
11.05.2017, 22:37 #106
В: Как увеличить маленькое изображение в графическом окне GraphABC без сглаживания пикселей?
О: При использовании стандартных процедур изображение pic.png размером 16x16 размазывается при его увеличении.
Т.е., при использовании следующего кода мы получим из данного изображения размытую картинку.
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
program ugly_pixels;
 
uses GraphABC;
 
var
  
  //Переменная рисунка
  pic: Picture;
  
  //Коэфициент увеличения/уменьшения изображения
  resize: Integer;
  
  //Переменные, необходимые для отцентровки изображения
  cx, cy: Integer;
 
begin
  
  //Задаем заголовок окна (не обязательно)
  GraphABC.SetWindowCaption('Ugly pixels!');
  
  //Создаем рисунок
  //В нашем случае, это рисунок "pic.png" с размером 16x16 пикселей
  //Файл лежит в одной папке с программой
  pic := Picture.Create('pic.png');
  
  //Увеличение окна до максимального размера
  GraphABC.MaximizeWindow;
  
  //Получение коэфициента увеличения/уменьшения изображения
  if pic.GetWidth > pic.GetHeight then
    resize := GraphABC.WindowWidth div pic.GetWidth
  else
    resize := GraphABC.WindowHeight div pic.GetHeight;
  
  //Увеличиваем изображение
  pic.SetSize(resize * pic.GetWidth, resize * pic.GetHeight);
  
  //Установка центровочных координат
  cx := (GraphABC.WindowWidth - pic.GetWidth) div 2;
  cy := (GraphABC.WindowHeight - pic.GetHeight) div 2;
  
  //Отрисовка полученного изображения
  pic.Draw(cx, cy);
  
end.
(См. рис. 1)

Для того, чтобы решить данную проблему, мы получим цвет с каждого пикселя оригинального изображения, а потом воспользуемся процедурами GraphABC.SetPenColor, GraphABC.SetBrushColor, GraphABC.Rectangle и GraphABC.FillRectangle для отрисовки "искуственного пикселя":

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
program clear_pixels;
 
uses GraphABC;
 
var
  
  //Переменная рисунка
  original_picture: Picture;
  
  //Динамический двумерный массив цветов пикселей
  array_of_colors: array[,] of Color;
  
  //Коэфициент увеличения/уменьшения изображения
  resize: Integer;
  
  //Переменные, необходимые для отцентровки изображения
 cx, cy: Integer;
 
begin
 
  //Задаем заголовок окна (не обязательно)
  GraphABC.SetWindowCaption('Clear pixels!');
 
  //Создаем рисунок
  //В нашем случае, это рисунок "pic.png" с размером 16x16 пикселей
  //Файл лежит в одной папке с программой
  original_picture := Picture.Create('pic.png');
  
  //Устанавливаем размер массива цветов пикселей, зависящий от ширины и высоты исходного изображения
  array_of_colors := new Color[original_picture.GetWidth, original_picture.GetHeight];
  
  //Заполняем массив цветами из оригинального рисунка
  //Номер первого элемента динамического массива всегда равен [0, 0]
  //Поэтому массив array_of colors будет иметь диапозон array[0..15, 0..15], а не [1..16, 1..16]
  for var x := 0 to original_picture.GetWidth - 1 do
    for var y := 0 to original_picture.GetHeight - 1 do
    begin
      array_of_colors[x, y] := original_picture.GetPixel(x, y);
    end;
 
  //Увеличение окна до максимального размера
  GraphABC.MaximizeWindow;
  
  //Получение коэфициента увеличения/уменьшения изображения
  if original_picture.GetWidth > original_picture.GetHeight then
    resize := GraphABC.WindowWidth div original_picture.GetWidth
  else
    resize := GraphABC.WindowHeight div original_picture.GetHeight;
  
  //Установка центровочных координат
  cx := (GraphABC.WindowWidth - resize * original_picture.GetWidth) div 2;
  cy := (GraphABC.WindowHeight - resize * original_picture.GetHeight) div 2;
  
  //Отрисовка полученного изображения
  //Каждый квадрат равен одному пикселю из оригинального изображения
  for var x := 0 to original_picture.GetWidth - 1 do
    for var y := 0 to original_picture.GetHeight - 1 do
    begin
      GraphABC.SetPenColor(array_of_colors[x, y]);
      GraphABC.SetBrushColor(array_of_colors[x, y]);
      GraphABC.Rectangle(cx + resize * x, cy + resize * y, cx + resize * (x + 1), cy + resize * (y + 1));
      GraphABC.FillRectangle(cx + resize * x, cy + resize * y, cx + resize * (x + 1), cy + resize * (y + 1));
    end;
  
end.
(См. рис. 2)
1
Миниатюры
Полезные коды для PascalABC.NET   Полезные коды для PascalABC.NET  
Вложения
Тип файла: zip Исходники.zip (2.1 Кб, 2 просмотров)
PascalAbcNet
1 / 1 / 1
Регистрация: 11.04.2017
Сообщений: 58
23.05.2017, 13:39 #107
В как сделать синтезатор речи?
О
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
{$apptype windows}
{$reference 'System.speech.dll'}
uses
 System.Speech;// System.Windows.Forms, System.Drawing;
 
var
 sysnz: System.Speech.Synthesis.SpeechSynthesizer;
begin
sysnz := new System.Speech.Synthesis.SpeechSynthesizer();
sysnz.Rate :=2 ;//скорость
sysnz.Volume := 100;//громкость
sysnz.SelectVoice(sysnz.GetInstalledVoices.Item[0].VoiceInfo.Name.tostring);//0 русский 1 английский стандартные 2 языковых движка виндовс
sysnz.Speak('Текст на языке движка');
 
end.
0
caeles-lupus
0 / 0 / 1
Регистрация: 22.09.2014
Сообщений: 8
03.07.2017, 17:39 #108
Мой перенос одного из самых быстрых алгоритмов размытия по Гауссу с C++ на Pascal ABC.NET.
Алгоритм оформлен в виде класса, переделать во что-то другое, думаю труда не составить, было бы желание

Источник алгоритма: http://blog.ivank.net/fastest-gaussian-blur.html
Источник кода на C#: https://github.com/mdymel/superfastb...aussianBlur.cs
На GitHub: https://github.com/caeles-lupus/Fastes-Gaussian-Blur

Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
uses graphabc;
 
function inc_(n:integer):integer;
begin
n+=1;
result := n;
end;
 
type
  Stopwatch = System.Diagnostics.Stopwatch;
 
  Bitmap = System.Drawing.Bitmap;
  BitmapData = system.Drawing.Imaging.BitmapData;
  Rectangle = System.Drawing.Rectangle;
  ImageLockMode = system.Drawing.Imaging.ImageLockMode;
  PixelFormat = System.Drawing.Imaging.PixelFormat;
  IntPtr = system.IntPtr;
  TByteRgb = array[,,] of byte;
  Marshal = system.Runtime.InteropServices.Marshal;
  Parallel = System.Threading.Tasks.Parallel;
  Action =  system.Action;
  
  GaussianBlur = class
      _red:array of integer;
      _green: array of integer;
      _blue: array of integer;
      
      _width:integer;
      _height:integer;
      
      procedure GaussianBlur(image:Bitmap);
        begin
          var rct:Rectangle := new Rectangle(0, 0, image.Width, image.Height);
          var source:array of integer := new integer[rct.Width * rct.Height];
          var bits:BitmapData := image.LockBits(rct, ImageLockMode.ReadWrite, PixelFormat.Format32bppArgb);
          Marshal.Copy(bits.Scan0, source, 0, source.Length);
          image.UnlockBits(bits);
 
          _width :=  image.Width;
          _height := image.Height;
 
          _red :=   new integer[_width*_height];
          _green := new integer[_width*_height];
          _blue :=  new integer[_width*_height];
          
          {$omp parallel for}
          For var i := 0 to source.Length-1 do begin
            _red[i] :=    (source[i] and $ff0000) shr 16; //R
            _green[i] :=  (source[i] and $00ff00) shr 8; //G
            _blue[i] :=   (source[i] and $0000ff); //B
          end;
        end;
 
      function Process(radial:integer):Bitmap;
      begin
        var newRed:   array of integer = new integer[_width * _height];
        var newGreen: array of integer = new integer[_width * _height];
        var newBlue:  array of integer = new integer[_width * _height];
        var dest:     array of integer = new integer[_width * _height];
        
        gaussBlur_4(_red, newRed, radial);
        gaussBlur_4(_green, newGreen, radial);
        gaussBlur_4(_blue, newBlue, radial);
        
        // нормализация. готовим integer для перевода в byte
        {$omp parallel for}
        For var i := 0 to dest.Length-1 do begin
          if (newRed[i] > 255) then newRed[i] := 255;
          if (newGreen[i] > 255) then newGreen[i] := 255;
          if (newBlue[i] > 255) then newBlue[i] := 255;
  
          if (newRed[i] < 0) then newRed[i] := 0;
          if (newGreen[i] < 0) then newGreen[i] := 0;
          if (newBlue[i] < 0) then newBlue[i] := 0;
          
          //dest[i] := integer($ff000000 or integer(newRed[i] shl 16) or integer(newGreen[i] shl 8) or integer(newBlue[i]) );
          dest[i] := RGB(newRed[i],newGreen[i],newBlue[i]).ToArgb;
        end;
  
        var image:Bitmap := new Bitmap(_width, _height);
        var rct:Rectangle := new Rectangle(0, 0, image.Width, image.Height);
        var bits2 := image.LockBits(rct, ImageLockMode.ReadWrite, PixelFormat.Format32bppArgb);
        Marshal.Copy(dest, 0, bits2.Scan0, dest.Length);
        image.UnlockBits(bits2);
        
        result := image;
      end;
 
      function boxesForGauss(sigma:integer; n:integer):array of integer;
      begin
        var wIdeal:real := Sqrt((12 * sigma * sigma / n) + 1);
        var wl:integer := Floor(wIdeal);
        if (wl mod 2 = 0) then dec(wl);
        var wu:integer := wl + 2;
  
        var mIdeal:real := (12 * sigma * sigma - n * wl * wl - 4 * n * wl - 3 * n) / (-4 * wl - 4);
        var m:integer := Round(mIdeal);
  
        var sizes:List<integer> := new List<integer>();
        for var i := 0 to n-1 do sizes.Add(i<m?wl:wu);
        result := sizes.ToArray();
      end;
 
      procedure gaussBlur_4(source:array of integer; dest:array of integer; r:integer);
      begin
        var bxs:array of integer := boxesForGauss(r, 3);
        boxBlur_4(source, dest, _width, _height, (bxs[0] - 1) div 2);
        boxBlur_4(dest, source, _width, _height, (bxs[1] - 1) div 2);
        boxBlur_4(source, dest, _width, _height, (bxs[2] - 1) div 2);
      end;
 
      procedure boxBlur_4(source:array of integer; dest:array of integer; w:integer; h:integer; r:integer);
      begin
        for var i := 0 to source.Length-1 do dest[i] := source[i];
        boxBlurH_4(dest, source, w, h, r);
        boxBlurT_4(source, dest, w, h, r);
      end;
 
      procedure boxBlurH_4(source:array of integer; dest:array of integer; w:integer; h:integer; r:integer);
      begin
          var iar:real := 1 / (r + r + 1);
          {$omp parallel for}
          For var i := 0 to h-1 do begin
              var ti:integer := i * w;
              var li:integer := ti;
              var ri:integer := ti + r;
              var fv:integer := source[ti];
              var lv:integer := source[ti + w - 1];
              var val:integer := (r + 1) * fv;
              for var j := 0 to r-1 do val += source[ti + j];
              for var j := 0 to r do begin
                  val += source[ri] - fv; inc(ri);
                  dest[ti] := Round(val * iar); inc(ti);
              end;
              for var j := r + 1 to (w - r -1) do begin
                  val += source[ri] - dest[li]; inc(ri); inc(li);
                  dest[ti] := Round(val * iar); inc(ti);
              end;
              for var j := w - r to w-1 do begin
                  val += lv - source[li]; inc(li);
                  dest[ti] := Round(val * iar); inc(ti);
              end;
          end;
      end;
 
      procedure boxBlurT_4(source:array of integer; dest:array of integer; w:integer; h:integer; r:integer);
      begin
          var iar:real := 1 / (r + r + 1);
          {$omp parallel for}
          For var i := 0 to w-1 do begin
              var ti:integer := i;
              var li:integer := ti;
              var ri:integer := ti + r * w;
              var fv:integer := source[ti];
              var lv:integer := source[ti + w * (h - 1)];
              var val:integer := (r + 1) * fv;
              for var j := 0 to r-1 do val += source[ti + j * w];
              for var j := 0 to r do begin
                  val += source[ri] - fv;
                  dest[ti] := Round(val * iar);
                  ri += w;
                  ti += w;
              end;
              for var j := (r + 1) to (h - r -1) do begin
                  val += (source[ri] - source[li]);
                  dest[ti] := Round(val * iar);
                  li += w;
                  ri += w;
                  ti += w;
              end;
              for var j := h - r to h-1 do begin
                  val += lv - source[li];
                  dest[ti] := Round(val * iar);
                  li += w;
                  ti += w;
              end;
          end;
      end;
    end;
    
BEGIN
  var p:picture := new Picture('sample.bmp');
  window.Width := 2*p.Width+1;
  window.Height := p.Height;
  CenterWindow;
  window.Caption := 'Fastest Gaussian Blur(with LockBits+Marshal.copy)';
  p.Draw(0,0);
  var r := 5;
  var gb:GaussianBlur := new GaussianBlur;
  var tt:Stopwatch := new Stopwatch;
  tt.Start;
  gb.GaussianBlur(p.bmp);
  p.bmp:=gb.Process(r);
  tt.Stop;
  writeln(' R: ',r,'px');
  writeln(' Time: ',tt.ElapsedMilliseconds,'ms');
  writeln(' Size: ',p.Width,'x',p.Height,'px');
  p.Draw(p.Width+1,0);  
  line(p.Width+1,0,p.Width+1,p.Height);
END.
Pascal
1
 
Полезные коды для PascalABC.NET
0
TERESHI
8 / 8 / 6
Регистрация: 26.11.2015
Сообщений: 31
21.09.2017, 23:22 #109
В: Как же всё-таки увеличить маленькое изображение в графическом окне GraphABC без сглаживания и без увеличения пикселей по отдельности(что увеличивает время работы программы)?
О:
Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
{{$reference System.Drawing.Dll}
Uses GraphABC, System.Drawing.Drawing2D;
begin
  var k := 30;                                                                  //Коэффициент преобразования
  var p := new Picture('s.png');                                                //Нужное нам изображение
  SetWindowSize(p.Width * k, p.Height * k);                                     //Изменяем размер графического окна на размер будущего изображения
  GraphWindowGraphics.SmoothingMode := SmoothingMode.HighSpeed;                 //Задаём отсутствие сглаживания
  GraphWindowGraphics.CompositingQuality := CompositingQuality.HighSpeed;       //Процесс компоновки: высокая скорость, низкое качество
  GraphWindowGraphics.InterpolationMode := InterpolationMode.NearestNeighbor;   //Интерполяция по ближайшим соседним элементам
  p.Draw(0, 0, p.Width * k, p.Height * k);                                      //Вывод увеличенного изображения
end.

1
Изображения
   
Volobuev Ilya
87 / 94 / 42
Регистрация: 25.07.2014
Сообщений: 1,745
Записей в блоге: 2
26.09.2017, 15:57 #110
В: Как найти самую длинную последовательность чисел из файла?
О:
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
const
  Path1 = 'C:\Ilya\AlgoРитмы\Файл1.txt';
  Path2 = 'C:\Ilya\AlgoРитмы\Файл2.txt';
 
var
  F1, F2: Text;
  L: List<integer>;
  N: integer;
  MaxL: integer;
 
begin
  Assign(F1, Path1);
  Assign(F2, Path2);
  Reset(F1);
  Rewrite(F2);
  
  L := new List<integer>();
  
  while not Eof(F1) do
  begin
    Readln(F1, N);
    L.Add(N);
  end;
  
  var i := 0;
  N := L[0];
  while i < L.Count do
  begin
    var len := 1;
    while (i < L.Count) and (L[i] = N) do
    begin
      Inc(len);
      Inc(i);
    end;
    if len > MaxL then
      MaxL := len;
    if i < L.Count then
      N := L[i];
  end;
  
  Write(F2, MaxL);
  Close(F1);
  Close(F2);
end.
Добавлено через 1 минуту
В: Как использовать рефлексию на PascalABC.Net?
О:
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
{Переведено с C#.}
uses System.Reflection;
 
type
  User = class
  private 
    _Name: string;
    _Age: integer;
  public 
    property Name: string read _Name write _Name;
    property Age: integer read _Age write _Age;
    
    constructor ();begin end;
    
    procedure Display() := WritelnFormat('Имя: {0} Возраст: {1}', Name, Age);
    
    function Payment(hours, perhour: integer) := hours * perhour;
  end;
 
begin
  var MyType := TypeOf(User);
  var MyType2 := System.Type.GetType('Рефлексия - пример 1.User', false, true);
  
  Writeln(MyType.ToString());
  Writeln(MyType2.ToString());
  Readln();
end.
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
{Переведено с C#.}
uses System.Reflection;
 
type
  User = class
  private 
    _Name: string;
    _Age: integer;
  public 
    property Name: string read _Name write _Name;
    property Age: integer read _Age write _Age;
    
    constructor ();begin end;
    
    procedure Display() := WritelnFormat('Имя: {0} Возраст: {1}', Name, Age);
    
    function Payment(hours, perhour: integer) := hours * perhour;
  end;
 
begin
  var Man := new User();
  Man.Name := 'Tom';
  Man.Age := 30;
  
  var MyType := Man.GetType();
  
  foreach var m in MyType.GetMembers() do
    System.Console.WriteLine(Format('{0} {1} {2}', m.DeclaringType.Name, m.MemberType, m.Name));
 
  Readln();
end.
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
{Переведено с C#.}
uses System.Reflection;
 
type
  User = class
  private 
    _Name: string;
    _Age: integer;
  public 
    property Name: string read _Name write _Name;
    property Age: integer read _Age write _Age;
    
    constructor ();begin end;
    
    procedure Display() := WritelnFormat('Имя: {0} Возраст: {1}', Name, Age);
    
    function Payment(hours, perhour: integer) := hours * perhour;
  end;
 
begin
  var Man := new User();
  Man.Name := 'Tom';
  Man.Age := 30;
  
  var MyType := Man.GetType();
  
  foreach var m in MyType.GetMethods() do
  begin
    var modifier := '';
    
    if m.IsStatic then modifier += 'static ';
    if m.IsVirtual then modifier += 'virtual';
    
    WriteFormat('{0} {1} {2}(', modifier, m.ReturnType.Name, m.Name);
    
    var parameters := m.GetParameters();
    
    for var i := 0 to Length(parameters) - 1 do
    begin
      WriteFormat('{0} {1}', parameters[i].ParameterType.Name, parameters[i].Name);
      if i + 1 < parameters.Length then Write(', ');
    end;
    Writeln(')');
  end;
  
  Readln();
end.
Добавлено через 2 минуты
В: Как нарисовать линию, используя алгоритм DDA в консоли?
О:
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
{Переведено с C#.}
procedure DrawLine();
begin
  while true do
  begin
    System.Console.Write('X: ');
    var x := System.Convert.ToInt32(System.Console.ReadLine());
    System.Console.Write('Y: ');
    var y := System.Convert.ToInt32(System.Console.ReadLine());
    System.Console.Write('X2: ');
    var x1 := System.Convert.ToInt32(System.Console.ReadLine());
    System.Console.Write('Y2: ');
    var y1 := System.Convert.ToInt32(System.Console.ReadLine());
    
    var l := Max(Abs(x1 - x), Abs(y1 - y));
    var incX := (x1 - x) / l;
    var incY := (y1 - y) / l;
    
    var cx := x * 1.0;
    var cy := y * 1.0;
    
    System.Console.BackgroundColor := System.ConsoleColor.Green; // Цвет линии.
    
    while not ((cy = y1) and (cx = x1)) do
    begin
      System.Console.SetCursorPosition(System.Convert.ToInt32(cx), System.Convert.ToInt32(cy));
      System.Console.Write(' ');
      cx += incX;
      cy += incY;
    end;
    
    System.Console.ReadKey();
    System.Console.BackgroundColor := System.ConsoleColor.Black;
    System.Console.Clear();
  end;
end;
 
begin
  System.Console.Title := 'Console';
  DrawLine();
end.
0
Volobuev Ilya
87 / 94 / 42
Регистрация: 25.07.2014
Сообщений: 1,745
Записей в блоге: 2
22.10.2017, 18:24 #111
В: Как сделать игру на составление возрастающей последовательности?
О:
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
uses GraphABC, ABCObjects;
const
  Border = 100;
 
type
  Circles = List<CircleABC>; // Описываю тип списка, параметизированного типом CircleABC. 
 
var
  Obj: CircleABC;
  DX, DY: integer;
  Move: boolean;
  Numbers: Circles;
 
function IsEqual(L2: Circles): boolean; // Проверка на корректность последовательности. Узнаем в правильном ли порядке расставлены в ней цифры.
begin
  Result := true;
  for var i := 0 to L2.Count - 1 do
    if Numbers[i].Number <> L2[i].Number then
    begin
      Result := false;
      break;
    end;
end;
 
procedure MouseUp(x, y, mb: integer); // Необходима для перемещения кружочков.
begin
  if mb = 1 then
  begin
    Move := false;
    if IsEqual(Numbers.OrderBy(x -> x.Position.X).ToList()) then
    begin
      SetWindowIsFixedSize(true);
      var A := new RectangleABC(0, 0, Window.Width, Window.Height, clYellow);
      A.Text := 'Вы расставили все числа по местам.';
      Sleep(4000);
      Halt();
    end;
  end;
end;
 
procedure MouseMove(x, y, mb: integer); // Необходима для перемещения кружочков.
begin
  if mb = 1 then
    if not Move then
    begin
      for var i := 0 to Numbers.Count - 1 do
        if Numbers[i].PtInside(x, y) then
        begin
          DX := x - Numbers[i].Position.X;
          DY := y - Numbers[i].Position.Y;
          Obj := Numbers[i];
          
          Move := true;
          break;
        end;
    end
    else
      Obj.Position := new Point(x - Dx, y - Dy);
end;
 
begin
  var W := Window.Width - 2 * Border;
  var H := Window.Height - 2 * Border;
  
  Numbers := new Circles();
  for var i := 0 to 6 do
  begin
    Numbers.Add(new CircleABC(Border + Random(W), Border + Random(H), 30, clRandom()));
    Numbers.Last().Number := i;
  end;
  
  Move := false;
  OnMouseMove := MouseMove;
  OnMouseUp := MouseUp;
end.
0
BlackStoneBlack
3 / 3 / 1
Регистрация: 10.05.2016
Сообщений: 67
03.11.2017, 16:36 #112
В: Как автоматически передвигать объект в Graph3D, а также менять его цвет?
О:
Передвижение объекта в Graph3D и изменение его цвета (на примере сферы)
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
//ВНИМАНИЕ: проверено на PascalABC.NET 3.3
 
uses Graph3D;
 
var
  ///Используемая сфера
  mobile_sphere: SphereT;
  
  ///Переменная для обеспечения бесконечного цикла программы
  stopped: Boolean;
  
  ///Координата объекта в пространстве
  x, y, z: Real;
  
  ///Коэффициент скорости смены цвета сферы
  cf, acf: Real;
  
  ///Коэффициент изменения направления вектора движения по оси z
  zf: ShortInt;
  
  ///Цветовой канал
  r, b, g: Byte;
 
begin
  //Начальные значения
  x := -5;
  y := -5;
  z := 0;
  zf := 1;
  acf := 0.05;
  
  //Начальное положение сферы
  mobile_sphere := Sphere(x, y, z, 1, ARGB(255, r, g, b));
  
  //Бесконечный цикл программы
  while not stopped do
  begin
    
    //Передвижение по квадрату в плоскости осей x и y
    if (x < 5) and (y <= -5) then
      x += 0.0001
    else if (x >= 5) and (y < 5) then
      y += 0.0001
    else if (x > -5) and (y >= 5) then
      x -= 0.0001
    else if (x <= -5) and (y > -5) then
      y -= 0.0001;
    
    //Изменение коэффициента изменения направления движения сферы по оси z
    if z >= 2 then
      zf := -1
    else if z <= -2 then
      zf := 1;
    
    //Передвижение по прямой относительно оси z
    z += zf * 0.0002;
    
    //Изменение цета по кругу
    if (r < 255) and (g = 0) and (b = 0) then
    begin
      if (r = 0) or (cf > 1) then
      begin
        cf := 0;
        r += 1;
      end;
      r += 1 * Floor(cf);
      cf += acf;
    end
    else if (r = 255) and (g < 255) and (b = 0) then
    begin
      if (g = 0) or (cf > 1) then
      begin
        cf := 0;
        g += 1;
      end;
      g += 1 * Floor(cf);
      cf += acf;
    end
    else if (r > 0) and (g = 255) and (b = 0) then
    begin
      if (r = 255) or (cf > 1) then
      begin
        cf := 0;
        r -= 1;
      end;
      r -= 1 * Floor(cf);
      cf += acf;
    end
    else if (r = 0) and (g = 255) and (b < 255) then
    begin
      if (b = 0) or (cf > 1) then
      begin
        cf := 0;
        b += 1;
      end;
      b += 1 * Floor(cf);
      cf += acf;
    end
    else if (r = 0) and (g > 0) and (b = 255) then
    begin
      if (g = 255) or (cf > 1) then
      begin
        cf := 0;
        g -= 1;
      end;
      g -= 1 * Floor(cf);
      cf += acf;
    end
    else if (r = 0) and (g = 0) and (b > 0) then
    begin
      if (b = 255) or (cf > 1) then
      begin
        cf := 0;
        b -= 1;
      end;
      b -= 1 * Floor(cf);
      cf += acf;
    end;
    
    //Передвижение сферы
    mobile_sphere.MoveTo(x, y, z);
    
    //Изменение цвета сферы
    mobile_sphere.Color := ARGB(255, r, g, b);
  end;
end.
0
Миниатюры
Полезные коды для PascalABC.NET  
DeNcHiK3713
1 / 1 / 0
Регистрация: 02.06.2016
Сообщений: 20
19.11.2017, 14:02 #113
Цитата Сообщение от BaboshinSD Посмотреть сообщение
В: Как программно выключить компьютер?
О:
Выключение компьютера
Pascal
1
2
3
4
5
6
7
8
function FindDir(): string;
begin
  Result := System.IO.Directory.GetDirectoryRoot('\WINDOWS\System32\shutdown.exe');
end;
 
begin
  Exec(FindDir + 'WINDOWS\System32\shutdown.exe', '-f');
end.
Более правильный вариант:

Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
uses
  System.Diagnostics,
 
begin
    var shutdown := new Process;
    shutdown.StartInfo.FileName := System.Environment.SystemDirectory + '\shutdown.exe';
    shutdown.StartInfo.Arguments := '/s /t 0';
    shutdown.StartInfo.WindowStyle := ProcessWindowStyle.Hidden;
    shutdown.Start();
    shutdown.WaitForExit;
end.


или как у меня
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
{$apptype windows}
{$mainresource 'shutdown.res'}
{$reference 'System.Windows.Forms.dll'}
 
uses
  System.Diagnostics,
  System.Windows.Forms;
 
begin
  var answer := System.Windows.Forms.MessageBox.Show(
    'Выключить компьютер?', 'Внимание!',
    System.Windows.Forms.MessageBoxButtons.YesNo,
    System.Windows.Forms.MessageBoxIcon.Asterisk,
    System.Windows.Forms.MessageBoxDefaultButton.Button2
  );
  if answer = System.Windows.Forms.DialogResult.Yes then begin
    var shutdown := new Process;
    shutdown.StartInfo.FileName := System.Environment.SystemDirectory + '\shutdown.exe';
    shutdown.StartInfo.Arguments := '/s /t 0';
    shutdown.StartInfo.WindowStyle := ProcessWindowStyle.Hidden;
    shutdown.Start();
    shutdown.WaitForExit;
  end;
end.
Файл ресурсов: Work.zip
0
DeNcHiK3713
1 / 1 / 0
Регистрация: 02.06.2016
Сообщений: 20
20.11.2017, 10:39 #114
Там в первом примере ошибка,
Pascal
1
2
3
4
5
6
7
8
9
10
11
uses
  System.Diagnostics;
 
begin
    var shutdown := new Process;
    shutdown.StartInfo.FileName := System.Environment.SystemDirectory + '\shutdown.exe';
    shutdown.StartInfo.Arguments := '/s /t 0';
    shutdown.StartInfo.WindowStyle := ProcessWindowStyle.Hidden;
    shutdown.Start();
    shutdown.WaitForExit;
end.
0
DeNcHiK3713
1 / 1 / 0
Регистрация: 02.06.2016
Сообщений: 20
23.12.2017, 19:15 #115
Программное открытие/закрытие привода:
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
function mciSendString(command: string; buffer: StringBuilder; bufferSize: integer; hwndCallback: System.IntPtr): integer;
  External 'winmm.dll' name 'mciSendString';
  
function open(letter: char): boolean;
begin
  if mciSendString('open ' + letter + ': type CDAudio alias drive' + letter, nil, 0, System.IntPtr.Zero) + mciSendString('set drive' + letter + ' door open', nil, 0, System.IntPtr.Zero) = 0 then Result := true else Result := false;
end;
 
function close(letter: char): boolean;
begin
  if mciSendString('open ' + letter + ': type CDAudio alias drive' + letter, nil, 0, System.IntPtr.Zero) +  mciSendString('set drive' + letter + ' door closed', nil, 0, System.IntPtr.Zero) = 0 then Result := true else Result := false;
end;
 
begin
  Writeln(open('E'));
  sleep(1500);
  Writeln(close('E'));
end.
1
Kostik654
0 / 0 / 0
Регистрация: 02.03.2017
Сообщений: 112
27.12.2017, 19:53 #116
Ошибка времени выполнения: Среда выполнения Common Language Runtime обнаружила недопустимую программу.
0
27.12.2017, 19:53
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
27.12.2017, 19:53
Привет! Вот еще темы с ответами:

Надо найти библиотеку для PascalABC NET - PascalABC.NET
Всем привет. Вот сейчас пишу движок для PascalABC NET. Для графики взял OpenGL. Теперь начал делать обработчик событий нажатий клавиш и тут...

Написать программу из задачника среды PascalABC.NET для задания integer8: - PascalABC.NET
Написать программу из задачника среды PascalABC.NET для задания integer8: Потрудитесь выложить задание должным образом оформленное, и с...

Установится ли PascalABC.NET на систему, где установлен только .NET 4.6.1? - PascalABC.NET
Привет всем. Вопрос, собственно, озвучен выше. Конкретнее: есть компьютер со свежеустановленной Win10 x64, на которой присутствует...

Переделайте "Старт ракеты" для PascalABC.net - PascalABC.NET
uses graph,crt; procedure raketa(x,y,c:integer); begin setcolor(c); line(x,y,x-10,y+10); line(x,y,x+10,y+10); ...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
116
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2018, vBulletin Solutions, Inc.