Игра о российском флаге

@Argenta · Регистрация: 29.11.2017

Студворк — интернет-сервис помощи студентам

В каждой лунке лежит белый, синий или красный шар. Одним ходом разрешается менять местами два любых шара. Добиться того, чтобы все белые шары шли первыми, все красные - последними, а синие - посередине. Если число лунок равно n, то для решения задачи достаточно сделать не более n-1 хода.
Я вот тут начала писать. Как наиболее рационально сделать так, чтоб шаров каждого цвета было одинаково и был отступ между шарами?

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
uses GraphABC;
const
 
r = 50; {радиус шарика}
n = 2;{кол во шаров каждого цвета ,задается пользователем}
nmax = 1000;
 
 
type
 
tColour = integer;
tBall = record
   colour: tColour;
end;
tArray = array [1..nmax] of tBall;
 
var 
 
t, i: integer; 
a: tArray;
b: Boolean;
 
begin
   //LockDrawing;
   SetWindowSize(800, 600);
    
   for i:=1 to 3*n  do begin
      a[i].colour:= random(n+1);
   end;
   for i:=1 to 3*n do begin
      if a[i].colour = 0 then 
         Brush.Color := clwhite
      else if a[i].colour = 1 then
         Brush.Color := clblue
      else begin 
         a[i].colour := 2;
         Brush.Color := clred;
      end;
      Ellipse((i-1)*r,0,i*r,r);
   //Redraw;
   //Sleep(1);
   end;
   repeat 
   
   
   
   
   i:= 1;
   while (i <= n) and b do begin
     if a[i].colour >= a[i+1].colour then
        b:= false;
   end;
   until b;
end.
   //Window.Clear;

@Puporev · 14.11.2018, 11:45

Сообщение от Argenta

Как наиболее рационально сделать так, чтоб шаров каждого цвета было одинаково и был отступ между шарами?

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
uses graphABC;
const r=20;
      d=10;
type tBall=record
           x:integer;
           cl:Color;
           end;
var n,c1,c2,y:integer;
    a:array[1..18] of tBall;
    b:Color;
begin
randomize;
repeat
write('Введите количество шаров одного цвета от 2 до 6 n=');//у меня больше по ширине не входит на экран
readln(n);
until n in [2..6];
//заполним массив по порядку
for var i:=1 to 3*n do
 begin
  case i mod 3 of
  1:a[i].cl:=clWhite;
  2:a[i].cl:=clBlue;
  else a[i].cl:=clRed;
  end;
  a[i].x:=i*d+(2*i-1)*r;
 end;
 //перемешаем его
for var i:=1 to 3*n do 
 begin
  c1:=random(3*n)+1;
  c2:=random(3*n)+1;
  b:=a[c1].cl;
  a[c1].cl:=a[c2].cl;
  a[c2].cl:=b;
 end;
 setwindowsize((3*n+1)*d+6*n*r,4*r);
 centerwindow;
 clearwindow(clGreen);
 y:=2*r;
 for var i:=1 to 3*n do
  begin
   setpencolor(a[i].cl);
   setbrushcolor(a[i].cl);
   circle(a[i].x,y,r);
  end; 
end.

@Argenta · 20.11.2018, 23:12 **[ТС]**

Подскажите, пожалуйста, что я еще не так делаю, когда пишу процедуру для компьютерной мыши, выделяю первый шарик и пытаюсь поменять его со вторым

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
program Flag;
 
uses GraphABC;
 
const
 
nmax = 1000;
r = 30; {радиус шарика}
n = 3;  {количество шариков одинакового цвета}
d = 40;
 
type
 
tBall = record
   colour: Color;
   x: integer;
end;
 
tArray = array [1..nmax] of tBall;
 
var 
 
i, y, c1, c2, t, k: integer; 
a: tArray;
buf: Color;
b: Boolean;
 
 
procedure MouseDown1(x, c, mb: integer);  {выделяем первый шарик}
var
   i: integer;
   found1: Boolean;
   
begin
   found1 := false;
   while not found1 do begin
     if mb = 1 then begin
        i := 1;
        while (i <= 3*n) do begin
           if (sqr(x - a[i].x) + sqr(c - y) <= sqr(r)) then begin
              SetPenColor(clWhite);
              SetPenWidth(3);
              DrawRectangle(a[i].x - r, y - r, a[i].x + r, y + r); 
              k := i;
              found1:= True;  
            end;
           i := i + 1;
        end;
     end;
   end;
end;
 
procedure MouseDown2(x, c, mb: integer); {второй шарик}
var
   i: integer;
   found2: Boolean;
   
begin
   found2 := false;
   while not found2 do begin
     if mb = 1 then begin
        i := 1;
        while (i <= 3*n) do begin
           if (sqr(x - a[i].x) + sqr(c - y) <= sqr(r)) then begin
              t := i;
              found2:= True;  
            end;
           i := i + 1;
        end;
     end;
   end;
