Простая логическая игра 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

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

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

Новые блоги и статьи Все статьи Все блоги /
PhpStorm 2025.3: WSL Terminal всегда стартует в ~ and_y87 14.12.2025 PhpStorm 2025. 3: WSL Terminal всегда стартует в ~ (home), игнорируя директорию проекта Симптом: После обновления до PhpStorm 2025. 3 встроенный терминал WSL открывается в домашней директории. . .	Access VikBal 11.12.2025 Помогите пожалуйста !! Как объединить 2 одинаковые БД Access с разными данными.	Новый ноутбук volvo 07.12.2025 Всем привет. По скидке в "черную пятницу" взял себе новый ноутбук Lenovo ThinkBook 16 G7 на Амазоне: Ryzen 5 7533HS 64 Gb DDR5 1Tb NVMe 16" Full HD Display Win11 Pro	Музыка, написанная Искусственным Интеллектом volvo 04.12.2025 Всем привет. Некоторое время назад меня заинтересовало, что уже умеет ИИ в плане написания музыки для песен, и, собственно, исполнения этих самых песен. Стихов у нас много, уже вышли 4 книги, еще 3. . .	От async/await к виртуальным потокам в Python IndentationError 23.11.2025 Армин Ронахер поставил под сомнение async/ await. Создатель Flask заявляет: цветные функции - провал, виртуальные потоки - решение. Не threading-динозавры, а новое поколение лёгких потоков. Откат?. . .
Поиск "дружественных имён" СОМ портов Argus19 22.11.2025 Поиск "дружественных имён" СОМ портов На странице: https:/ / norseev. ru/ 2018/ 01/ 04/ comportlist_windows/ нашёл схожую тему. Там приведён код на С++, который показывает только имена СОМ портов, типа,. . .	Сколько Государство потратило денег на меня, обеспечивая инсулином. Programma_Boinc 20.11.2025 Сколько Государство потратило денег на меня, обеспечивая инсулином. Вот решила сделать интересный приблизительный подсчет, сколько государство потратило на меня денег на покупку инсулинов. . . .	Ломающие изменения в C#.NStar Alpha Etyuhibosecyu 20.11.2025 Уже можно не только тестировать, но и пользоваться C#. NStar - писать оконные приложения, содержащие надписи, кнопки, текстовые поля и даже изображения, например, моя игра "Три в ряд" написана на этом. . .	Мысли в слух kumehtar 18.11.2025 Кстати, совсем недавно имел разговор на тему медитаций с людьми. И обнаружил, что они вообще не понимают что такое медитация и зачем она нужна. Самые базовые вещи. Для них это - когда просто люди. . .	Создание Single Page Application на фреймах krapotkin 16.11.2025 Статья исключительно для начинающих. Подходы оригинальностью не блещут. В век Веб все очень привыкли к дизайну Single-Page-Application . Быстренько разберем подход "на фреймах". Мы делаем одну. . .

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

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

Dragokas 18030 / 7733 / 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