Простая логическая игра 2048

SoftIce · Регистрация: 27.07.2011

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

Правила игры:

Всего две цифры, и обе они - двойки. Что делать? Очень просто, нажимайте на кнопки со стрелками. После каждого нажатия цифры будут съезжать в ту сторону, в которую указывает нажатая стрелка. Например, если в показанной комбинации нажать кнопку со стрелкой, указывающей влево, то верхняя двойка останется на месте, так как она уже находится в крайней возможной позиции, а та, которая ниже, сползет к левой границе, то есть, окажется прямо под верхней двойкой. Если же вы захотите нажать не левую стрелку, а, например, нижнюю, то обе двойки поедут вниз и окажутся в нижнем ряду, одна в первом столбце, а вторая в четвертом.
Зачем все это, спросите? А вот, зачем. Посмотрите на следующий рисунок:

Здесь вы видите уже больше разных цифр: и двойки, и четверка с восьмеркой. Давайте нажмем в этой комбинации стрелку вверх. При этом две правые двойки соединятся и на их месте возникнет одна четверка. То есть, двойки сложатся по правилам обыкновенной человеческой арифметики. Поскольку одно место освободится, восьмерка с четверкой сдвинутся на одну клетку вверх.
Попробуйте нажать стрелку влево, и все цифры сползут к левой границе, а соединятся две двойки в верхнем ряду, сложившись в одну четверку.
Все эти бессмысленные на первый взгляд манипуляции цифрами нужны для одной простой вещи: достижения заветной суммы, которую очень хорошо видно над игровым полем. Это 2048. Сдвигайте цифры, складывайте друг с другом, заставляйте их расти и добейтесь суммы 2048. Как только вы сделаете это, игра вас отпустит, вы сможете избавиться от наваждения и стать нормальным человеком

Код игры

Кликните здесь для просмотра всего текста

Visual Basic
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
Option Explicit
Const n As Integer = 4
Dim A(1 To n, 1 To n) As Integer, C(1 To n, 1 To n) As CommandButton
Dim W As Single, H As Single, TC(1 To n, 1 To n) As Single, LC(1 To n, 1 To n) As Single
 
Private Sub MoveS(ByVal s As String)
  Dim f As Boolean, i As Integer, j As Integer, k As Integer
  For k = 1 To n
    Select Case s
        Case "R"
           For i = 1 To n
               For j = 1 To n - 1
                  If A(i, j) <> 0 Then
                    If A(i, j + 1) = 0 Then A(i, j + 1) = A(i, j): A(i, j) = 0: f = True ': ChangeAnimS i, j, i, j + 1, s
                    If f Then DrawS
                    If A(i, j) = A(i, j + 1) Then A(i, j + 1) = A(i, j) * 2: A(i, j) = 0: ChangeAnimS i, j, i, j + 1, s: f = True
                  End If
               Next j
            Next i
        Case "L"
            For i = 1 To n
               For j = n To 2 Step -1
                 If A(i, j) <> 0 Then
                    If A(i, j - 1) = 0 Then A(i, j - 1) = A(i, j): A(i, j) = 0: f = True ': ChangeAnimS i, j, i, j - 1, s
                    If f Then DrawS
                    If A(i, j) = A(i, j - 1) Then A(i, j - 1) = A(i, j) * 2: A(i, j) = 0: ChangeAnimS i, j, i, j - 1, s: f = True
                  End If
               Next j
            Next i
         Case "D"
            For j = 1 To n
               For i = 1 To n - 1
                 If A(i, j) <> 0 Then
                    If A(i + 1, j) = 0 Then A(i + 1, j) = A(i, j): A(i, j) = 0: f = True ': ChangeAnimS i, j, i + 1, j, s
                    If f Then DrawS
                    If A(i, j) = A(i + 1, j) Then A(i + 1, j) = A(i, j) * 2: A(i, j) = 0: ChangeAnimS i, j, i + 1, j, s: f = True
                 End If
               Next i
            Next j
         Case "U"
            For j = 1 To n
               For i = n To 2 Step -1
                 If A(i, j) <> 0 Then
                    If A(i - 1, j) = 0 Then A(i - 1, j) = A(i, j): A(i, j) = 0: f = True ': ChangeAnimS i, j, i - 1, j, s
                    If f Then DrawS
                    If A(i, j) = A(i - 1, j) Then A(i - 1, j) = A(i, j) * 2: A(i, j) = 0: ChangeAnimS i, j, i - 1, j, s: f = True
                 End If
               Next i
            Next j
     End Select
    Next k
    If f Then AddNewS ' если передвижение было, то добавляем новую плитку
    DrawS
    GetStatusS
