PureBasic Forums - English

http://www.purebasic.com
https://www.purebasic.fr/english/

2048 (AZJIO)

https://www.purebasic.fr/english/viewtopic.php?t=87068

Page 1 of 1

2048 (AZJIO)

Posted: Wed Jun 11, 2025 8:35 pm
by AZJIO
A2048

Download yandex

Image

Code: Select all

;- TOP
; AZJIO 2025.06.11-2025.06.27
; https://www.purebasic.fr/english/viewtopic.php?t=87068

EnableExplicit

; Создание структуры, для выравнивания в колонке счёта рекордов
CompilerIf #PB_Compiler_OS = #PB_OS_Windows
	Global ListViewSpalte.LV_COLUMN
	ListViewSpalte\mask = #LVCF_FMT
CompilerEndIf

;- # Constants
#Password$ = "1111111"
#Menu = 0
#Timer = 0
#Font = 0
#Font1 = 1
#FontFize = 33
#Window = 0
#WinScore = 1
#HeightBtnRefresh = 56
#Taskbar = 80 ; поправка на панель задач при изменении размера окна
CompilerIf  #PB_Compiler_OS = #PB_OS_Windows
	#FontName$ = "Arial"
CompilerElse
	#FontName$ = "Sans"
CompilerEndIf


;- ● Enumeration
Enumeration Gadget
	#Score
	#btnMenu
	#cnv
	#Style
	#LV
EndEnumeration

Enumeration Menu
	#mNew
	#mAbout
	#mUndo
	#mRecords
	#mExitScore
	#mLeft
	#mRight
	#mUp
	#mDown
EndEnumeration

Structure NP
	n.i
	x.i
	y.i
	m.i
EndStructure



XIncludeFile "ForA2048.pb"


;- ● Global
Global s = 80, x, y, i, j, bRefresh = #True
Global WinHeight, WinWidth, tmp, GameStep, c, flgUndo, LastMove, MoveNumber
Global Score, ScoreOld
Global FontDivider.f = 2.5


Global RecordsMax = 15
Global UserName$ = ""
Global DspWidth, DspHeight
Global ini$, PathConfig$

; Global cr0 = Clr(1, c)
Global cr2 = $453B9B
Global cr4 = $4B0195
Global cr8 = $B400B4
Global cr16 = $AD006A
Global cr32 = $878F00
Global cr64 = $BFA800
Global cr128 = $FF9F00
Global cr256 = $D26068
Global cr512 = $00A3A0
Global cr1024 = $4ECA8E
Global cr2048 = $22A24F
Global cr4096 = $72ADC0
Global cr8192 = $3EAFFC
Global cr16384 = $C0AD72
Global cr32768 = $DBA6AA

Global crScore = $3333ee

Global Dim nxy(3, 3)
Global Dim nxyZ(3, 3)
Global Dim MoveCache.NP(4)
; 0 - пустое, иногда id, если построено на отдельных элементах
; 1 - число на кнопке
; 2 - x-позиция
; 3 - y-позиция
; i - индекс массива от 1 до 16 или линия последовательности
; последовательность собрана, когда числа на кнопках (nxy(i, 1)) совпадает с индексом массива i.
; Проверяем в обратном порядке, так как низ собирают последним

Global Dim Clr(4, 1)
Clr(0, 0) = $c7c7c7
Clr(1, 0) = $3c3c3c
Clr(2, 0) = $696969 ;- удалить
Clr(3, 0) = $696969
Clr(4, 0) = $282828

Clr(0, 1) = 0
Clr(1, 1) = $e1e1e1
Clr(2, 1) = $f0f0f0
Clr(3, 1) = $f0f0f0
Clr(4, 1) = $adadad

; 0 текст кнопки
; 1 фон кнопки
; 2 фон пустышки
; 3 фон окна
; 4 цвет каймы кнопки

; Clr(2, 0) = $111111
; Global Clr(0, c) = $0088FF
; Global Clr(1, c) = $003133

Global isLFont
Global indentX, indentY

;- ● Declare
Declare reButton(i, z = 1)
Declare Refresh()
Declare reArr(o, u, n)
Declare reDraw()
Declare SizeWindow()
Declare Event_Timer()
Declare New()
Declare MenuEvents()
Declare ToLeft()
Declare ToTop()
Declare NewTile()
; Declare CalculateRating()
Declare GUI3()
Declare DrawTextScore()
Declare.s SortRes(Out$)
Declare.s ReadRecords()
Declare AddRecords(Score)
; Declare SplitL(String.s, List StringList.s(), Separator.s = " ")



ExamineDesktops()
DspWidth = DesktopWidth(0)
DspHeight = DesktopHeight(0)

