The 15 puzzle (3D) (made by Tiranas)
Sun Jan 08, 2023 7:11 am
Hi guys, did you ever played the "15 puzzle" game?
The 15 puzzle (also called Gem Puzzle, Boss Puzzle, Game of Fifteen, Mystic Square and many others) is a sliding puzzle having 15 square tiles numbered 1–15 in a frame that is 4 tiles high and 4 tiles wide, leaving one unoccupied tile position. Tiles in the same row or column of the open position can be moved by sliding them horizontally or vertically, respectively. The goal of the puzzle is to place the tiles in numerical order. (Wikipedia)
By the way, I know Tiranas as a really good programmer!
Download: 15 puzzle (10 mb, zip, google drive)
The 15 puzzle (also called Gem Puzzle, Boss Puzzle, Game of Fifteen, Mystic Square and many others) is a sliding puzzle having 15 square tiles numbered 1–15 in a frame that is 4 tiles high and 4 tiles wide, leaving one unoccupied tile position. Tiles in the same row or column of the open position can be moved by sliding them horizontally or vertically, respectively. The goal of the puzzle is to place the tiles in numerical order. (Wikipedia)
By the way, I know Tiranas as a really good programmer!
Download: 15 puzzle (10 mb, zip, google drive)
Alex likes this post
Source code !!!
Sun Jan 08, 2023 11:39 am
- Code:
'----------------------------------------------------
' "The 15 puzzle"
'' Made by Tiranas (Dec 17, 2020)
'----------------------------------------------------
#Include "./WorldSim3D.bi"
#include "./SampleFunctions.bi"
randomize timer
dim shared as float32 fTmp = 0f
dim shared as string sTmp1
Dim as wFont MyFont = 0
Dim as Int32 prevFPS = 0
dim as wColor4s sceneColor = (255,0,0,0)
dim shared as wVector2i fromPos = (0, 0)
dim shared as wVector2i toPos = (0, 0)
dim as String wndCaption = "3D Fifteen puzzle (made by Tiranas) with WorldSim3D game engine "
dim as String metrics = ""
Dim shared as wVector3f vec3, vec4
dim shared as float32 cubsize
cubsize = 25
Dim shared as wGuiObject msg_err = 0
dim shared as wTexture sText0 = 0
dim shared as wAnimator cubemove_anim = 0
dim shared as wNode sNodeBSG = 0
dim shared as wNode cube(0 to 64)
Dim shared as int32 nMax, nSavI, eg, nm, nMove
Dim shared As Byte m()
Dim shared As int32 iSelectedNode
dim shared as byte m2(1 To 6, 1 To 6, 0 To 1)
dim shared as int32 nDoHod
dim shared as int32 gf_retry
dim shared as byte gf_iq, gf_min, gf_recur, gbErr
Dim shared As Boolean bAuto = false
Dim shared As Boolean nAutoMove = false
' For Rit1() function
dim shared as int32 iNul, jNul
dim shared as int32 gHTX, gHTY
dim shared as int32 gHX1, gHY1
declare sub CreateBackground()
declare sub control_key()
declare sub ScreenShot_only()
declare Sub CreatePole()
declare Function GetSumm() As Boolean
declare Function Rnd1() As Byte
declare Sub NewPole()
declare sub MoveCubeToPos(iSelNode as int32)
declare Function GetVictory() As Boolean
declare sub Set_m2()
declare Function rMove1(m3() As Byte, k As Byte, i0 As Int32, j0 As Int32) As int32
declare Sub AI_Move()
declare sub AI_MoveAll()
declare Function GetRetryIQ(v As int32) As Byte
declare Function Rit1(m3() As Byte, nMove As Byte, i0 As Int32, j0 As Int32) As Int32
dim as wVector2u screen_size = (1360, 768)
'Dim as Boolean init=wEngineStart(wDRT_OPENGL, wDEFAULT_SCREENSIZE, 32, false, FALSE, TRUE, FALSE)
Dim as Boolean init=wEngineStart(wDRT_OPENGL, screen_size, 32, false, FALSE, TRUE, FALSE)
if Not init then
PrintWithColor("wEngineStart() failed!"): end
endif
' Dim shared As wVector2u scrSize
' wWindowGetSize(@scrSize)
dim shared as wGuiObject button1
dim as wVector2i minPos, maxPos
minPos.x = 600: minPos.y = 690
maxPos.x = 750: maxPos.y = 720
button1 = wGuiButtonCreate (minPos, maxPos, "AI solution", "I give up. You yourself solve!")
wGuiObjectSetId (button1, 101)
Dim as string fontPath="./Assets/Fonts/Consolas_12.xml"
CheckFilePath(fontPath)
MyFont=wFontLoad(fontPath)
wEngineShowLogo(false)
Dim as wGuiObject guiSkin = wGuiGetSkin()
wGuiSkinSetFont(guiSkin, MyFont)
wGuiSkinSetColor(guiSkin, wGDC_3D_FACE, wCOLOR4s_SKYBLUE)
Dim as wColor4s btnColor = (255,25,100,0)
wGuiSkinSetColor(guiSkin, wGDC_BUTTON_TEXT, btnColor)
For i as Int32 = 0 To wGDC_COUNT - 1
Dim as wColor4s clr = wGuiSkinGetColor(guiSkin,i)
clr.alpha=255
wGuiSkinSetColor(guiSkin, i, clr)
Next i
dim shared as wNode camera2
Dim shared as wVector3f pos2, tar1, tar2, vec1, vec2, normal_vec, n_vec
pos2.x = 200: pos2.y = 0: pos2.z = 0
tar2.x = 0: tar2.x = 0: tar2.x = 0
camera2 = wCameraCreate (pos2, tar2)
wCameraSetClipDistance (Camera2, 12000, 1)
wCameraSetFov (Camera2, 0.8) ' wMathPI/2.5
CreateBackground()
NewPole()
CreatePole()
Dim As double fTime = timer + 0.01667
while(wEngineRunning())
if (timer >= fTime) Then
fTime = timer + 0.01667
wSceneBegin(sceneColor)
wSceneDrawAll()
/'
fromPos.x = 10: fromPos.y = 10
metrics = "Polygons: " & Str(wSceneGetPrimitivesDrawn())
wFontDraw(MyFont,metrics,fromPos,toPos,wCOLOR4s_YELLOW)
metrics = "Nodes: " & Str(wSceneGetNodesCount())
fromPos.x = 10: fromPos.y += 20
wFontDraw(MyFont,metrics,fromPos,toPos,wCOLOR4s_DARKORANGE)
metrics = "Meshes: " & Str(wSceneGetMeshesCount())
fromPos.x = 10: fromPos.y += 20
wFontDraw(MyFont,metrics,fromPos,toPos,wCOLOR4s_LIME)
'/
metrics = "Moves: " & Str(nMove)
fromPos.x = 10: fromPos.y = 10
wFontDraw(MyFont,metrics,fromPos,toPos,wCOLOR4s_MAGENTA)
'fromPos.x = 10: fromPos.y += 20
'wFontDraw(MyFont,sTmp1,fromPos,toPos,wCOLOR4s_WHITE)
wGuiDrawAll()
wSceneEnd()
wEngineCloseByEsc()
if prevFPS <> wEngineGetFPS() then
prevFPS = wEngineGetFPS()
wWindowSetCaption(wndCaption+str(prevFPS))
endif
control_key()
endif
wend
wEngineStop()
end
sub control_key()
Dim as wKeyEvent Ptr KeyEvent
Dim as wMouseEvent Ptr MouseEvent
Dim as wNode SelectedNode
Dim as wGuiEvent Ptr guiEvent = 0
if cubemove_anim <> 0 then
if wAnimatorIsFinished(cubemove_anim) then
wAnimatorSetEnable(cubemove_anim, false, 0)
cubemove_anim = 0
if GetVictory() then
wGuiObjectSetEnable (button1, true)
nAutoMove = false
endif
else
exit sub
endif
endif
if nAutoMove then
AI_MoveAll()
exit sub
endif
if msg_err <> 0 then
if(wGuiIsEventAvailable()) Then
guiEvent = wGuiReadEvent()
if(guiEvent->event=wGCT_MESSAGEBOX_OK) Then
msg_err = 0
NewPole()
CreatePole()
exit sub
endif
endif
exit sub
endif
if wGuiIsEventAvailable() Then
guiEvent = wGuiReadEvent()
if guiEvent -> event = wGCT_BUTTON_CLICKED Then
If guiEvent -> id = 101 Then
wGuiObjectSetEnable (button1, false)
nAutoMove = true
exit sub
endif
endif
endif
Do While (wInputIsKeyEventAvailable())
KeyEvent = wInputReadKeyEvent()
If (Not KeyEvent->isControl) And (Not KeyEvent->isShift) Then
dim as int32 ind1
Select case as const KeyEvent->key
Case wKC_PLUS ' increase
Case wKC_MINUS ' decrease
Case wKC_F1
'if KeyEvent->direction = wKD_UP Then VisHelp = Not VisHelp
Case wKC_F2
Case wKC_F3
Case wKC_F11
'
Case wKC_F12
if KeyEvent->direction = wKD_UP Then ScreenShot_only()
Case wKC_KEY_W, wKC_UP, wKC_NUMPAD8
If KeyEvent->direction = wKD_UP and ((nm + eg) <= nMax) Then
ind1 = m(nm + eg) ' 38 Up
MoveCubeToPos(ind1)
endif
Case wKC_KEY_D, wKC_RIGHT, wKC_NUMPAD6
If KeyEvent->direction = wKD_UP and ((nm - 1) >= 0) Then
ind1 = m(nm - 1) ' 39 Right
MoveCubeToPos(ind1)
endif
Case wKC_KEY_S, wKC_DOWN, wKC_NUMPAD2
If KeyEvent->direction = wKD_UP and ((nm - eg) >= 0) Then
ind1 = m(nm - eg) ' 40 Down
MoveCubeToPos(ind1)
endif
Case wKC_KEY_A, wKC_LEFT, wKC_NUMPAD4
If KeyEvent->direction = wKD_UP and ((nm + 1) <= nMax) Then
ind1 = m(nm + 1) ' 37 Left
MoveCubeToPos(ind1)
endif
Case wKC_ESCAPE
End Select
Else
Exit Do
EndIf
loop
while wInputIsMouseEventAvailable()
MouseEvent = wInputReadMouseEvent()
if MouseEvent->action=wMET_MOUSE_MOVED then
SelectedNode = wCollisionGetNodeFromScreen(MouseEvent->position)
for i as Int32 = 0 to nMax
if cube(i) <> 0 then wNodeSetDebugMode(cube(i), wDM_OFF)
next i
if SelectedNode <> 0 then
for i as Int32 = 0 to nMax
if SelectedNode = cube(i) then
if cube(i) <> 0 then
wNodeSetDebugMode(cube(i), wDM_BBOX)
iSelectedNode = i: exit for
endif
endif
next i
else
iSelectedNode = -1
endif
endif
if MouseEvent->action=wMET_LMOUSE_LEFT_UP then
MoveCubeToPos(iSelectedNode)
endif
wend
end sub
Sub ScreenShot_only()
Dim As String sFile
For i As int32 = 0 To 999
sFile = "./Screenshots/ScreenShot_" & Right("0000" & Str(i), 3) & ".jpg"
If Not wFileIsExist(sFile) Then
wSystemSaveScreenShot(sFile)
Exit For
EndIf
Next i
End Sub
sub MoveCubeToPos(iSelNode as int32)
' Move a cell
if iSelNode < 0 then exit sub
if cubemove_anim <> 0 then
if not wAnimatorIsFinished(cubemove_anim) then
exit sub
endif
endif
if nMove >= 2048 then
msg_err = wGuiMessageBoxCreate("I am sorry, man", "You have reached the maximum number of moves!", true, wGMBF_OK, 0)
exit sub
endif
Dim k As Int32, i As Int32, B As Byte, sav_nm as byte
If ((nm - 1) >= 0) And ((nm Mod eg) <> 0) Then If (m(nm - 1) = iSelNode) Then k = -1
If ((nm + 1) <= nMax) And (((nm + 1) Mod eg) <> 0) Then If (m(nm + 1) = iSelNode) Then k = 1
If (nm - eg) >= 0 Then If (m(nm - eg) = iSelNode) Then k = -eg
If (nm + eg) <= nMax Then If (m(nm + eg) = iSelNode) Then k = eg
If k = 0 Then Exit Sub
sav_nm = nm
B = m(nm): m(nm) = m(nm + k): m(nm + k) = B: nm = nm + k
vec2 = vec1
vec2.y = vec1.y + ((nMax - sav_nm) \ eg) * (cubsize + 0.3) - (eg shr 1) * cubsize + (cubsize shr 1)
vec2.z = vec1.z + (sav_nm mod eg) * (cubsize + 0.3) - (eg shr 1) * cubsize + (cubsize shr 1)
vec3 = wNodeGetAbsolutePosition(cube(iSelNode))
cubemove_anim = wAnimatorFlyingStraightCreate (cube(iSelNode), vec3, vec2, 300, false)
'wNodeSetPosition (cube(iSelNode), vec2)
nMove = nMove + 1
end sub
Function GetVictory() As Boolean
For i as int32 = 0 To (nMax - 1)
If m(i) <> (i + 1) Then return false
Next i
if nAutoMove then
msg_err = wGuiMessageBoxCreate("I win!", "I am awesome. AI is perfect!", true, wGMBF_OK, 0)
else
msg_err = wGuiMessageBoxCreate("You win!", "You are clever! You did well!", true, wGMBF_OK, 0)
endif
return true
End Function
Function Rnd1() As Byte
dim as byte Rnd2 = Fix(Rnd * (nMax + 1))
return Rnd2
End Function
Function GetSumm() As Boolean
' Solvability check and correction
Dim i As Byte, j As Byte, iSum As Int32, I1 As Byte, i2 As Byte
iSum = 0
For i = 0 To nMax
For j = i + 1 To nMax
If m(i) > m(j) Then iSum = iSum + 1
Next j
Next i
iSum = iSum + Sqr(nMax + 1)
If (iSum Mod 2) = 0 Then ' correction
For i = 0 To 30
I1 = Rnd1(): i2 = Rnd1()
If (I1 <> i2) And ((m(I1) > 0) And (m(i2) > 0)) Then j = m(I1): m(I1) = m(i2): m(i2) = j: Exit For
Next i
Else
return True
End If
End Function
Sub NewPole()
Dim I1 As Byte, i2 As Byte, j As Byte
iSelectedNode = -1
nMove = 0
nDoHod = 0
nSavI = 0
gf_min = 10
gf_iq = gf_min: gf_retry = 0: gf_recur = 0
nMax = (nSavI + 4) * (nSavI + 4) - 1
If nMax = 15 Then eg = 4
If nMax = 24 Then eg = 5
If nMax = 35 Then eg = 6
Erase m: ReDim m(36)
For i as int32 = 0 To nMax
If i < nMax Then m(i) = i + 1
Next i
For n as int32 = 1 To 64
I1 = Rnd1(): i2 = Rnd1()
If (I1 <> i2) And ((m(I1) > 0) And (m(i2) > 0)) Then j = m(I1): m(I1) = m(i2): m(i2) = j
Next n
GetSumm() ' Solvability check and correction
for i as int32 = 0 to nMax
If m(i) = 0 Then
nm = i
exit for
endif
next i
end sub
Sub CreatePole()
dim as string sFile
dim as wTexture sText
dim as wMaterial mat1
dim as int32 nnPlus = 0
if sText0 = 0 then
sFile = ".\Assets\texture\b1.jpg"
sText0 = wTextureLoad(sFile)
wEngineSetTransparentZWrite(true)
endif
for i as int32 = 1 to 15
if cube(i) = 0 then
nnPlus += 1
sFile = ".\Assets\texture\" + str(i) + ".jpg"
sText = wTextureLoad (sFile)
cube(i) = wNodeCreateCube(cubsize, false, wCOLOR4s_WHITE)
mat1 = wNodeGetMaterial(cube(i), 0)
wMaterialSetFlag (mat1, wMF_LIGHTING, FALSE)
wMaterialSetFlag (mat1, wMF_ANISOTROPIC_FILTER, TRUE)
wMaterialSetFlag (mat1, wMF_BILINEAR_FILTER, false)
wMaterialSetFlag (mat1, wMF_TRILINEAR_FILTER, TRUE)
wMaterialSetTexture (mat1, 0, sText)
endif
next i
for i as int32 = 0 to nMax
if m(i) > 0 then
vec2 = vec1
vec2.y = vec1.y + ((nMax - i) \ eg) * (cubsize + 0.3) - (eg shr 1) * cubsize + (cubsize shr 1)
vec2.z = vec1.z + (i mod eg) * (cubsize + 0.3) - (eg shr 1) * cubsize + (cubsize shr 1)
wNodeSetPosition (cube(m(i)), vec2)
if nnPlus > 0 then
wNodeRotateToNode (cube(m(i)), Camera2)
endif
endif
next i
End Sub
'---------------------------------
' AI !
'---------------------------------
Function Rit1(m3() As Byte, nMove As Byte, i0 As Int32, j0 As Int32) As Int32
' Evaluation function
Dim i As Int32, j As Int32, d As Int32, s1 As Int32
Dim i3 As Int32, j3 As Int32, k3 As Byte, rr as int32
k3 = 127
For d = 1 To eg
If (k3 = 127) Then
For i = 1 To eg
If (m3(i, d, 0) = m3(i, d, 1)) Then
rr = rr + nMax
Else
k3 = m3(i, d, 1): i3 = i: j3 = d: Exit For
End If
Next i
If (k3 = 127) Then rr = rr + 10000 Else Exit For
End If
If (k3 = 127) Then
For j = 1 To eg
If (m3(d, j, 0) = m3(d, j, 1)) Then
rr = rr + nMax
Else
k3 = m3(d, j, 1): i3 = d: j3 = j: Exit For
End If
Next j
If (k3 = 127) Then rr = rr + 10000 Else Exit For
End If
Next d
If (k3 < 127) And (k3 > 0) Then
For j = 1 To eg
For i = 1 To eg
If (k3 = m3(i, j, 0)) Then
s1 = nMax - Abs(i - i3) - Abs(j - j3) - Abs(i - i0) - Abs(j - j0)
Exit For
End If
Next i
If (s1 > 0) Then Exit For
Next j
End If
rr = rr - nMove + s1
return rr
End Function
sub Set_m2()
' Fill in the m2 matrix and determine the coordinates of the zero cell
Dim I1 As Byte, j1 As Byte, X As Int32
I1 = 1: j1 = 1
Erase m2
For X = 0 To nMax
m2(I1, j1, 0) = m(X) ' current filling of the matrix
If X < nMax Then m2(I1, j1, 1) = X + 1 ' correct filling of the matrix
If m(X) = 0 Then iNul = I1: jNul = j1
I1 = I1 + 1: If I1 > eg Then j1 = j1 + 1: I1 = 1
Next X
End sub
Function rMove1(m3() As Byte, k As Byte, i0 As Int32, j0 As Int32) As int32
' sorting through the options of moves
If k > gf_iq Then return 0
Dim R(3) As Int32, i As Int32, h As Int32
If (i0 < eg) Then
m3(i0, j0, 0) = m3(i0 + 1, j0, 0): m3(i0 + 1, j0, 0) = 0
'Call VisM3(m3())
R(0) = Rit1(m3(), k, i0 + 1, j0) + rMove1(m3(), k + 1, i0 + 1, j0)
m3(i0 + 1, j0, 0) = m3(i0, j0, 0): m3(i0, j0, 0) = 0
End If
If (i0 > 1) Then
m3(i0, j0, 0) = m3(i0 - 1, j0, 0): m3(i0 - 1, j0, 0) = 0
R(1) = Rit1(m3(), k, i0 - 1, j0) + rMove1(m3(), k + 1, i0 - 1, j0)
m3(i0 - 1, j0, 0) = m3(i0, j0, 0): m3(i0, j0, 0) = 0
End If
If (j0 < eg) Then
m3(i0, j0, 0) = m3(i0, j0 + 1, 0): m3(i0, j0 + 1, 0) = 0
R(2) = Rit1(m3(), k, i0, j0 + 1) + rMove1(m3(), k + 1, i0, j0 + 1)
m3(i0, j0 + 1, 0) = m3(i0, j0, 0): m3(i0, j0, 0) = 0
End If
If (j0 > 1) Then
m3(i0, j0, 0) = m3(i0, j0 - 1, 0): m3(i0, j0 - 1, 0) = 0
R(3) = Rit1(m3(), k, i0, j0 - 1) + rMove1(m3(), k + 1, i0, j0 - 1)
m3(i0, j0 - 1, 0) = m3(i0, j0, 0): m3(i0, j0, 0) = 0
End If
dim as int32 rH1
rH1 = R(0): i = 1 ' 37 Left (1)
If (R(1) >= rH1) Then rH1 = R(1): i = 2 ' 39 Right (2)
If (R(2) > rH1) Then rH1 = R(2): i = 3 ' 38 Up (3)
If (R(3) >= rH1) Then rH1 = R(3): i = 4 ' 40 Down (4)
If (k = 1) Then
return i
Else
return rH1
'rMove1 = r(0) + r(1) + r(2) + r(3)
End If
End Function
Function GetRetryIQ(v As int32) As Byte
If (v = 1) And (gf_retry = 2) Then return 0
If (v = 2) And (gf_retry = 1) Then return 0
If (v = 3) And (gf_retry = 4) Then return 0
If (v = 4) And (gf_retry = 3) Then return 0
return 1
End Function
sub AI_MoveAll()
if cubemove_anim <> 0 then
if wAnimatorIsFinished(cubemove_anim) then
wAnimatorSetEnable(cubemove_anim, false, 0)
cubemove_anim = 0
endif
return
endif
if nAutoMove or not bAuto then AI_Move()
end sub
Sub AI_Move()
' AI move
If bAuto Then Exit Sub
bAuto = True
Dim As int32 v, xn, yn
' "I'm thinking"
' Fill in the m2 matrix and determine the coordinates of the zero cell
Set_m2()
'Call Get_ex_ey ' Determine the minimum upper bound of processing
If nDoHod = 0 Then
v = rMove1(m2(), 1, iNul, jNul)
End If
If GetRetryIQ(v) = 0 Or nDoHod > 0 Then
nDoHod = nDoHod + 1
If nDoHod >= 2 Then nDoHod = 0
' There is a repeat of the move
Set_m2()
If jNul = (eg - 1) Then
If iNul = (eg - 2) Then
v = 3
Else
If iNul > (eg - 2) Then
v = 2
Else
v = 3
End If
End If
Else
If jNul = eg Then
If iNul = eg Then
v = 4
Else
If iNul < eg Then
v = 1
Else
v = 1
End If
End If
Else
v = 2
End If
End If
End If
dim as int32 ind1
gf_retry = v
Select Case v
Case 1
If ((nm + 1) <= nMax) Then
ind1 = m(nm + 1) ' 37 Left
MoveCubeToPos(ind1)
endif
Case 2
If ((nm - 1) >= 0) Then
ind1 = m(nm - 1) ' 39 Right
MoveCubeToPos(ind1)
endif
Case 3
If ((nm + eg) <= nMax) Then
ind1 = m(nm + eg) ' 38 Up
MoveCubeToPos(ind1)
endif
Case 4
If ((nm - eg) >= 0) Then
ind1 = m(nm - eg) ' 40 Down
MoveCubeToPos(ind1)
endif
End Select
bAuto = False
End Sub
sub CreateBackground()
dim as string sFile = ".\Assets\texture\Background1.jpg"
dim as wTexture sText = wTextureLoad(sFile)
dim as wVector2f tileSize = (400, 200)
sNodeBSG = wNodeCreatePlane(tileSize, wVECTOR2u_ONE, 0, wVECTOR2f_ONE, false)
dim as wMaterial mat1 = wNodeGetMaterial(sNodeBSG, 0)
wMaterialSetFlag (mat1, wMF_LIGHTING, FALSE)
wMaterialSetFlag (mat1, wMF_ANISOTROPIC_FILTER, TRUE)
wMaterialSetFlag (mat1, wMF_BILINEAR_FILTER, false)
wMaterialSetFlag (mat1, wMF_TRILINEAR_FILTER, TRUE)
wMaterialSetTexture (mat1, 0, sText)
dim as wVector3f vBCG, vTar
vBCG = vec1
vBCG.x = -cubsize
wNodeSetPosition (sNodeBSG, vBCG)
wNodeRotateToNode (sNodeBSG, Camera2)
vTar.z = 270
vTar.y = -90
wNodeSetAbsoluteRotation (sNodeBSG, vTar)
wNodeUpdateAbsolutePosition (sNodeBSG)
wNodeDraw (sNodeBSG)
end sub
Permissions in this forum:
You cannot reply to topics in this forum