end;
      
 
begin
   randomize;
   SetWindowSize((3*n+1)*d+6*n*r,4*r);
   CenterWindow;
   ClearWindow(clGreen);
   y:=2*r;
   
   for i:= 1 to 3*n do begin   {присваиваем цвета по порядку}
      if i mod 3 = 0 then
         a[i].colour:= clWhite
      else if i mod 3 = 1 then
         a[i].colour:= clBlue
      else 
         a[i].colour:= clRed;
      
      a[i].x:=i*d+(2*i-1)*r;
      
   end;
   for i:= 1 to 3*n do begin   {перемешиваем цвета}
      c1:= random(3*n)+1;
      c2:= random(3*n)+1;
      buf:= a[c1].colour;
      a[c1].colour:= a[c2].colour;
      a[c2].colour:= buf;
   end;
   
  
   for i:= 1 to 3*n do begin  {рисуем шары}
      SetBrushColor(clBlack);
      SetPenColor(clBlack);
      circle(a[i].x, y, round(1.5*r));
      SetBrushColor(a[i].colour);
      SetPenColor(a[i].colour);
      circle(a[i].x, y, r);
   end;
   
 // repeat 
   
   OnMouseDown := MouseDown1; { первый шарик }
   OnMouseDown := MouseDown2;  { второй шарик}
   
   buf := a[k].colour;          {меняем местами}
   a[k].colour:= a[t].colour;
   a[t].colour:= buf;
      
   
  { i:= 1;
   while (i <= n) and b do begin
     if a[i].colour >= a[i+1].colour then
        b:= false;}
  
  // until b
 
end.

@Argenta · 21.11.2018, 18:58 **[ТС]**

///

Добавлено через 4 минуты

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
program Flag;
 
uses GraphABC;
 
const
 
nmax = 1000;
r = 30; {радиус шарика}
n = 3;  {количество шариков одинакового цвета}
d = 40;
 
type
 
tBall = record
   colour: Color;
   x: integer;
   order: integer;
end;
 
tArray = array [1..nmax] of tBall;
 
var 
 
   i, y, c1, c2, t, k: integer; 
   a: tArray;
   buf: Color;
   b: Boolean;
   found1: Boolean;
   found2: Boolean;
 
function Check(a: tArray): boolean;
var
   i: integer; 
begin
   Check := True;
   for i:= 1 to 3*n do begin
      if a[i].colour = clWhite then 
         a[i].order := 0
      else if a[i].colour = clBlue then 
         a[i].order := 1
      else 
         a[i].order := 2;
   end;
   i:= 1;
   while (i <= 3*n) and Check(a) do begin
      if a[i].order  >= a[i+1].order  then
         Check := false;
      i := i + 1;
   end;
end;
  
procedure MouseDown1(x, c, mb: integer);  {выделяем первый шарик}
var
   i: integer;
   
begin
   if mb = 1 then begin
      i := 1;
      while (i <= 3*n) do begin
         if (sqr(x - a[i].x) + sqr(c - y) <= sqr(r)) then begin
            SetPenColor(clWhite);
            SetPenWidth(3);
            DrawRectangle(a[i].x - r, y - r, a[i].x + r, y + r); 
            k := i;
            found1:= True;  
         end;
         i := i + 1;
      end;
   end;
end;
  
 
procedure MouseDown2(x, c, mb: integer); {второй шарик}
var
   i: integer;
   found2: Boolean;
   
begin
   if mb = 1 then begin
      i := 1;
      while (i <= 3*n) do begin
         if (sqr(x - a[i].x) + sqr(c - y) <= sqr(r)) then begin
            SetPenColor(clWhite);
            SetPenWidth(3);
            DrawRectangle(a[i].x - r, y - r, a[i].x + r, y + r); 
            t := i;
            found2:= True;  
         end;
      i := i + 1;
     end;
   end;
end;
 
      
 
