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

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

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

Новые блоги и статьи Все статьи Все блоги /
SDL3 для Web (WebAssembly): Загрузка PNG с прозрачным фоном с помощью SDL_LoadPNG (без SDL3_image) 8Observer8 11.02.2026 Содержание блога Библиотека SDL3 содержит встроенные инструменты для базовой работы с изображениями - без использования библиотеки SDL3_image. Пошагово создадим проект для загрузки изображения. . .	SDL3 для Web (WebAssembly): Загрузка PNG с прозрачным фоном с помощью SDL3_image 8Observer8 10.02.2026 Содержание блога Библиотека SDL3_image содержит инструменты для расширенной работы с изображениями. Пошагово создадим проект для загрузки изображения формата PNG с альфа-каналом (с прозрачным. . .	Установка Qt-версии Lazarus IDE в Debian Trixie Xfce volvo 10.02.2026 В общем, достали меня глюки IDE Лазаруса, собранной с использованием набора виджетов Gtk2 (конкретно: если набирать текст в редакторе и вызвать подсказку через Ctrl+Space, то после закрытия окошка. . .	SDL3 для Web (WebAssembly): Работа со звуком через SDL3_mixer 8Observer8 08.02.2026 Содержание блога Пошагово создадим проект для загрузки звукового файла и воспроизведения звука с помощью библиотеки SDL3_mixer. Звук будет воспроизводиться по клику мышки по холсту на Desktop и по. . .
SDL3 для Web (WebAssembly): Основы отладки веб-приложений на SDL3 по USB и Wi-Fi, запущенных в браузере мобильных устройств 8Observer8 07.02.2026 Содержание блога Браузер Chrome имеет средства для отладки мобильных веб-приложений по USB. В этой пошаговой инструкции ограничимся работой с консолью. Вывод в консоль - это часть процесса. . .	SDL3 для Web (WebAssembly): Обработчик клика мыши в браузере ПК и касания экрана в браузере на мобильном устройстве 8Observer8 02.02.2026 Содержание блога Для начала пошагово создадим рабочий пример для подготовки к экспериментам в браузере ПК и в браузере мобильного устройства. Потом напишем обработчик клика мыши и обработчик. . .	Философия технологии iceja 01.02.2026 На мой взгляд у человека в технических проектах остается роль генерального директора. Все остальное нейронки делают уже лучше человека. Они не могут нести предпринимательские риски, не могут. . .	SDL3 для Web (WebAssembly): Вывод текста со шрифтом TTF с помощью SDL3_ttf 8Observer8 01.02.2026 Содержание блога В этой пошаговой инструкции создадим с нуля веб-приложение, которое выводит текст в окне браузера. Запустим на Android на локальном сервере. Загрузим Release на бесплатный. . .

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

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

Dragokas 18031 / 7734 / 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