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

PascalABC.NET

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

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

23.03.2013, 15:03. Просмотров 160953. Ответов 113

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

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


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


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

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

Работа с графикой:
Исходники программ, работающих с графикой и графическими библиотеками (GraphABC, OpenGL и пр.).
Проектирование игр:
Инструкции, советы и пр.:
Инструкции, касающиеся работы с PascalABC.NET, советы для новичков и пр.
Работа со строками:
Базовые алгоритмы:
21
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
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. Чем и как его можно откомпилировать? Просто стоит задача...

113
Syrax
25 / 16 / 5
Регистрация: 09.12.2009
Сообщений: 98
11.01.2015, 15:06 #91
Q: Возможно ли создать на PascalABC.Net клиент-серверное приложение?
A: Возможно. Пример реализации клиент-серверного чата.
Кликните здесь для просмотра всего текста

Сервер
Кликните здесь для просмотра всего текста
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
uses
  System, System.Net, System.Net.Sockets, System.Threading, crt;
 
type
  TByteArray = array of byte;
 
var
  client: array [1..64] of TCPClient;
  s_str: array [1..64] of NetworkStream;
  s_raw: TByteArray;
  listener: system.Net.Sockets.TcpListener;
  s_ip, msg, cl_str: string;
  s_port, length, i, n: integer;
  thr: array [1..64] of thread;
 
procedure chat(data: object); 
var
  i, err:integer;
  name: string;