begin
   
   randomize;
   SetWindowSize((3*n+1)*d+6*n*r,4*r);
   CenterWindow;
   y:=2*r;
   
   for i:= 1 to 3*n do begin   {присваиваем цвета по порядку}
      if i mod 3 = 0 then
         a[i].colour:= clWhite
      else if i mod 3 = 1 then
         a[i].colour:= clBlue
      else 
         a[i].colour:= clRed;
      
      a[i].x:=i*d+(2*i-1)*r;
      
   end;
   for i:= 1 to 3*n do begin   {перемешиваем цвета}
      c1:= random(3*n)+1;
      c2:= random(3*n)+1;
      buf:= a[c1].colour;
      a[c1].colour:= a[c2].colour;
      a[c2].colour:= buf;
   end;
   
   ClearWindow(clGreen);
   for i:= 1 to 3*n do begin  {рисуем шары}
      SetBrushColor(clBlack);
      SetPenColor(clBlack);
      circle(a[i].x, y, round(1.5*r));
      SetBrushColor(a[i].colour);
      SetPenColor(a[i].colour);
      circle(a[i].x, y, r);
   end;
   
   repeat 
     found1:= false;
     found2:= false;
    
     while not found1 do
        OnMouseDown := MouseDown1; {первый шарик }
       
     while not found2 do
        OnMouseDown := MouseDown2;
       
     buf := a[k].colour;          {меняем местами}
     a[k].colour:= a[t].colour;
     a[t].colour:= buf;
    
     ClearWindow(clGreen);
     for i:= 1 to 3*n do begin  {рисуем шары}
       SetBrushColor(clBlack);
       SetPenColor(clBlack);
       circle(a[i].x, y, round(1.5*r));
       SetBrushColor(a[i].colour);
       SetPenColor(a[i].colour);
       circle(a[i].x, y, r);
    end;
   
    until check(a);
   
    Sleep(2000);
    CloseWindow;
         
end.

Добавлено через 13 минут
Puporev

@Puporev · 21.11.2018, 19:05

Я решать всю задачу не буду, туповат в этом.
Вы спросили

Сообщение от Argenta

сделать так, чтоб шаров каждого цвета было одинаково и был отступ между шарами?

Я ответил, больше пас.

@Get_Over_Here · 21.11.2018, 19:22

Argenta, У вас до {меняем местами} не доходит выполнение программы(зацикливается), следовательно что-то не так с процедурами MouseDown1 и MouseDown2 или циклом

Добавлено через 7 минут
Argenta, Ошибка в том, что у вас Found2 в процедуре MouseDown2 объявлена повторно, и значения присваиваются ему, а глобальная переменная не меняется(уберите её)

@Argenta · 21.11.2018, 19:48 **[ТС]**

Get_Over_Here,
Да , я уже нашла ошибку , спасибо
но теперь появилась другая
Ошибка времени выполнения: StackOverflowException: Программа завершена из-за переполнения программного стека

@Get_Over_Here · 21.11.2018, 20:01

Argenta, Это уже из-за бесконечной рекурсии(строка 45), уберите 2 условие в цикле While

Добавлено через 7 минут

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
program Flag;
 
uses GraphABC;
 
const
  
  nmax = 1000;
  r = 30; {радиус шарика}
  n = 3;  {количество шариков одинакового цвета}
  d = 40;
 
type
  
  tBall = record
    colour: Color;
    x: integer;
    order: integer;
  end;
  
  tArray = array [1..nmax] of tBall;
 
var
  
  i, y, c1, c2, t, k: integer; 
  a: tArray;
  buf: Color;
  b: Boolean;
  found1: Boolean;
  found2: Boolean;
 
function Check(a: tArray): boolean;
var
  i: integer;
begin
  Check := True;
  for i := 1 to 3 * n do 
  begin
    if a[i].colour = clWhite then 
      a[i].order := 0
    else if a[i].colour = clBlue then 
      a[i].order := 1
    else 
      a[i].order := 2;
  end;
  i := 1;
  while (i <= 3 * n) do 
  begin
    if a[i].order >= a[i + 1].order then 
      Check := false;
    i := i + 1;
  end;
end;
 
procedure MouseDown1(x, c, mb: integer);{выделяем первый шарик}
var
  i: integer;
 
begin
  if mb = 1 then begin
    i := 1;
    while (i <= 3 * n) do 
    begin
      if (sqr(x - a[i].x) + sqr(c - y) <= sqr(r)) then begin
        SetPenColor(clWhite);
        SetPenWidth(3);
        DrawRectangle(a[i].x - r, y - r, a[i].x + r, y + r); 
        k := i;
        found1 := True;  
      end;
      i := i + 1;
    end;
  end;
end;
 
 
procedure MouseDown2(x, c, mb: integer);{второй шарик}
var
  i: integer;
 
begin
  if mb = 1 then begin
    i := 1;
    while (i <= 3 * n) do 
    begin
      if (sqr(x - a[i].x) + sqr(c - y) <= sqr(r)) then begin
        SetPenColor(clWhite);
        SetPenWidth(3);
        DrawRectangle(a[i].x - r, y - r, a[i].x + r, y + r); 
        t := i;
        found2 := True;  
      end;
      i := i + 1;
    end;
  end;
end;
 
 
 