End Sub
 
Private Sub AddNewS(Optional ByVal n As Integer = 1)
    Dim k As Integer, m As Long, i As Long, j As Integer
    Do
        m = m + 1: i = Int(Rnd * 4 + 1): j = Int(Rnd * 4 + 1)
        If A(i, j) = 0 Then A(i, j) = 2: k = k + 1: If n = 2 Then AnimS i, j
    Loop Until k >= n Or m >= 1000
    DrawS
    If n = 1 Then AnimS i, j
End Sub
 
Private Sub DrawS()
    Dim i As Integer, j As Integer
    For i = 1 To n
        For j = 1 To n
           C(i, j).Caption = IIf(A(i, j) > 0, A(i, j), "")
           C(i, j).BackColor = IIf(A(i, j) > 0, ColorS(A(i, j)), &HC0C0C0)
           C(i, j).Top = TC(i, j): C(i, j).Left = LC(i, j): C(i, j).Height = H: C(i, j).Width = W 'выравниваем размеры и положение клеток, которые могут изменится во время "анимации"
        Next j
    Next i
    Label1.Caption = "Score:  " & ScoreS & Space(20) & "Max.Tiles:  " & MaxTilesS
End Sub
 
Private Sub AnimS(ByVal i As Integer, ByVal j As Integer)
    Dim T As Single, L As Single, k As Integer
    T = C(i, j).Top: L = C(i, j).Left
    C(i, j).Top = T + H / 2: C(i, j).Left = L + W / 2
    C(i, j).FontSize = 1: C(i, j).Width = 1: C(i, j).Height = 1
    For k = 1 To 400
       C(i, j).Width = C(i, j).Width + 2: C(i, j).Height = C(i, j).Height + 2
       C(i, j).Top = C(i, j).Top - 1: C(i, j).Left = C(i, j).Left - 1
       DoEvents
    Next k
    C(i, j).Width = W: C(i, j).Height = H: C(i, j).Top = T: C(i, j).Left = L: C(i, j).FontSize = 24
End Sub
 
Private Sub ChangeAnimS(ByVal i As Integer, ByVal j As Integer, ByVal i1 As Integer, ByVal j1 As Integer, ByVal s As String)
    Dim T As Single, L As Single, k As Integer
    T = C(i, j).Top: L = C(i, j).Left
    If s = "U" Or s = "D" Then
       Do
           C(i, j).Top = C(i, j).Top - CInt(IIf(s = "U", 2, -2))
           DoEvents
       Loop Until Abs(C(i, j).Top - C(i1, j1).Top) <= 50
     Else
       Do
           C(i, j).Left = C(i, j).Left - CInt(IIf(s = "L", 2, -2))
           DoEvents
       Loop Until Abs(C(i, j).Left - C(i1, j1).Left) <= 50
     End If
    C(i, j).Top = T: C(i, j).Left = L
End Sub
 
Private Sub GetStatusS()
    Dim f As Boolean, i As Integer, j As Integer
    If MaxTilesS >= 2048 Then MsgBox "Победа!": NewGames: Exit Sub
    For i = 1 To n
       For j = 1 To n
          If A(i, j) = 0 Then f = True 'есть пустые клетки
          If j < n Then If A(i, j) = A(i, j + 1) Then f = True 'есть рядом стоящие одинаковые
          If i < n Then If A(i + 1, j) = A(i, j) Then f = True 'есть рядом стоящие одинаковые
       Next j
    Next i
    If Not f Then
      MsgBox "Ходов больше нет!" & vbCrLf & "Набрано очков: " & ScoreS & vbCrLf & "Самая крупная плитка: " & MaxTilesS
      NewGames
    End If