begin
  Val(data.ToString, i, err);
  s_str[i] := client[i].GetStream;
  length := s_str[i].Read(s_raw, 0, s_raw.Length);
  name := System.Text.Encoding.Default.GetString(s_raw, 0, length);
  writeln('Есть клиент ', name, '.');
  msg := Concat('Добро пожаловать на сервер ', s_ip, ', ', name, '!');
  s_str[i].Write(System.Text.Encoding.Default.GetBytes(msg), 0, msg.Length);
  try
    while true do 
    begin
      length := s_str[i].Read(s_raw, 0, s_raw.Length);
      cl_str := System.Text.Encoding.Default.GetString(s_raw, 0, length);
      writeln(name, ': ', cl_str);
      for j:integer:=1 to n do begin
        s_str[j] := client[j].GetStream;
        msg := name + ' [' + DateTime.Now.ToString + ']: ' + cl_str{+#13#10};
        if s_str[j].CanWrite then
          s_str[j].Write(System.Text.Encoding.Default.GetBytes(msg), 0, msg.Length)
        else
          writeln('Ошибка. Невозможно отправить сообщение клиенту.');
      end;
    end;
  except
    textcolor(4);
    writeln('Клиент отключился.');
    textcolor(2);
  end;
end;
 
 
begin
  s_raw := TByteArray(System.Array.CreateInstance(typeof(byte), 1024));
  try
    textcolor(14);
    write('Введите IP: ');
    readln(s_ip);
    write('Введите порт: ');
    readln(s_port);
    listener := TCPListener.Create(IPAddress.Parse(s_ip), s_port);
    listener.Start(64);
    textcolor(2);
    writeln('Готово. Ожидаем подключения...');
  except
    textcolor(4);
    writeln('Ошибка. Приложение будет закрыто.');
    sleep(2500);
    exit;
  end;
  i := 0;
  while true do
    if listener.Pending then
    begin
      i += 1;
      n:=i;
      client[i] := listener.AcceptTcpClient();
      thr[i] := new Thread(chat);
      thr[i].Start(i);
    end;
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
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
  System, System.Net, System.Net.Sockets, System.Threading, crt;
 
type
  TByteArray = array of byte;
 
var
  client: TCPClient;
  s_str: NetworkStream;
  s_raw: TByteArray;
  s_ip, cl_str, cl_stro, name: string;
  s_port, length: integer;
  thr_s, thr_r: Thread;
 
procedure send;
begin
  while true do
  begin
    readln(cl_str);
    s_str.Write(System.Text.Encoding.Default.GetBytes(cl_str), 0, cl_str.Length);
  end;
end;
 
procedure read;
begin
  while true do
  begin
    length := s_str.Read(s_raw, 0, s_raw.Length);
    cl_stro := System.Text.Encoding.Default.GetString(s_raw, 0, length);
    writeln(cl_stro);
  end;
end;
 
begin
  s_raw := TByteArray(System.Array.CreateInstance(typeof(byte), 1024));
  try
    textcolor(14);
    write('Введите IP: ');
    readln(s_ip);
    write('Введите порт: ');
    readln(s_port);
  except
    textcolor(4);
    writeln('Какая-то ошибка... Закрываем приложение.');
    sleep(2500);
    exit;
  end;
  textcolor(2);
  try
    client := TCPClient.Create;
    client.Connect(ipAddress.Parse(s_ip), s_port);
    if client.Connected = true then
    begin
      write('Введите имя: '); readln(name);
      s_str := client.GetStream;
      s_str.Write(System.Text.Encoding.Default.GetBytes(name), 0, name.Length);
      writeln('Подключено к ', s_ip);
      length := s_str.Read(s_raw, 0, s_raw.Length);
      cl_str := System.Text.Encoding.Default.GetString(s_raw, 0, length);
      writeln(cl_str);
      thr_s := new Thread(send);
      thr_s.Start;
      thr_r := new Thread(read);
      thr_r.Start;
    end;
  except
    if client.Connected = false then
    begin
      textcolor(4);
      writeln('Подключение не удалось. Выход...');
      sleep(2500);
      exit;
    end;
  end;
end.

0
pavelDev
40 / 40 / 19
Регистрация: 13.11.2013
Сообщений: 175
Записей в блоге: 1
18.10.2015, 18:25 #92
Шум Перлина !!!
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
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
{$apptype windows}
{$reference 'System.Windows.Forms.dll'}
{$reference 'System.Drawing.dll'}
uses
  System.Windows.Forms, System.Drawing, System.IO, System,System.Threading;
 
type
//оринальный код был взят здесь [url]https://lotsacode.wordpress.com/2010/02/24/perlin-noise-in-c/[/url]
//под pascal abc.net код был переписан pavelDev
  PerlinNoise = class
  private 
  GradientSizeTable:=256;
  _random: System.random;
    _gradients := new double[GradientSizeTable * 3];
    _perm: array of byte := (
                    225, 155, 210, 108, 175, 199, 221, 144, 203, 116, 70, 213, 69, 158, 33, 252,
                      5, 82, 173, 133, 222, 139, 174, 27, 9, 71, 90, 246, 75, 130, 91, 191,
                    169, 138, 2, 151, 194, 235, 81, 7, 25, 113, 228, 159, 205, 253, 134, 142,
                    248, 65, 224, 217, 22, 121, 229, 63, 89, 103, 96, 104, 156, 17, 201, 129,
                     36, 8, 165, 110, 237, 117, 231, 56, 132, 211, 152, 20, 181, 111, 239, 218,
                    170, 163, 51, 172, 157, 47, 80, 212, 176, 250, 87, 49, 99, 242, 136, 189,
                    162, 115, 44, 43, 124, 94, 150, 16, 141, 247, 32, 10, 198, 223, 255, 72,
                     53, 131, 84, 57, 220, 197, 58, 50, 208, 11, 241, 28, 3, 192, 62, 202,
                     18, 215, 153, 24, 76, 41, 15, 179, 39, 46, 55, 6, 128, 167, 23, 188,
                    106, 34, 187, 140, 164, 73, 112, 182, 244, 195, 227, 13, 35, 77, 196, 185,
                     26, 200, 226, 119, 31, 123, 168, 125, 249, 68, 183, 230, 177, 135, 160, 180,
                     12, 1, 243, 148, 102, 166, 38, 238, 251, 37, 240, 126, 64, 74, 161, 40,
                    184, 149, 171, 178, 101, 66, 29, 59, 146, 61, 254, 107, 42, 86, 154, 4,
                    236, 232, 120, 21, 233, 209, 45, 98, 193, 114, 78, 19, 206, 14, 118, 127,
                     48, 79, 147, 85, 30, 207, 219, 54, 88, 234, 190, 122, 95, 67, 143, 109,
                    137, 214, 145, 93, 92, 100, 245, 0, 216, 186, 60, 83, 105, 97, 204, 52);
 
 
 
    procedure InitGradients();
    begin
      for var i := 0 to GradientSizeTable - 1 do
      begin
        
        var z := 1.0 - 2.0 * _random.NextDouble();
        var r := Math.Sqrt(1.0 - z * z);
        var theta := 2 * Math.PI * _random.NextDouble();
        _gradients[i * 3] := r * Math.Cos(theta);
        _gradients[i * 3 + 1] := r * Math.Sin(theta);
        _gradients[i * 3 + 2] := z;
      end;
    end;
    
    function Permutate(x: integer): integer;
    begin
      var mask := GradientSizeTable - 1;
      Result := _perm[x and mask];
      //return _perm[x & mask];
    end;
    
    function Index(ix, iy, iz: integer): integer;
    begin
            // Turn an XYZ triplet into a single gradient table index.
      Result := Permutate(ix + Permutate(iy + Permutate(iz)));
    end;
    
    function Lattice(ix, iy, iz: integer; fx, fy, fz: double): double;
    begin
            // Look up a random gradient at [ix,iy,iz] and dot it with the [fx,fy,fz] vector.
      var index := Index(ix, iy, iz);
      var g := index * 3;
      Result := _gradients[g] * fx + _gradients[g + 1] * fy + _gradients[g + 2] * fz;
    end;
     function Lerp( t,value0,value1:double):double;
        begin
            result:=value0 + t * (value1 - value0);
        end;
        function Smooth(x:double):double;
        begin
            //* Smoothing curve. This is used to calculate interpolants so that the noise
              //doesn't look blocky when the frequency is low. */
            result:=x* x * (3 - 2 * x);
        end;
        
  public 
      function Noise(x,y,z:double):double;
        begin
            { The main noise function. Looks up the pseudorandom gradients at the nearest
               lattice points, dots them with the input vector, and interpolates the
               results to produce a single output value in [0, 1] range.}
              
              //int ix = (int)Math.Floor(x);
  
            var ix := Convert.ToInt32(Math.Floor(x));
            var fx0 := x - ix;
            var fx1 := fx0 - 1;
            var wx := Smooth(fx0);
            
            // int iy = (int)Math.Floor(y);
            var iy := Convert.ToInt32(Math.Floor(y));
            var fy0 := y - iy;
            var fy1:= fy0 - 1;
            var wy := Smooth(fy0);
 
            //int iz = (int)Math.Floor(z);
             var iz := Convert.ToInt32(Math.Floor(z));
              var fz0 := z - iz;
            var fz1:= fz0 - 1;
            var wz := Smooth(fz0);
 
            var vx0 := Lattice(ix, iy, iz, fx0, fy0, fz0);
            var vx1 := Lattice(ix + 1, iy, iz, fx1, fy0, fz0);
            var vy0 := Lerp(wx, vx0, vx1);
 
            vx0 := Lattice(ix, iy + 1, iz, fx0, fy1, fz0);
            vx1 := Lattice(ix + 1, iy + 1, iz, fx1, fy1, fz0);
            var vy1 := Lerp(wx, vx0, vx1);
 
            var vz0 := Lerp(wy, vy0, vy1);
 
            vx0 := Lattice(ix, iy, iz + 1, fx0, fy0, fz1);
            vx1 := Lattice(ix + 1, iy, iz + 1, fx1, fy0, fz1);
            vy0 := Lerp(wx, vx0, vx1);
 
            vx0 := Lattice(ix, iy + 1, iz + 1, fx0, fy1, fz1);
            vx1 := Lattice(ix + 1, iy + 1, iz + 1, fx1, fy1, fz1);
            vy1 := Lerp(wx, vx0, vx1);
 
            var vz1 := Lerp(wy, vy0, vy1);
            Result:= Lerp(wz, vz0, vz1);
        end;
       constructor  create(seed:integer);
        begin
            _random := new Random(seed);
            InitGradients();
        end;
 
  
  end;
  
var f:Form;
b:Bitmap;
pbox:PictureBox;
num1,num2,num3:NumericUpDown;
function GeneratePerlinNoiseBitmap(_size:size;scale:pointf;seed:integer):Bitmap;
begin
Result:=new Bitmap(_size.Width,_size.Height);
var PNoise:=new PerlinNoise(seed);
 
 var widthDivisor := scale.X /_size.Width;
    var heightDivisor := scale.Y /_size.Height;
    for var i:=0 to Result.Width-1 do
    for var j:=0 to Result.Height-1 do
    begin
            var v:=
                // First octave
                (PNoise.Noise(2 * i * widthDivisor, 2 * j * heightDivisor, -0.5) + 1) / 2 * 0.7 +
                // Second octave
                (PNoise.Noise(4 * i * widthDivisor, 4 * j * heightDivisor, 0) + 1) / 2 * 0.2 +
                // Third octave
                (PNoise.Noise(8 * i * widthDivisor, 8 * j * heightDivisor, +0.5) + 1) / 2 * 0.1;
            
            v := Math.Min(1.0,Math.Max(0.0, v) );
            var o :=System.Convert.ToByte(v * 255);
            Result.SetPixel(i,j,Color.FromArgb(o,o,o));
         //   return Color.FromArgb(b, b, b);
        
       end; 
end;
 
 
procedure setControlSize();
begin
num1.Size:=new System.Drawing.Size(f.ClientSize.Width,num1.Size.Height);
num2.Size:=num1.Size;
num3.Size:=num2.Size;
 
pbox.Size:=new System.Drawing.Size(f.ClientSize.Width,f.ClientSize.Height-num1.Height-num2.Height-num3.Height);
pbox.Location:=new System.Drawing.Point(0,0);
num1.Location:=new System.Drawing.Point(0,pbox.Location.Y+pbox.Size.Height);
num2.Location:=new System.Drawing.Point(0,pbox.Location.Y+pbox.Size.Height+num1.Height);
num3.Location:=new System.Drawing.Point(0,pbox.Location.Y+pbox.Size.Height+num1.Height+num2.Height);
end;
 
procedure UPD(sender:object);
begin
pbox.Image:=GeneratePerlinNoiseBitmap(pbox.ClientSize,new pointf(Convert.ToInt32(num1.Value)/10,Convert.ToInt32(num2.Value)/10),Convert.ToInt32(num3.Value));
end;
 
procedure fsizechanged(sender:object;E:System.EventArgs);
begin
setControlSize;
  ThreadPool.QueueUserWorkItem(UPD);
end;
procedure Update(sender:object;E:System.EventArgs);
begin
  ThreadPool.QueueUserWorkItem(UPD);
end;
procedure fkd(sender:object;E:KeyEventArgs);
begin
if (e.KeyCode=Keys.F1) and (pbox.Image<>nil) then
begin
var sdlg:=new SaveFileDialog;
sdlg.filter:='BMP files (*.BMP)|*.BMP';
if sdlg.ShowDialog()=DialogResult.OK then 
pbox.Image.Save(sdlg.FileName,System.Drawing.imaging.imageformat.Bmp);
end;
end;
 
begin
 
 
 
f:=new Form();
f.StartPosition:=FormStartPosition.CenterScreen;
f.Text:='Шум Перлина(F1-сохранить)';
pbox:=new PictureBox();
num1:=new NumericUpDown();
num2:=new NumericUpDown();
num1.value:=10;
num2.value:=num1.Value;
 
num1.ValueChanged+=Update;
num2.ValueChanged+=Update;
 
num1.Maximum:=10000;
num2.Maximum:=10000;
 
num3:=new NumericUpDown();;
num3.Value:=99;
num3.ValueChanged+=Update;
 
 
f.Size:=new System.Drawing.Size(300,300+num1.Height+num2.Height);
setcontrolsize;
 
f.Controls.Add(pbox);
f.Controls.Add(num1);
f.Controls.Add(num2);
f.Controls.Add(num3);
f.SizeChanged+=fsizeChanged;
 
f.Load+=Update;
 
for var i:=0 to f.Controls.Count-1 do
f.Controls[i].KeyDown+=fkd;
f.KeyDown+=fkd;
 
Application.Run(f);
end.
1
pavelDev
40 / 40 / 19
Регистрация: 13.11.2013
Сообщений: 175
Записей в блоге: 1
23.01.2016, 16:08 #93
передать тип как параметр подпрограммы
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
uses
  System;
 
type
  i = interface
    procedure ia;
  end;
  c1 = class(i)
  public 
    procedure ia;
    begin
      write('c1 class');
    end;
  
  end;
  c2 = class(i)
  public 
    procedure ia;
    begin
      write('c2 class');
    end;
  end;
 
function ToI(value: System.type ): i;
begin
  var baseType := System.Activator.CreateInstance(value);
  try
    Result := i(basetype);
  except
    raise new Exception('inncorect parametr "value"');
  end;
end;
 
begin
  var cc := ToI(typeof(c1));
  cc.ia;
  writeln();
  cc := ToI(typeof(c2));
  cc.ia;
end.
0
pavelDev
40 / 40 / 19
Регистрация: 13.11.2013
Сообщений: 175
Записей в блоге: 1
30.01.2016, 23:11 #94
Generic-функция способная работать только с определенными типами
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
function Test<T>(value:T):integer;
begin
var arr:array of System.Type:=(typeof(double),typeof(integer));
var isc:boolean:=false;
//write(typeof(t));
for var i:=0 to arr.GetLength(0)-1 do
if typeof(t)=arr[i] then
begin
isc:=true;
break;
end;
if isc=false then raise new System.ArgumentException('inncorect type('+typeof(t).FullName+')');
//...
end;
begin
Test(999);//все нормально 
Test('314');//исключение
end.
0
Chilipalmer777
14 / 14 / 8
Регистрация: 20.03.2016
Сообщений: 168
23.03.2016, 09:24 #95
Вниманию тех, кто будет использовать функцию Count { подсчет количества символов в строке }
Код, приведенный на этой ветке форума(пост № 18) для функции Count НЕ совсем верен.
Для примера, подсчитайте при помощи этой функции количество символов 'o'(англ.) в слове 'slovo' и поймете где ошибка в коде функции.
Удачи!
p.s. Если не поняли в чем ошибка, напишите мне в ЛС - объясню.
0
BlackStoneBlack
3 / 3 / 1
Регистрация: 10.05.2016
Сообщений: 67
29.05.2016, 11:29 #96
В: Как сделать мультиразрешение в графическом окне?
О:
Мультиразрешение в GraphABC
Будем делать мультиразрешение через квадраты:
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
program Multiscreen;
uses GraphABC;
var recpixel, recpixelS, w, h, x, y: integer; //"Конечные" квадраты, ширина и высота окна, координаты
     recpixelR: real; //"Начальный" квадрат
 
procedure MyWindow;
begin
//Стандартные настройки окна. Некоторые строчки можно исключить - по желанию.
Window.Title:='Мультиразрешение в GraphABC'; 
Window.SetSize(1024,768); //Ширина и высота окна. Можно изменять произвольно, чтобы тестировать
Window.IsFixedSize:=true; 
Window.CenterOnScreen;
//Window.Maximize; //Окно на весь экран
//Здесь пошло самое интересное 
w:=Window.Width; 
h:=Window.Height;
recpixelR:=h/24; //Выясняем реальный размер квадрата на экране, исходя из его размера
//Делаем расчет именно по высоте, чтобы программа снизу не обрезалась на широкоформатных экранах
recpixelS:=round(recpixelR); //У нас не может быть, к примеру, 0,7 пикселя, посему округляем до ближайшего значения
recpixel:=recpixelS*2; //Увеличиваем размер квадрата вдвое, что, в общем-то, не обязательно
end;
 
procedure DrawRec(i, n: integer);
begin
//Можно не задавать заного значение w и h, но тогда далее программа может не сработать
w:=Window.Width; 
h:=Window.Height;
//Отрисуем поле 50х50
//Но при разрешении, к примеру, 1024х768 будет видно поле 16 квадратов на 12 квадратов
n:=50*50;
for i:=1 to n do
begin
if (i mod 17)=0 
then begin
y:=y+recpixel;
x:=0;
end;
Rectangle(x,y,x+recpixel,y+recpixel);
x:=x+recpixel;
end;
//Отрисуем закрашенный прямоугольник, задав ему координаты, которые зависят от размера окна и размера recpixel
y:=(h-recpixel*4)  div 2 + recpixel;
x:=(w-recpixel*4) div 2;
SetBrushColor(clRed);
Rectangle(x,y,x+recpixel*4,y+recpixel);
end;
 
begin
MyWindow;
DrawRec(1,1);
end.

Образец
Полезные коды для PascalABC.NET


Добавлено через 16 минут
Сейчас увидел ошибку в своем коде "Мультиразрешение":
В чем ошибка
Все довольно легко. Код (процедура DrawRec):
Pascal
1
2
3
4
5
6
7
8
9
10
for i:=1 to n do
begin
if (i mod 17)=0 
then begin
y:=y+recpixel;
x:=0;
end;
Rectangle(x,y,x+recpixel,y+recpixel);
x:=x+recpixel;
end;
Нужно поменять на:
Pascal
1
2
3
4
5
6
7
8
9
10
for i:=1 to n do
begin
if (i mod 50)=0 
then begin
y:=y+recpixel;
x:=0;
end;
Rectangle(x,y,x+recpixel,y+recpixel);
x:=x+recpixel;
end;
Так бэкграунд будет просто рациональнее отрисовываться, идеальным квадратом. Внешне изменений не должно быть.
0
DeNcHiK3713
0 / 0 / 0
Регистрация: 02.06.2016
Сообщений: 16
05.06.2016, 12:47 #97
BaboshinSD, Я делал форму через дизайнер pascalabc.net и {$mainresource имя ресурса} не работает.
0
BlackStoneBlack
3 / 3 / 1
Регистрация: 10.05.2016
Сообщений: 67
12.06.2016, 17:39 #98
В: Как создать Excel-таблицу через программу PascalABC.NET?
О:
Простейшая таблица

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
//для примера возьмем русских классиков
program easytable;
var f: Text;
begin
assign(f, 'table.csv'); //файл должен сразу уже лежать в папке с программой
rewrite(f); //открываем файл для перезаписи (записывает поверх старого)
writeln(f, 'Фамилия;Имя;Отчество'); //делаем шапку таблицы
writeln(f, 'Пушкин;Александр;Сергеевич');
writeln(f, 'Фет;Афанасий;Афанасьевич');
writeln(f, 'Гоголь;Николай;Васильевич');
close(f);
end.

Результат
В файле table.csv должно появиться:
 
A
B
C
1ФамилияИмяОтчество
2ПушкинАлександрСергеевич
3ФетАфанасийАфанасьевич
4ГогольНиколайВасильевич
0
groser
1 / 1 / 0
Регистрация: 26.02.2014
Сообщений: 25
15.06.2016, 12:49 #99
Вы каждый раз создаёте новый массив и булевую переменную, от которых можно отказаться и упростить/укоротить код. Конечно, в идеале надо вынести массив с "рабочими" типами в переменную, но это не так и сложно. Кстати, можно было бы вообще использовать Array.Contains(value) вместо ручного прогона, работает он одинаково. Вот мой вариант:
Pascal
1
2
3
4
5
6
7
8
9
procedure wat<T>(x:T);
begin
  if typeof(T) in [typeof(integer), typeof(real)] then // целое или вещественное
    writeln(sqr(System.Convert.ToDouble(x))) // преобразование к "рабочему" типу
  else {raise} writeln('incorrect type: ' + typeof(T).FullName); // не тот тип
end;
begin
  wat(10);  wat(20.0);  wat('30');
end.
0
silver47
0 / 0 / 0
Регистрация: 11.11.2015
Сообщений: 2
16.07.2016, 11:49 #100
Как использовать функции OnMouseDown и OnKeyDown во всей программе?
Кликните здесь для просмотра всего текста
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
uses graphABC;
var
  MouseX, MouseY, MouseK, Key: integer;
 
procedure mouse(x, y, mb: integer);
begin
  repeat
    MouseX := x;
    MouseY := y;
    MouseK := mb;
  until MouseK = -4;
end;
 
procedure keyboard(k: integer);
begin
  repeat
    Key := K;
  until MouseK = -4;
end;
 
begin
  OnMouseDown := mouse;
  OnKeyDown := keyboard;
end.
0
split2705
0 / 0 / 0
Регистрация: 08.09.2016
Сообщений: 1
08.09.2016, 04:53 #101
Цитата Сообщение от pavelDev Посмотреть сообщение
вот так можно ПОЛУЧИТЬ ЛОКАЛЬНЫЙ IP
Pascal
1
2
3
begin
writeln(System.Net.Dns.GetHostByName(System.Net.Dns.GetHostName).AddressList[0].ToString);
end.
Pascal
1
2
3
4
5
6
// Если IP несколько 
begin
var i :integer;
for i:=0 to System.Net.Dns.GetHostByName(System.Net.Dns.GetHostName).AddressList.Length-1 do
writeln(System.Net.Dns.GetHostByName(System.Net.Dns.GetHostName).AddressList[i].ToString);
end.
0
pavelDev
40 / 40 / 19
Регистрация: 13.11.2013
Сообщений: 175
Записей в блоге: 1
03.01.2017, 19:49 #102
Имеется некоторый цвет, полученный с помощью статического метода FromArgb, необходимо получить его эквивалент из списка статических полей класса Color и вывести его имя на экран(напр. red).
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
{$reference System.Drawing.dll}
uses System.Drawing,System.Reflection;
 
function Color.isEquivalence(Col: Color): boolean;
begin
  result := (Col.A = self.A) and (col.R = self.R) and (col.G = self.G) and (col.B = self.B);
  //result := self.ToArgb() = Col.ToArgb()
end;
 
function Color.GetEquivalence(): Color;
begin
  var prop := typeof(Color).GetProperties();
  for var i := 0 to prop.Length - 1 do
    if prop[i].PropertyType = typeof(Color) then
    begin
      var mem := prop[i].GetMethod;
      var cur := Color(mem.Invoke(mem, nil));
      if self.isEquivalence(cur) then
      begin
        result := cur;
        exit;
      end;
    end;
  result := self;
end;
 
begin
  var col := Color.FromArgb(255, 0, 128, 0);
  Writeln(col.Name);
  Write(col.GetEquivalence().Name);  
end.
0
nastia_fool
0 / 0 / 0
Регистрация: 13.02.2017
Сообщений: 2
14.02.2017, 20:32 #103
Анимация, две улитки и облачка
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
USES graphabc;
var
  i, k, z: integer;
 
procedure ul(x, y: integer);
begin
  setpenwidth(2);
  setpencolor(clblack);
  circle(x, y, 50);floodfill(x, y, clgold);
  circle(x, y, 35);floodfill(x, y, clblue);
  circle(x, y, 20);floodfill(x, y, RgB(random(255), random(255), random(255)));
  circle(x + 90, y - 10, 20);floodfill(x + 90, y - 10, clgreen);
  circle(x + 80, y - 15, 3);floodfill(x + 80, y - 15, clblack);
  circle(x + 100, y - 15, 3);floodfill(x + 100, y - 15, clblack);
  line(x + 85, y, x + 95, y);
  line(x + 90, y - 30, x + 105, y - 45);
  line(x + 90, y - 30, x + 75, y - 45);
  line(x + 5, y + 50, x + 90, y + 10);
  line(x + 45, y + 50, x + 90, y + 10);
  line(x + 5, y + 50, x + 45, y + 50);
  floodfill(x + 34, y + 47, clgreen);
end;
 
procedure obl(x, y: integer);
begin
  setbrushcolor(clblue);
  circle(x + 25 + random(5), y + random(5), 15 + random(5));
  circle(x + 52 + random(5), y + random(5), 19 + random(5));
  circle(x + 75 + random(5), y + random(5), 15 + random(5));
end;
 
begin
  lockdrawing;
  while true do
  begin
    z := 400;
    for i := 100 to 500 do
    begin
      clearwindow;
      obl(40, 30);
      obl(170, 60);
      obl(350, 50);
      obl(455, 35);
      ul(i, z);
      ul(i - 70, 300);
      floodfill(100, 200, clLime);
      redraw;
      sleep(10);
    end;
    if i = 500 then 
      i := 1;
  end;
end.
0
PascalAbcNet
1 / 1 / 1
Регистрация: 11.04.2017
Сообщений: 58
09.05.2017, 10:51 #104
Добавлено через 1 минуту
В как програмно выключить компьютер? выйти из системы? перезагрузить компьютер?
О
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', '-s');// -s выключение компьютера, -f выход из системы,-r перезагрузка
end.
в теме было только про выход из системы -f подбором букв наугад я нашел для выключения и перезагрузки
Pascal
1
Exec(FindDir + 'WINDOWS\System32\shutdown.exe', '-s');
в этой строке можно -s выключение компьютера заменить на
-f выход из системы и на -r перезагрузка.
0
BlackStoneBlack
3 / 3 / 1
Регистрация: 10.05.2016
Сообщений: 67
09.05.2017, 15:07 #105
В: Как получить контроль над формой, создаваемой в модуле GraphABC?
О:
Управление формой из модуля GraphABC

Для этих целей разработчики оставили функцию GraphABC.MainForm, возвращающую форму данного модуля.
При этом ее можно использовать напрямую или же определить отдельную переменную типа System.Windows.Forms.Form:

Pascal
1
2
3
4
5
//Импортируем библиотеку
uses System.Windows.Forms;
 
//Определяем переменную 
var window: Form := GraphABC.MainForm;
С помощью этой функции мы можем использовать функции и процедуры моудля GraphABC, которые облегчают жизнь в рисовании, и при этом не ограничиваться функционалом данного модуля. Таким образом, мы можем сделать форму, создаваемую в этом модуле, без рамки и растянуть ее на весь экран:

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
program fullscreen_and_without_bounds;
 
uses
  
  //Стандартный модуль PascalABC.NET для работы с графикой 
  GraphABC,
 
  //Пространство имен форм 
  System.Windows.Forms;
 
begin
 
  //Получаем текущую границу окна
  GraphABC.MainForm.Bounds := Screen.PrimaryScreen.Bounds;
  
  //Устанавливаем стиль границы окна в положение "Нет"
  GraphABC.MainForm.FormBorderStyle := FormBorderStyle.None;
  
  //-------------------
  // Установим размер окна, который будет равен разрешению рабочего стола.
  // Функция GraphABC.ScreenWidth возвращает ширину экрана в пикселях.
  // Функция GraphABC.ScreenWidth возвращает высоту экрана в пикселях.
  //-------------------
  GraphABC.SetWindowSize(GraphABC.ScreenWidth, GraphABC.ScreenHeight);
  
  //Отцентруем полученное окно
  GraphABC.CenterWindow;
  
end.
0
09.05.2017, 15:07
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
09.05.2017, 15:07
Привет! Вот еще темы с ответами:

Надо найти библиотеку для 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); ...


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

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

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