begin
  
  randomize;
  SetWindowSize((3 * n + 1) * d + 6 * n * r, 4 * r);
  CenterWindow;
  y := 2 * r;
  
  for i := 1 to 3 * n do 
  begin{присваиваем цвета по порядку}
    if i mod 3 = 0 then
      a[i].colour := clWhite
    else if i mod 3 = 1 then
      a[i].colour := clBlue
    else 
      a[i].colour := clRed;
    
    a[i].x := i * d + (2 * i - 1) * r;
    
  end;
  for i := 1 to 3 * n do 
  begin{перемешиваем цвета}
    c1 := random(3 * n) + 1;
    c2 := random(3 * n) + 1;
    buf := a[c1].colour;
    a[c1].colour := a[c2].colour;
    a[c2].colour := buf;
  end;
  
  ClearWindow(clGreen);
  for i := 1 to 3 * n do 
  begin{рисуем шары}
    SetBrushColor(clBlack);
    SetPenColor(clBlack);
    circle(a[i].x, y, round(1.5 * r));
    SetBrushColor(a[i].colour);
    SetPenColor(a[i].colour);
    circle(a[i].x, y, r);
  end;
  
  repeat
    found1 := false;
    found2 := false;
    
    while not found1 do
      OnMouseDown := MouseDown1; {первый шарик }
    
    while not found2 do
      OnMouseDown := MouseDown2;
    
    buf := a[k].colour;          {меняем местами}
    a[k].colour := a[t].colour;
    a[t].colour := buf;
    
    ClearWindow(clGreen);
    for i := 1 to 3 * n do 
    begin{рисуем шары}
      SetBrushColor(clBlack);
      SetPenColor(clBlack);
      circle(a[i].x, y, round(1.5 * r));
      SetBrushColor(a[i].colour);
      SetPenColor(a[i].colour);
      circle(a[i].x, y, r);
    end;
    
  until check(a);
  
  Sleep(2000);
  CloseWindow;
  
end.

Новые блоги и статьи Все статьи Все блоги /
модель ЗдравоСохранения 8. Подготовка к разному выполнению заданий anaschu 08.04.2026 https:/ / github. com/ shumilovas/ med2. git main ветка * содержимое блока дэлэй из старой модели теперь внутри зайца новой модели 8ATzM_2aurI	Блокировка документа от изменений, если он открыт у другого пользователя Maks 08.04.2026 Алгоритм из решения ниже реализован на примере нетипового документа, разработанного в конфигурации КА2. Задача: запретить редактирование документа, если он открыт у другого пользователя. / / . . .	Система безопасности+живучести для сервера-слоя интернета (сети). Двойная привязка. Hrethgir 08.04.2026 Далее были размышления о системе безопасности. Сообщения с наклонным текстом - мои. А как нам будет можно проверить, что ссылка наша, а не подделана хулиганами, которая выбросит на другую ветку и. . .	Модель ЗдрввоСохранения 7: больше работников, больше ресурсов. anaschu 08.04.2026 работников и заданий может быть сколько угодно, но настроено всё так, что используется пока что только 20% kYBz3eJf3jQ
Дальние перспективы сервера - слоя сети с космологическим дизайном интефейса карты и логики. Hrethgir 07.04.2026 Дальнейшее ближайшее планирование вывело к размышлениям над дальними перспективами. И вот тут может быть даже будут нужны оценки специалистов, так как в дальних перспективах всё может очень сильно. . .	Горе от ума kumehtar 07.04.2026 Эта мне ментальная установка, что вот прямо сейчас, мол, мне для полного счастья не хватает (нужное вписать), и когда я этого достигну - тогда и полный кайф. Одна из самых сильных ловушек на пути. . . .	Использование значений реквизитов справочника в документе, с определенными условиями и правами Maks 07.04.2026 1. Контроль срока действия договора Алгоритм из решения ниже реализован на примере нетипового документа "ЗаявкаНаРаботу", разработанного в конфигурации КА2. Задача: уведомлять пользователя, если. . .	Доступность команды формы по условию Maks 07.04.2026 Алгоритм из решения ниже реализован на примере нетипового документа "СписаниеМатериалов", разработанного в конфигурации КА2. Задача: сделать доступной кнопку (команда формы "ЗавершитьСписание") при. . .

Игра о российском флаге

Решение

Решение

@Get_Over_Here 79 / 49 / 23 Регистрация: 15.07.2018 Сообщений: 255
	21.11.2018, 19:22
	Argenta, У вас до {меняем местами} не доходит выполнение программы(зацикливается), следовательно что-то не так с процедурами MouseDown1 и MouseDown2 или циклом Добавлено через 7 минут Argenta, Ошибка в том, что у вас Found2 в процедуре MouseDown2 объявлена повторно, и значения присваиваются ему, а глобальная переменная не меняется(уберите её) 1

@Argenta 3 / 3 / 2 Регистрация: 29.11.2017 Сообщений: 126
	21.11.2018, 19:48 [ТС]
	Get_Over_Here, Да , я уже нашла ошибку , спасибо но теперь появилась другая Ошибка времени выполнения: StackOverflowException: Программа завершена из-за переполнения программного стека 0