End Sub
 
Private Sub NewGames()
    Dim i As Integer, j As Integer
    For i = 1 To n
        For j = 1 To n
             A(i, j) = 0
        Next j
    Next i
    DrawS
    AddNewS 2
End Sub
 
Private Function ScoreS() As Long
    Dim i As Integer, j As Integer, sc As Long
    For i = 1 To n
        For j = 1 To n
            If A(i, j) > 2 Then sc = sc + A(i, j) * (A(i, j) / 4)
        Next j
    Next i
    ScoreS = sc
End Function
 
Private Function MaxTilesS() As Long
    Dim i As Integer, j As Integer, max As Long
    For i = 1 To n
        For j = 1 To n
            If A(i, j) > max Then max = A(i, j)
        Next j
    Next i
    MaxTilesS = max
End Function
 
Private Function ColorS(ByVal CountPoint As Integer) As Long
     Select Case CountPoint
          Case 2: ColorS = RGB(250, 235, 215)    'AntiqueWhite
          Case 4: ColorS = RGB(255, 218, 185)    'PeachPuff
          Case 8: ColorS = RGB(218, 165, 32)     'Goldenrod
          Case 16: ColorS = RGB(184, 134, 11)    'DarkGoldenrod
          Case 32: ColorS = RGB(188, 143, 143)   'RosyBrown
          Case 64: ColorS = RGB(205, 92, 92)     'IndianRed
          Case 128: ColorS = RGB(160, 82, 45)    'Sienna
          Case 256: ColorS = RGB(210, 105, 30)   'Chocolate
          Case 512: ColorS = RGB(178, 34, 34)    'Firebrick
          Case 1024: ColorS = RGB(255, 140, 0)   'DarkOrange
          Case 2048: ColorS = 0
     End Select
End Function
 
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) 'определяем какая клавиша нажата
    Select Case KeyCode
        Case vbKeyUp: MoveS "U" 'Me.Caption = "Нажата кнопка вверх"
        Case vbKeyDown: MoveS "D" ' Me.Caption = "Нажата кнопка вниз"
        Case vbKeyLeft:  MoveS "L" 'Me.Caption = "Нажата кнопка влево"
        Case vbKeyRight: MoveS "R" ' Me.Caption = "Нажата кнопка вправо"
    End Select
End Sub
 
Private Sub Form_Load()
    Dim k As Integer, i As Integer, j As Integer
    Randomize
    Me.KeyPreview = True
    Me.Show
    For i = 1 To n
        For j = 1 To n
            k = k + 1: Set C(i, j) = Command1(k): C(i, j).Visible = True
            TC(i, j) = C(i, j).Top: LC(i, j) = C(i, j).Left
        Next j
    Next i
    H = C(1, 1).Height: W = C(1, 1).Width
    NewGames
End Sub
 
Private Sub Command2_Click()
    AddNewS
End Sub

SoftIce · 19.04.2015, 20:32 **[ТС]**

Добавлю только, что идея игры принадлежит не мне, моя только реализация.

@The trick · 19.04.2015, 20:37

SoftIce, спасибо за реализацию. Может перенести пост сюда?

SoftIce · 19.04.2015, 21:13 **[ТС]**

Сообщение от The trick

Может перенести пост сюда?

Нет, я думаю, не стОит.

Dragokas · 20.04.2015, 21:21

SoftIce, хочу кнопку "Подсказка из зала"

ЗЫ. Спасибо за реализацию.

Не по теме:

Коллеги на языке командной строки тоже делали".

Добавлено через 43 секунды
The trick, ~~Туда можно ссылочку и новую подветку "Игры".~~ Забыл, права есть. Сам добавлю. SoftIce, не против?