;- ● Global 2
Global DPI.d = 1
CompilerIf #PB_Compiler_OS = #PB_OS_Windows
	Define hDC0 = GetWindowDC_(0)
	DPI.d = GetDeviceCaps_(hDC0, #LOGPIXELSY) / 96
	ReleaseDC_(0, hDC0)
CompilerEndIf

Define ForceLang
Define UserIntLang
; Определение языка интерфейса и применение
; Определяет язык ОС
CompilerSelect #PB_Compiler_OS
	CompilerCase #PB_OS_Windows
		Global *Lang
		If OpenLibrary(0, "kernel32.dll")
			*Lang = GetFunction(0, "GetUserDefaultUILanguage")
			If *Lang And CallFunctionFast(*Lang) = 1049 ; ru
				UserIntLang = 1
			EndIf
			CloseLibrary(0)
		EndIf
	CompilerCase #PB_OS_Linux
		If ExamineEnvironmentVariables()
			While NextEnvironmentVariable()
				If Left(EnvironmentVariableName(), 4) = "LANG" And Left(EnvironmentVariableValue(), 2) = "ru"
					; LANG=ru_RU.UTF-8
					; LANGUAGE=ru
					UserIntLang = 1
					Break
				EndIf
			Wend
		EndIf
CompilerEndSelect

;- Language En
#CountStrLang = 12
Global Dim Lng.s(#CountStrLang)
Lng(1) = "A2048"
Lng(2) = "New"
Lng(3) = "Style"
Lng(4) = "Undo"
Lng(5) = "Game over"
Lng(6) = "About"
Lng(7) = "Highscore"
Lng(8) = "Enter the name of the winner for the leaderboard"
Lng(9) = "Name?"
Lng(10) = "Name"
Lng(11) = "Date / Time"
Lng(12) = "Score"


;- ini
PathConfig$ = GetPathPart(ProgramFilename())
If FileSize(PathConfig$ + "A2048.ini") = -1
	CompilerSelect #PB_Compiler_OS
		CompilerCase #PB_OS_Windows
			PathConfig$ = GetHomeDirectory() + "AppData\Roaming\A2048\"
		CompilerCase #PB_OS_Linux
			PathConfig$ = GetHomeDirectory() + ".config/A2048/"
			; 		CompilerCase #PB_OS_MacOS
			; 			PathConfig$ = GetHomeDirectory() + "Library/Application Support/A2048/"
	CompilerEndSelect
EndIf

ini$ = PathConfig$ + "A2048.ini"
If FileSize(PathConfig$) = -1
	ForceDirectories(GetPathPart(PathConfig$))
EndIf

If OpenPreferences(ini$)

	If PreferenceGroup("color")
		crScore = ColorValidate(ReadPreferenceString("cScore", ""), crScore)
		cr2 = ColorValidate(ReadPreferenceString("c2", ""), cr2)
		cr4 = ColorValidate(ReadPreferenceString("c4", ""), cr4)
		cr8 = ColorValidate(ReadPreferenceString("c8", ""), cr8)
		cr16 = ColorValidate(ReadPreferenceString("c16", ""), cr16)
		cr32 = ColorValidate(ReadPreferenceString("c32", ""), cr32)
		cr64 = ColorValidate(ReadPreferenceString("c64", ""), cr64)
		cr128 = ColorValidate(ReadPreferenceString("c128", ""), cr128)
		cr256 = ColorValidate(ReadPreferenceString("c256", ""), cr256)
		cr512 = ColorValidate(ReadPreferenceString("c512", ""), cr512)
		cr1024 = ColorValidate(ReadPreferenceString("c1024", ""), cr1024)
		cr2048 = ColorValidate(ReadPreferenceString("c2048", ""), cr2048)
		cr4096 = ColorValidate(ReadPreferenceString("c4096", ""), cr4096)
		cr8192 = ColorValidate(ReadPreferenceString("c8192", ""), cr8192)
		cr16384 = ColorValidate(ReadPreferenceString("c16384", ""), cr16384)
		cr32768 = ColorValidate(ReadPreferenceString("c32768", ""), cr32768)
	EndIf

	If PreferenceGroup("set")
		s = ReadPreferenceInteger("square", 80)
		s = RangeCheck(s, 36, 220) ; ограничение стартовых размеров, но не ограничивает в ресайзе.
		ForceLang = ReadPreferenceInteger("forcelang", ForceLang)
		RecordsMax = ReadPreferenceInteger("recordsmax", RecordsMax)
		RecordsMax = RangeCheck(RecordsMax, 3, 30)
		UserName$ = ReadPreferenceString("user", "") ; Если задано имя, то вопрос о имени никогда не будет задаваться.
	EndIf
	ClosePreferences()
EndIf

; Здесь нужно прочитать флаг из ini-файла определяющий принудительный язык, где
; 0 - автоматически
; -1 - принудительно первый
; 1 - принудительно второй
; Тем самым будучи в России можно выбрать англ язык или будучи в союзных республиках выбрать русский язык
If ForceLang = 1
	UserIntLang = 0
ElseIf ForceLang = 2
	UserIntLang = 1
EndIf

Procedure SetLangTxt(PathLang$)
	Protected file_id, Format, i, tmp$
	
	file_id = ReadFile(#PB_Any, PathLang$) 
	If file_id ; Если удалось открыть дескриптор файла, то
		Format = ReadStringFormat(file_id) ;  перемещаем указатель после метки BOM
		i=0
		While Eof(file_id) = 0        ; Цикл, пока не будет достигнут конец файла. (Eof = 'Конец файла')
			tmp$ =  ReadString(file_id, Format) ; читаем строку
			tmp$ = RTrim(tmp$ , #CR$) ; коррекция если в Windows
			If Asc(tmp$) And Asc(tmp$) <> ';'
				i+1
				If i > #CountStrLang ; массив Lng() уже задан, но если строк больше нужного, то не разрешаем лишнее
					Break
				EndIf
; 				Lng(i) = ReplaceString(tmp$, "\n", #LF$)
				Lng(i) = tmp$
			Else
				Continue
			EndIf
		Wend
		CloseFile(file_id)
	EndIf
	; Else
	; SaveFile_Buff(PathLang$, ?LangFile, ?LangFileend - ?LangFile)
EndProcedure


; Если языковой файл существует, то использует его
If FileSize(PathConfig$ + "Lang.txt") > 100
	UserIntLang = 0
	SetLangTxt(PathConfig$ + "Lang.txt")
EndIf

;- Language Ru
; Поддержка русского языка
If UserIntLang
	Lng(1) = "A2048"
	Lng(2) = "Новая"
	Lng(3) = "Стиль"
	Lng(4) = "Отменить"
	Lng(5) = "Игра окончена"
	Lng(6) = "О программе"
	Lng(7) = "Рекорды"
	Lng(8) = "Укажите имя победителя для таблицы рекордов"
	Lng(9) = "Имя?"
	Lng(10) = "Имя"
	Lng(11) = "Дата / Время"
	Lng(12) = "Очки"
EndIf

WinWidth = s * 4
WinHeight = s * 4 + #HeightBtnRefresh + #Taskbar

Procedure isGameOver(*test.Integer)
	Protected flgEnd = 1
	For i = 1 To 16
		If *test\i = 0
			flgEnd = 0
			Break
		EndIf
		*test + SizeOf(Integer)
	Next
	ProcedureReturn flgEnd
EndProcedure


Procedure Move()
	If isGameOver(@nxy()) ; проверяет, что есть хотя бы одна пустая плитка для возможности перемещения
		SetGadgetText(#Score, Str(Score))
		AddRecords(Score)
; 		DrawTextScore()
		MessageRequester("", Lng(5) + #CRLF$ + Lng(12) + ":" + #TAB$ + Str(Score))
		New()
		ProcedureReturn
	EndIf
	If CompareMemory(@nxy(), @nxyZ(), SizeOf(Integer) * 16) ; если массивы одинаковы после перемещения, то не добавляем
		ProcedureReturn
	EndIf
	If NewTile() ; при создании кнопки не удалось создать, нет пустого поля. В этом уже нет необходимости из-за isGameOver()
		SetGadgetText(#Score, Str(Score))
		MessageRequester(Str(Score), Lng(5))
		New()
		ProcedureReturn
	EndIf
	reDraw()
	SetGadgetText(#Score, Str(Score))
EndProcedure


Procedure MenuEvents()
	Protected x1

	Select Event()
		Case #PB_Event_Menu        ; кликнут элемент всплывающего Меню
			Select EventMenu()
				Case #mRecords
					GUI3()
				Case #mNew
					New()
				Case #mUndo
					; Debug "#mUndo"
					If MoveNumber = 0
						ProcedureReturn
					EndIf
					CopyArray(nxyZ(), nxy())
					reDraw()
					flgUndo = 1
					; MoveNumber - 1
					Score = ScoreOld
					SetGadgetText(#Score, Str(Score))

				Case #mLeft
					CopyArray(nxy(), nxyZ())
					ToLeft()
					LastMove = 1
					Move()

				Case #mRight
					CopyArray(nxy(), nxyZ())
					For y = 0 To 3
						Swap nxy(0, y), nxy(3, y)
						Swap nxy(1, y), nxy(2, y)
					Next
					ToLeft()
					For y = 0 To 3
						Swap nxy(0, y), nxy(3, y)
						Swap nxy(1, y), nxy(2, y)
					Next
					LastMove = 2
					Move()

				Case #mUp
					CopyArray(nxy(), nxyZ())
					ToTop()
					LastMove = 3
					Move()

				Case #mDown
					CopyArray(nxy(), nxyZ())
					For x = 0 To 3
						Swap nxy(x, 0), nxy(x, 3)
						Swap nxy(x, 1), nxy(x, 2)
					Next
					ToTop()
					For x = 0 To 3
						Swap nxy(x, 0), nxy(x, 3)
						Swap nxy(x, 1), nxy(x, 2)
					Next
					LastMove = 4
					Move()
				Case #mExitScore
					CloseWindow(#WinScore)
					DisableWindow(#Window, #False)
				Case #mAbout
					MessageRequester(Lng(6), "Author AZJIO" + #CR$ + #CR$ + "2025.06.27 (PureBasic)" + #CR$ + "2025.06.21 (SpiderBasic)")
			EndSelect
	EndSelect
EndProcedure

Procedure Events()
	Protected CnvsY, CnvsX, index

	Select Event()
		Case #PB_Event_Gadget
			Select EventGadget()
				Case #cnv
					Select EventType()
						Case #PB_EventType_LeftClick, #PB_EventType_RightClick
							DisplayPopupMenu(#Menu, WindowID(#Window)) ; show popup menu
					EndSelect
				Case #Style
					c + 1
					If c > ArraySize(Clr(), 2)
						c = 0
					EndIf
					SetWindowColor(#Window, Clr(3, c))
					reDraw()
					; Debug c
				Case #btnMenu

					If EventType() = #PB_EventType_LeftClick;, #PB_EventType_RightClick
						DisplayPopupMenu(#Menu, WindowID(#Window)) ; show popup menu
					EndIf
			EndSelect
	EndSelect


EndProcedure


CompilerSelect #PB_Compiler_OS
	CompilerCase #PB_OS_Linux
		UseGIFImageDecoder()
		; https://www.purebasic.fr/english/viewtopic.php?p=531374#p531374
		ImportC ""
			gtk_window_set_icon(a.l, b.l)
		EndImport

		DataSection
			IconTitle:
			IncludeBinary "A2048.gif"
			IconTitleend:
		EndDataSection
		CatchImage(0, ?IconTitle)
CompilerEndSelect


;-┌──GUI──┐
If OpenWindow(#Window, 0, 0, 4*s, 4*s + #HeightBtnRefresh, "A2048", #PB_Window_SystemMenu | #PB_Window_MinimizeGadget | #PB_Window_ScreenCentered | #PB_Window_SizeGadget)
	CompilerIf #PB_Compiler_OS = #PB_OS_Linux
		gtk_window_set_icon_(WindowID(#Window), ImageID(0)) ; назначаем иконку в заголовке
	CompilerEndIf
	; WindowBounds(#Window, 132, 132 + #HeightBtnRefresh, WinHeight - #Taskbar - #HeightBtnRefresh, WinHeight - #Taskbar)
	CanvasGadget(#cnv, 0, 0, 4*s, 4*s)

	If LoadFont(#Font, #FontName$, s / FontDivider)
		isLFont = 1
	EndIf

	BindGadgetEvent(#cnv, @Events(), #PB_EventType_LeftClick)

;- ├ Buttons
	CanvasGadget(#Score, 0, s * 4, s * 2, #HeightBtnRefresh)
	TextGadget(#Score, 0, s * 4, s * 2, #HeightBtnRefresh, "0", #PB_Text_Center)
	If LoadFont(#Font1, #FontName$, #FontFize)
		SetGadgetFont(#Score, FontID(#Font1))
	EndIf
	SetGadgetColor(#Score,  #PB_Gadget_FrontColor , crScore)
; 	BindGadgetEvent(#New, @Events(), #PB_EventType_LeftClick)
	ButtonGadget(#Style, s * 2, s * 4, s, #HeightBtnRefresh, Lng(3))
	BindGadgetEvent(#Style, @Events(), #PB_EventType_LeftClick)
	ButtonGadget(#btnMenu, s * 3, s * 4, s, #HeightBtnRefresh, Chr($2630))
	BindGadgetEvent(#btnMenu, @Events(), #PB_EventType_LeftClick)

;- ├ Menu
	If CreatePopupMenu(#Menu)
		MenuItem(#mNew, Lng(2))
		MenuItem(#mUndo, Lng(4) + #TAB$ + "Ctrl+Z")
		MenuItem(#mRecords, Lng(7))
		MenuItem(#mAbout, Lng(6))
	EndIf
; 	BindMenuEvent(#Menu, #mAbout, @About())
	BindEvent(#PB_Event_Menu, @MenuEvents())

	BindEvent(#PB_Event_SizeWindow, @SizeWindow())
	BindEvent(#PB_Event_Timer, @Event_Timer())

;- ├ Keyboard
	AddKeyboardShortcut(#Window, #PB_Shortcut_Left, #mLeft)
	AddKeyboardShortcut(#Window, #PB_Shortcut_Right, #mRight)
	AddKeyboardShortcut(#Window, #PB_Shortcut_Up, #mUp)
	AddKeyboardShortcut(#Window, #PB_Shortcut_Down, #mDown)
	AddKeyboardShortcut(#Window, #PB_Shortcut_Control | #PB_Shortcut_Z, #mUndo)
	AddKeyboardShortcut(#Window, #PB_Shortcut_Back, #mUndo)
	
	New()

;-└──GUI──┘
	Repeat
		If WaitWindowEvent() = #PB_Event_CloseWindow
			If EventWindow() = #WinScore
				CloseWindow(#WinScore)
				DisableWindow(#Window, #False)
			Else
				CloseWindow(#Window)
				End
			EndIf
		EndIf
	ForEver 
EndIf


; Procedure CalculateRating()
; 	Protected Rating
; 	For y = 0 To 3
; 		For x = 0 To 3
; 			Rating + nxy(x, y)
; 		Next
; 	Next
; 	ProcedureReturn Rating
; 	ProcedureReturn Score
; EndProcedure

Procedure NewTile()
	Protected Count0, R
	; Debug "NewTile"
; 	Debug MoveCache(LastMove)\m
; 	Debug MoveNumber
; 	Debug "========================================"
	If flgUndo And MoveCache(LastMove)\n And MoveCache(LastMove)\m = MoveNumber And nxy(MoveCache(LastMove)\x, MoveCache(LastMove)\y) = 0
		flgUndo = 0
		; MoveNumber + 1
		nxy(MoveCache(LastMove)\x, MoveCache(LastMove)\y) = MoveCache(LastMove)\n
; 		Debug MoveNumber
	Else
		For y = 0 To 3
			For x = 0 To 3
				If nxy(x, y) = 0
					Count0 + 1
				EndIf
			Next
		Next
		If Count0 = 0
			ProcedureReturn 1
		EndIf
		R = Random(Count0, 1)
		Count0 = 1
		For y = 0 To 3
			For x = 0 To 3
				If nxy(x, y) = 0
					If Count0 = R
						If Random(9) > 7
							nxy(x, y) = 4 ; 20%
						Else
							nxy(x, y) = 2 ; 80%
						EndIf
						; каждый ход запоминается позиция нового появления квадрата и направление перемещения, поэтому
						; если отменить и использовать тоже действие, то квадрат появляется там же.
						MoveNumber + 1
						MoveCache(LastMove)\n = nxy(x, y)
						MoveCache(LastMove)\x = x
						MoveCache(LastMove)\y = y
						MoveCache(LastMove)\m = MoveNumber
						Break 2
					EndIf
					Count0 + 1
				EndIf
			Next
		Next
	EndIf
	ProcedureReturn 0
EndProcedure


Procedure ResizeFont()
	indentY = 0
	FreeFont(#Font)
	If LoadFont(#Font, #FontName$, s / FontDivider)
		isLFont = 1
	EndIf
EndProcedure


Procedure ToLeft()
	Protected x1, tmpScore
	; проверка пустот
	For y = 0 To 3
		x1 = 0
		For x = 0 To 2
			If nxy(x, y)
				x1 + 1
			ElseIf nxy(x, y) = 0 And nxy(x + 1, y)
				nxy(x1, y) = nxy(x + 1, y)
				nxy(x + 1, y) = 0
				x1 + 1
			EndIf
		Next
	Next
	ScoreOld = Score
	For y = 0 To 3
		For x = 1 To 3
			If nxy(x, y) And nxy(x, y) = nxy(x - 1, y)
				nxy(x - 1, y) = nxy(x, y) * 2
				nxy(x, y) = 0
				tmpScore + nxy(x - 1, y)
				
; 				Уменьшать шрифт при увеличении числа на плитке
				If FontDivider = 2.5 And nxy(x - 1, y) > 127
					FontDivider = 2.8
					ResizeFont()
				ElseIf FontDivider = 2.8 And nxy(x - 1, y) > 512
					FontDivider = 3.5
					ResizeFont()
				ElseIf FontDivider = 3.5 And nxy(x - 1, y) > 8192
					FontDivider = 4.5
					ResizeFont()
				EndIf
			EndIf
		Next
	Next
	Score + tmpScore
	; проверка пустот
	For y = 0 To 3
		x1 = 0
		For x = 0 To 2
			If nxy(x, y)
				x1 + 1
			ElseIf nxy(x, y) = 0 And nxy(x + 1, y)
				nxy(x1, y) = nxy(x + 1, y)
				nxy(x + 1, y) = 0
				x1 + 1
			EndIf
		Next
	Next
EndProcedure


Procedure ToTop()
	Protected y1, tmpScore
	; проверка пустот
	For x = 0 To 3
		y1 = 0
		For y = 0 To 2
			If nxy(x, y)
				y1 + 1
			ElseIf nxy(x, y) = 0 And nxy(x, y + 1)
				nxy(x, y1) = nxy(x, y + 1)
				nxy(x, y + 1) = 0
				y1 + 1
			EndIf
		Next
	Next
	ScoreOld = Score
	For x = 0 To 3
		For y = 1 To 3
			If nxy(x, y) And nxy(x, y) = nxy(x, y - 1)
				nxy(x, y - 1) = nxy(x, y) * 2
				nxy(x, y) = 0
				tmpScore + nxy(x, y - 1)
				
; 				Уменьшать шрифт при увеличении числа на плитке
				If FontDivider = 2.5 And nxy(x, y - 1) > 127
					FontDivider = 2.8
					ResizeFont()
				ElseIf FontDivider = 2.8 And nxy(x, y - 1) > 512
					FontDivider = 3.5
					ResizeFont()
				ElseIf FontDivider = 3.5 And nxy(x, y - 1) > 8192
					FontDivider = 4.5
					ResizeFont()
				EndIf
			EndIf
		Next
	Next
	Score + tmpScore
	; проверка пустот
	For x = 0 To 3
		y1 = 0
		For y = 0 To 2
			If nxy(x, y)
				y1 + 1
			ElseIf nxy(x, y) = 0 And nxy(x, y + 1)
				nxy(x, y1) = nxy(x, y + 1)
				nxy(x, y + 1) = 0
				y1 + 1
			EndIf
		Next
	Next
EndProcedure


Procedure New()
; 	Debug "New"
	Protected x1, y1, index, s2 = s * DPI
	Score = 0
	ScoreOld = 0
	FontDivider = 2.5
; 	If StartDrawing(CanvasOutput(#cnv))
		; Box(0, 0, s2 * 4, s2 * 4, Clr(3, c))
		; DrawingMode(#PB_2DDrawing_Transparent)
		; If isLFont
			; DrawingFont(FontID(#Font))
		; EndIf
		; If Not indentY
			; indentY = (s2 - TextHeight("1")) / 2
		; EndIf

		; Генерируем кнопки
	For x = 0 To 3
		For y = 0 To 3
			nxy(x, y) = 0
		Next
	Next
	x1 = Random(2)
	y1 = Random(2)
		; direction = Random(1)
	nxy(x1, y1) = 2
		; DrawText(x1 * s2 + indentX, y1 * s2 + indentY, "2", Clr(0, c), Clr(1, c))
	If Random(1)
		nxy(x1, y1 + 1) = 2
			; DrawText(x1 * s2 + indentX, (y1+1) * s2 + indentY, "2", Clr(0, c), $453b9b)
	Else
		nxy(x1 + 1, y1) = 2
			; DrawText((x1+1) * s2 + indentX, y1 * s2 + indentY, "2", Clr(0, c), $453b9b)
	EndIf
		; StopDrawing()
; 	EndIf

	reDraw()
	MoveNumber = 0
	SetGadgetText(#Score, Str(Score))

EndProcedure


Procedure reDraw()
	Protected index, s2 = s * DPI
	If StartDrawing(CanvasOutput(#cnv))
		Box(0, 0, s2 * 4, s2 * 4, Clr(3, c))
		DrawingMode(#PB_2DDrawing_Transparent)
		If isLFont
			DrawingFont(FontID(#Font))
		EndIf
		If Not indentY
			indentY = (s2 - TextHeight("1")) / 2
		EndIf

		For x = 0 To 3
			For y = 0 To 3
				; nxy(x, y) = 0
				; Debug nxy(indent)\n
				indentX = (s2 - TextWidth(Str(nxy(x, y)))) / 2
				; Box(x * s2, y * s2, s2, s2, Clr(4, c))
				Box(x * s2 + 1, y * s2 + 1, s2 - 2, s2 - 2, Clr(4, c))
				Select nxy(x, y)
					Case 0 : tmp = Clr(1, c)
					Case 2 : tmp = cr2
					Case 4 : tmp = cr4
					Case 8 : tmp = cr8
					Case 16 : tmp = cr16
					Case 32 : tmp = cr32
					Case 64 : tmp = cr64
					Case 128 : tmp = cr128
					Case 256 : tmp = cr256
					Case 512 : tmp = cr512
					Case 1024 : tmp = cr1024
					Case 2048 : tmp = cr2048
					Case 4096 : tmp = cr4096
					Case 8192 : tmp = cr8192
					Case 16384 : tmp = cr16384
					Case 32768 : tmp = cr32768
				EndSelect

				Box(x * s2 + 2, y * s2 + 2, s2 - 4, s2 - 4, tmp)
				; Числа только для двух новых кнопок
				If nxy(x, y)
					DrawText(x * s2 + indentX, y * s2 + indentY, Str(nxy(x, y)), Clr(0, c), Clr(1, c))
				EndIf
			Next
		Next
		StopDrawing()
	EndIf
EndProcedure


Procedure Event_Timer()
	CompilerIf  #PB_Compiler_OS <> #PB_OS_Windows
		ResizeWindow(#Window, #PB_Ignore, #PB_Ignore, s * 4, s * 4 + #HeightBtnRefresh)
	CompilerEndIf
	indentY = 0
	FreeFont(#Font)
	If LoadFont(#Font, #FontName$, s / FontDivider)
		isLFont = 1
	EndIf
	FreeFont(#Font1)
	If LoadFont(#Font1, #FontName$, #FontFize)
		SetGadgetFont(#Score, FontID(#Font1))
	EndIf
	reDraw()
	RemoveWindowTimer(#Window, #Timer)
EndProcedure

Procedure SizeWindow()
	Protected i, tmp
	WinHeight = WindowHeight(#Window)
	WinWidth = WindowWidth(#Window)
	If WinWidth > WinHeight - #Taskbar
		WinHeight = WinWidth + #Taskbar
	Else
		WinWidth = WinHeight - #Taskbar
	EndIf
	s = WinWidth / 4
	; ResizeWindow(#Window, #PB_Ignore, #PB_Ignore, s * 4, s * 4 + #HeightBtnRefresh)
	indentY = 0
	reDraw()
	WinWidth = s * 4 - #HeightBtnRefresh
	ResizeGadget(#cnv, #PB_Ignore, #PB_Ignore, 4*s, 4*s)
	ResizeGadget(#Score, #PB_Ignore, s * 4, s * 2, #PB_Ignore)
	ResizeGadget(#Style, s * 2, s * 4, s, #PB_Ignore)
	ResizeGadget(#btnMenu, s * 3, s * 4, s, #PB_Ignore)
	CompilerIf  #PB_Compiler_OS = #PB_OS_Windows
		ResizeWindow(#Window, #PB_Ignore, #PB_Ignore, s * 4, s * 4 + #HeightBtnRefresh)
		RemoveWindowTimer(#Window, #Timer)
		AddWindowTimer(#Window, #Timer, 400)
	CompilerElse
		RemoveWindowTimer(#Window, #Timer)
		AddWindowTimer(#Window, #Timer, 400)
	CompilerEndIf
EndProcedure









; Рекорды
Procedure GUI3()
	Protected Height
	CompilerIf #PB_Compiler_OS = #PB_OS_Windows
		Protected i, hControl
	CompilerEndIf
	Height = 25 * RecordsMax
	Height = RangeCheck(Height, 150, DspHeight - 80) ; минус заголовок окна и панель задач
	If OpenWindow(#WinScore, 0, 0, 400, Height, Lng(7), #PB_Window_SystemMenu | #PB_Window_ScreenCentered, WindowID(#Window))
		DisableWindow(#Window, #True)
		SetGadgetFont(#PB_Default, #PB_Default)
		AddKeyboardShortcut(#WinScore, #PB_Shortcut_Escape, #mExitScore)

;№ + "Name" + "Score" + "Size / Color" + "Date / Time"
		ListIconGadget(#LV , 0, 0, 400, Height, "", 20, #PB_ListIcon_FullRowSelect | #PB_ListIcon_GridLines)
		AddGadgetColumn(#LV, 1, Lng(10), 140)
		AddGadgetColumn(#LV, 2, Lng(12), 60)
		AddGadgetColumn(#LV, 4, Lng(11), 160)
		CompilerIf #PB_Compiler_OS = #PB_OS_Windows
			hControl = GadgetID(#LV)
			ListViewSpalte\fmt = #LVCFMT_RIGHT ; Указываем в поле fmt структуры константу для выравнивания
			SendMessage_(hControl, #LVM_SETCOLUMN, 0, @ListViewSpalte)
			SendMessage_(hControl, #LVM_SETCOLUMN, 2, @ListViewSpalte)
			ListViewSpalte\fmt = #LVCFMT_CENTER ; Указываем в поле fmt структуры константу для выравнивания
			SendMessage_(hControl, #LVM_SETCOLUMN, 3, @ListViewSpalte)
		CompilerEndIf

		ReadRecords()

; 		В обоих ОС делаем предварительную оценку высоты списка и потом проверяем данные на валидность, перед ресайзом
		CompilerSelect #PB_Compiler_OS
			CompilerCase #PB_OS_Windows
				Height = SendMessage_(hControl, #LVM_APPROXIMATEVIEWRECT, CountGadgetItems(#LV), -1) >> 16
				; Height = SendMessage_(hControl, #LVM_APPROXIMATEVIEWRECT, RecordsMax, -1) >> 16
			CompilerCase #PB_OS_Linux
				Height = 25 * CountGadgetItems(#LV) + 40 ; + высота заголовка и пол-пункта следующего за последним
		CompilerEndSelect
		Height = RangeCheck(Height, 100, DspHeight - 80) ; минус заголовок окна и панель задач
; 		уменьшаем окно до числа пунктов, условно, так как 25 это не условно принятая величина
		ResizeWindow(#WinScore, #PB_Ignore, #PB_Ignore, #PB_Ignore, Height)
		ResizeGadget(#LV, #PB_Ignore, #PB_Ignore, #PB_Ignore, Height)

		CompilerIf #PB_Compiler_OS = #PB_OS_Windows
			For i = 0 To 4
				SendMessage_(hControl,#LVM_SETCOLUMNWIDTH,i,#LVSCW_AUTOSIZE)
				SendMessage_(hControl,#LVM_SETCOLUMNWIDTH,i,#LVSCW_AUTOSIZE_USEHEADER)
			Next
		CompilerEndIf
	EndIf
EndProcedure


; Разделители для списка рекордов, которые маловероятно всстретятся в имени пользователя, а в никах могут быть любые символы.
#DelimElem$ = #LF$
#DelimString$ = #CR$

Structure Sort2D
  String.s
  Record.i
EndStructure

Procedure.s SortRes(Out$)
	Protected i
	Protected NewList StringList.s()
	Protected NewList ResList.Sort2D()
	SplitL(Out$, StringList(), #DelimString$)
	ForEach StringList()
		If AddElement(ResList())
			ResList()\Record = Val(StringField(StringList(), 2, #DelimElem$))
			ResList()\String = StringList()
		EndIf
	Next
	SortStructuredList(ResList(), #PB_Sort_Descending, OffsetOf(Sort2D\Record) , TypeOf(Sort2D\Record))
	If IsGadget(#LV)
		ForEach ResList()
			i + 1
			AddGadgetItem(#LV, -1, Str(i) + #DelimElem$ + ResList()\String)
		Next
	Else
		Out$ = ""
		ForEach ResList()
			Out$ + ResList()\String + #DelimString$
		Next
; 		Out$ = Left(Out$, Len(Out$) - 1)
		Out$ = RTrim(Out$, #DelimString$)
		ProcedureReturn Out$
	EndIf
EndProcedure

; Внесена способность не воспринимать переименованный файл рекордов, так как в пароль входят параметры игры,
; несмотря на то что в рекордах указаны характеристики игры. Параметры игры переставлены в начало пароля, так как
; в конце пароля они не воспринимаются, как будто у пароля есть ограничение длины пароля.


Procedure.s ReadRecords()
	Protected ID, Bytes, *Output, *Input, Length, Out$
	Protected FileName$ = "Records"
	Protected Password$ = #Password$
	If FileSize(PathConfig$ + FileName$) > 0
		ID = ReadFile(#PB_Any, PathConfig$ + FileName$)
		If ID
			Length = Lof(ID)
			*Input = AllocateMemory(Length)
			*Output = AllocateMemory(Length)
			If *Input And *Output
				Bytes = ReadData(ID, *Input, Length)
				If AESDecoder(*Input , *Output , Bytes , @Password$, 128 , 0, #PB_Cipher_ECB)
					Out$ = PeekS(*Output, Bytes)
; 					If Not (FindString(Out$, #DelimElem$) And FindString(Out$, "x") And FindString(Out$, "."))
; 						Out$ = ""
; 					EndIf
					Out$ = SortRes(Out$)
				EndIf
				FreeMemory(*Input)
				FreeMemory(*Output)
			EndIf
			CloseFile(ID)
		EndIf
	EndIf
	ProcedureReturn Out$
EndProcedure


Procedure AddRecords(Score)
	Protected ID, *Output, Input$, *Input, tmp, Length
	Protected NewList StringList.s()
	Protected txtRecords$, *CurElem, MinValie = 2147483647, *MinElem
	Protected FileName$ = "Records"
; 	Protected Password$ = Title$ +  FileName$
	Protected Password$ = #Password$


; 	запрос имени только если рекорд входит в таблицу рекордов
	If Not Asc(UserName$)
		Input$ = InputRequester(Lng(9), Lng(8), UserName())
		If Asc(Input$)
			UserName$ = Input$
; 			If MessageRequester("Сохранить имя?", "Сохранить имя, чтобы больше никогда не справшивать?", #PB_MessageRequester_YesNo) = #PB_MessageRequester_Yes
; 				Debug "да"
; 			EndIf
		Else
			ProcedureReturn ; не добавляем рекорды если имя не указано.
		EndIf
	EndIf

; 	Устранение разделителя в имени (Linux может позволить)
	UserName$ = ReplaceString(UserName$, #DelimString$, "")
	UserName$ = ReplaceString(UserName$, #DelimElem$, "")


	txtRecords$ = ReadRecords()
; 	Debug txtRecords$
	If Asc(txtRecords$) ; если рекорды существуют, то надо проверить достиг ли результат таблицы рекордов
		txtRecords$ + #DelimString$ + UserName$ + #DelimElem$ + Str(Score) + #DelimElem$ + FormatDate("%yyyy.%mm.%dd %hh:%ii:%ss", Date())
		SplitL(txtRecords$, StringList(), #DelimString$)
		; если число рекордов меньше максимального то просто добавляем рекорд в конец списка, иначе нужно удалить минимальный
		If ListSize(StringList()) > RecordsMax
			ResetList(StringList())
			Repeat
				*CurElem = NextElement(StringList())
				If Not *CurElem
					Break
				EndIf
				tmp = Val(StringField(StringList(), 2, #DelimElem$))
				If tmp <= MinValie
					MinValie = tmp
					*MinElem = *CurElem
				EndIf
			; Until Not *CurElem
			ForEver
			ChangeCurrentElement(StringList() , *MinElem)
			DeleteElement(StringList())

			txtRecords$ = ""
			ForEach StringList()
				txtRecords$ + StringList() + #DelimString$
; 				If AddElement(NumList())
; 					NumList() = StringField(StringList(), 2, #DelimElem$)
; 				EndIf
			Next
; 			txtRecords$ = Left(txtRecords$, Len(txtRecords$) - 1)
			txtRecords$ = RTrim(txtRecords$, #DelimString$)
		EndIf
	Else
		txtRecords$ = UserName$ + #DelimElem$ + Str(Score) + #DelimElem$ + FormatDate("%yyyy.%mm.%dd %hh:%ii:%ss", Date())
	EndIf
; 	Debug "перед шифрованием и сохранением: " + txtRecords$
	Length = StringByteLength(txtRecords$) + 2
; 	*Input = AllocateMemory(Length)
	*Output = AllocateMemory(Length)
	If *Output
		AESEncoder(@txtRecords$ , *Output , Length, @Password$ , 128 , 0, #PB_Cipher_ECB)
		ID = CreateFile(#PB_Any, PathConfig$ + FileName$)
		If ID
			WriteData(ID , *Output , Length)
			CloseFile(ID)
		EndIf
		FreeMemory(*Output)
	EndIf
EndProcedure


; Procedure DrawTextScore()
; 	Protected w, h, tmp, s2 = s * DPI
; 	If StartDrawing(CanvasOutput(#cnv))
; 		DrawingMode(#PB_2DDrawing_Transparent)
; 		DrawingFont(FontID(#Font))
; 		Box(0, 0, s2 * 4, s2 * 4, Clr(1, c))
; 		w = TextWidth(Lng(12) + ": " + Str(Score))
; 		tmp = 4 * s - w
; 		If tmp > -1
; 			DrawText(tmp / 2, 10, Lng(12) + ": " + Str(Score), $FFFFFF)
; 		EndIf
; 		h = TextHeight(Lng(12))
; 		w = TextWidth(Lng(5))
; 		tmp = 4 * s - w
; 		If tmp > -1
; 			DrawText(tmp / 2, h + 10, Lng(5), $FFFFFF)
; 		EndIf
; 		StopDrawing()
; 	EndIf
; EndProcedure

Code: Select all


Procedure RangeCheck(value, min, max)
	If value < min
		value = min
	ElseIf value > max
		value = max
	EndIf
    ProcedureReturn value
EndProcedure


; https://www.purebasic.fr/english/viewtopic.php?f=12&t=65159&p=486382&hilit=SplitL#p486382
Procedure SplitL(String.s, List StringList.s(), Separator.s = " ")
	Protected S.String, *S.Integer = @S
	Protected.i p, slen
	slen = Len(Separator)
	ClearList(StringList())
	*S\i = @String
	Repeat
		AddElement(StringList())
		p = FindString(S\s, Separator)
		StringList() = PeekS(*S\i, p - 1)
		*S\i + (p + slen - 1) << #PB_Compiler_Unicode
	Until p = 0
	*S\i = 0
EndProcedure


;==================================================================
;
; Author:    ts-soft     
; Date:       March 5th, 2010
; Explain:
;     modified version from IBSoftware (CodeArchiv)
;     on vista and above check the Request for "User mode" or "Administrator mode" in compileroptions
;    (no virtualisation!)
;==================================================================
Procedure ForceDirectories(Dir.s)
	Static tmpDir.s, Init
	Protected result
	
	If Len(Dir) = 0
		ProcedureReturn #False
	Else
		If Not Init
			tmpDir = Dir
			Init   = #True
		EndIf
		If (Right(Dir, 1) = #PS$)
			Dir = Left(Dir, Len(Dir) - 1)
		EndIf
		If (Len(Dir) < 3) Or FileSize(Dir) = -2 Or GetPathPart(Dir) = Dir
			If FileSize(tmpDir) = -2
				result = #True
			EndIf
			tmpDir = ""
			Init = #False
			ProcedureReturn result
		EndIf
		ForceDirectories(GetPathPart(Dir))
		ProcedureReturn CreateDirectory(Dir)
	EndIf
EndProcedure

Procedure IsHex(*c.Character)
	Protected flag = 1
	
	If *c\c = 0
		ProcedureReturn 0
	EndIf
	
	Repeat
		If Not ((*c\c >= '0' And *c\c <= '9') Or (*c\c >= 'a' And *c\c <= 'f') Or (*c\c >= 'A' And *c\c <= 'F'))
			flag = 0
			Break
		EndIf
		*c + SizeOf(Character)	
	Until Not *c\c
	
; 	Debug flag
	ProcedureReturn flag
EndProcedure

Procedure RGBtoBGR(c)
; 	ProcedureReturn RGB(Blue(c), Green(c), Red(c))
	ProcedureReturn ((c & $00FF00) | ((c & $0000FF) << 16) | ((c & $FF0000) >> 16))
EndProcedure

; def если пустая строка или больше 6 или 5 или 4
; def в BGR, не RGB, то есть готовое для применения
; Color$ это RGB прочитанный из ini с последующим преобразованием в BGR
Procedure ColorValidate(Color$, def = 0)
	Protected tmp$, tmp2$, i
; 	Debug Color$
	i = Len(Color$)
	If i <= 6 And IsHex(@Color$)
		Select i
			Case 6
; 				def = Val("$" + Color$)
; 				RGBtoBGR2(@def)
				def = RGBtoBGR(Val("$" + Color$))
			Case 1
				def = Val("$" + LSet(Color$, 6, Color$))
			Case 2
				def = Val("$" + Color$ + Color$ + Color$)
			Case 3
; 				сразу переворачиваем в BGR
				For i = 3 To 1 Step -1
					tmp$ = Mid(Color$, i, 1)
					tmp2$ + tmp$ + tmp$
				Next
				def = Val("$" + tmp2$)
		EndSelect
	EndIf
; 	Debug Hex(def)
	ProcedureReturn def
EndProcedure

Re: 2048 (AZJIO)

Posted: Wed Jun 11, 2025 9:42 pm
by minimy
Nice game! my record is 76 :mrgreen:
Thanks for share AZJIO!

Re: 2048 (AZJIO)

Posted: Wed Jun 11, 2025 11:53 pm
by AZJIO
Archive with files (Windows, Linux)
There's also a rule that needs to be improved and other little things. The sequence "8, 4, 2, 2" and the left arrow key gives 16, that is, it makes 3 moves. Also "2,2,2" and the left arrow key gives 2, 4, expected 4, 2.

I did a preview to select the button color.

Code: Select all

#cnv = 0

Global s = 80
#Window = 0
#Font = 0
#Font1 = 1
LoadFont(#Font, "Arial", s / 2.5)
LoadFont(#Font1, "Arial", s / 4.5)

Procedure New()
	Protected x1, y1, indentX, index, s2 = s
	If StartDrawing(CanvasOutput(#cnv))
		Box(0, 0, s2 * 4, s2 * 4, $696969)
		DrawingMode(#PB_2DDrawing_Transparent)
		DrawingFont(FontID(#Font))
		indentY = (s2 - TextHeight("1")) / 2
		; Генерируем кнопки
		i = 1
		For x = 0 To 3
			For y = 0 To 3
				n = Pow(2, i)
				i + 1
				Debug n
				; Box(x * s2, y * s2, s2, s2, Clr(4, c))
				Select n
					Case 0 : tmp = $3C3C3C
					Case 2 : tmp = $453B9B
					Case 4 : tmp = $4B0195
					Case 8 : tmp = $B400B4
					Case 16 : tmp = $AD006A
					Case 32 : tmp = $878F00
					Case 64 : tmp = $BFA800
					Case 128 : tmp = $FF9F00
					Case 256 : tmp = $D26068
					Case 512 : tmp = $00A3A0
					Case 1024 : tmp = $4ECA8E
					Case 2048 : tmp = $22A24F
					Case 4096 : tmp = $72ADC0
					Case 8192 : tmp = $3EAFFC
					Case 16384 : tmp = $C0AD72
					Case 32768 : tmp = $DBA6AA
				EndSelect
				Box(x * s2 + 1, y * s2 + 1, s2 - 2, s2 - 2, $282828)
				Box(x * s2 + 2, y * s2 + 2, s2 - 4, s2 - 4, tmp)
				If n > 600
					DrawingFont(FontID(#Font1))
					indentY = (s2 - TextHeight("1")) / 2
					indentX = (s2 - TextWidth(Str(n))) / 2
					DrawText(x * s2 + indentX, y * s2 + indentY, Str(n), $FFFFFF, tmp)
				Else
					indentX = (s2 - TextWidth(Str(n))) / 2
					DrawText(x * s2 + indentX, y * s2 + indentY, Str(n), $FFFFFF, tmp)
				EndIf
			Next
		Next
		StopDrawing()
	EndIf
EndProcedure

;-┌──GUI──┐
If OpenWindow(#Window, 0, 0, 4*s, 4*s, "", #PB_Window_SystemMenu | #PB_Window_MinimizeGadget | #PB_Window_ScreenCentered | #PB_Window_SizeGadget)
	CanvasGadget(#cnv, 0, 0, 4*s, 4*s)
	New()
;-└──GUI──┘
	Repeat
	Until WaitWindowEvent() = #PB_Event_CloseWindow
EndIf

Re: 2048 (AZJIO)

Posted: Thu Jun 12, 2025 6:17 am
by dige
Nice! 👍🏼

Re: 2048 (AZJIO)

Posted: Thu Jun 12, 2025 8:53 am
by Mindphazer
Doesn't compile on MacOS because with your CompilerSelect, the Event_Timer() procedure is not created...

Re: 2048 (AZJIO)

Posted: Thu Jun 12, 2025 9:16 pm
by AZJIO
Added Ctrl+Z to cancel.
Now the results of the addition are not added together again.
The first summation is from the side in which the direction is.

I read the rules of the game and made changes to the code. I was trying to ensure that canceling a move did not generate a new tile position, thus making it impossible to choose an advantageous situation for myself.

Re: 2048 (AZJIO)

Posted: Thu Jun 12, 2025 10:30 pm
by idle
works well win11, I'm quite liking the variety

Re: 2048 (AZJIO)

Posted: Fri Jun 27, 2025 9:31 am
by AZJIO
Update (Windows)
Added saving of game records (highscore)
Added an ini file that sets the color, square size, user name, and number of records.
Added an external Lang.txt file for translation into your native language.

Re: 2048 (AZJIO)

Posted: Fri Jun 27, 2025 11:42 am
by IceSoft
AZJIO wrote: Wed Jun 11, 2025 8:35 pm A2048
Download yandex
Could not downloaded. Virus dedected!

Re: 2048 (AZJIO)

Posted: Fri Jun 27, 2025 1:27 pm
by Mindphazer
If you compile the source provided in the first post, one file is missing (ForA2048.pb)

Re: 2048 (AZJIO)

Posted: Fri Jun 27, 2025 2:22 pm
by AZJIO
Mindphazer wrote: Fri Jun 27, 2025 1:27 pm If you compile the source provided in the first post, one file is missing (ForA2048.pb)
Added
IceSoft wrote: Fri Jun 27, 2025 11:42 am Could not downloaded. Virus dedected!
Can you disable your antivirus? You can compile the game yourself.

————————
Added the source code for Android (screenshot).
packages for Linux - Done.

Re: 2048 (AZJIO)

Posted: Mon Jun 30, 2025 8:28 pm
by threedslider
Another game for 2048 ! Good job on that :mrgreen:
All times are UTC+01:00
Page 1 of 1

Powered by phpBB® Forum Software © phpBB Limited