SoftIce · 20.04.2015, 21:43 **[ТС]**

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

SoftIce, не против?

Я не против.

@trxh · 19.02.2016, 18:21

а куда вписывать этот код?

Добавлено через 56 секунд
а куда вписывать этот код?

SoftIce · 19.02.2016, 18:30 **[ТС]**

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

а куда вписывать этот код?

К первому сообщению прикреплен архив проекта, там уже все "вписано" куда надо.

Новые блоги и статьи Все статьи Все блоги /
Автоматическое создание документа при проведении другого документа Maks 29.03.2026 Реализация из решения ниже выполнена на нетиповых документах, разработанных в конфигурации КА2. Есть нетиповой документ "ЗаявкаНаРемонтСпецтехники" и нетиповой документ "ПланированиеСпецтехники". В. . .	Настройка движения справочника по регистру сведений Maks 29.03.2026 Решение ниже реализовано на примере нетипового справочника "ТарифыМобильнойСвязи" разработанного в конфигурации КА2, с целью учета корпоративной мобильной связи в коммерческом предприятии. . . .	Автозаполнение реквизита при выборе элемента справочника Maks 27.03.2026 Программный код из решения ниже на примере нетипового документа "ЗаявкаНаРемонтСпецтехники" разработанного в конфигурации КА2. При выборе "Спецтехники" (Тип Справочник. Спецтехника), заполняется. . .	Сумматор с применением элементов трёх состояний. Hrethgir 26.03.2026 Тут. https:/ / fips. ru/ EGD/ ab3c85c8-836d-4866-871b-c2f0c5d77fbc Первый документ красиво выглядит, но без схемы. Это конечно не даёт никаких плюсов автору, но тем не менее. . . всё может быть. . .
Автозаполнение реквизитов при создании документа Maks 26.03.2026 Программный код из решения ниже размещается в модуле объекта документа, в процедуре "ПриСозданииНаСервере". Алгоритм проверки заполнения реализован для исключения перезаписи значения реквизита,. . .	Команды формы и диалоговое окно Maks 26.03.2026 1. Команда формы "ЗаполнитьЗапчасти". Программный код из решения ниже на примере нетипового документа "ЗаявкаНаРемонтСпецтехники" разработанного в конфигурации КА2. В качестве источника данных. . .	Кому нужен AOT? DevAlt 26.03.2026 Решил сделать простой ланчер Написал заготовку: dotnet new console --aot -o UrlHandler var items = args. Split(":"); var tag = items; var id = items; var executable = args;. . .	Отправка уведомления на почту при создании или изменении элементов справочника Maks 24.03.2026 Программная отправка письма электронной почты на примере типового справочника "Склады" в конфигурации БП3. Перед реализацией необходимо выполнить настройку системной учетной записи электронной. . .

SoftIce es geht mir gut 11274 / 4760 / 1183 Регистрация: 27.07.2011 Сообщений: 11,439
	19.04.2015, 20:32 [ТС]
	Добавлю только, что идея игры принадлежит не мне, моя только реализация. 0

@The trick Модератор 10057 / 3902 / 884 Регистрация: 22.02.2013 Сообщений: 5,853 Записей в блоге: 79
	19.04.2015, 20:37
	SoftIce, спасибо за реализацию. Может перенести пост сюда? 0

Dragokas 18033 / 7736 / 892 Регистрация: 25.12.2011 Сообщений: 11,502 Записей в блоге: 16
	20.04.2015, 21:21
	SoftIce, хочу кнопку "Подсказка из зала" ЗЫ. Спасибо за реализацию. Не по теме: Коллеги на языке командной строки тоже делали". Добавлено через 43 секунды The trick, ~~Туда можно ссылочку и новую подветку "Игры".~~ Забыл, права есть. Сам добавлю. SoftIce, не против? 0

@trxh 0 / 0 / 0 Регистрация: 19.02.2016 Сообщений: 1
	19.02.2016, 18:21
	а куда вписывать этот код? Добавлено через 56 секунд а куда вписывать этот код? 0