Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
sokoban.bas
| Uploader: |  ThePuppetMaster |
| Datum/Zeit: | 13.12.2011 20:42:45 |
'################################
' 2011 By.: ThePuppetMaster
'################################
' inspiriert von www.rockbox.org
'################################
' Do What The Fuck u Want!
'################################
Const C_Wall = 35 '# = WAND
Const C_Target = 42 '* 'Zielfeld
Const C_Stone = 43 '+ 'Stein
Const C_StoneTarget = 79 'O 'Stein auf zielfeld
Const C_Man = 83 'S 'Mann
Dim Shared G_Width as UInteger = 400
Dim Shared G_Height as UInteger = 400
Dim Shared G_FieldW as UInteger = 20
Dim Shared G_FieldH as UInteger = 20
Dim Shared G_RasterW as UInteger: G_RasterW = G_Width \ G_FieldW
Dim Shared G_RasterH as UInteger: G_RasterH = G_Height \ G_FieldH
Dim Shared G_IMGWall as Any Ptr
Dim Shared G_IMGStoneK as Any Ptr
Dim Shared G_IMGStoneN as Any Ptr
Dim Shared G_IMGTarget as Any Ptr
Dim Shared G_IMGMan as Any Ptr
Dim Shared G_Field(G_FieldW, G_FieldH) as Byte
Dim Shared G_Stone(G_FieldW, G_FieldH) as Byte
Dim Shared G_ManX as Byte
Dim Shared G_ManY as Byte
Dim Shared G_Time as Double
Dim Shared G_Level as UInteger
Dim Shared G_NeedTime as Double
Dim Shared G_NeedSteps as UInteger
Dim Shared G_NeedStepTable as String
Dim Shared G_NeedStepTableUnDo as String
Dim Shared G_NeedStepTableC as UInteger
Dim Shared G_NeedStepTableX as UInteger
Function LoadLevel(V_LevelID as UInteger) as Integer
If Dir("level/lv" & Str(V_LevelID) & ".dat", -1) = "" Then Return -1
Dim XFN as Integer = FreeFile
Open "level/lv" & Str(V_LevelID) & ".dat" for Binary as #XFN
Dim T as String = Space(Lof(XFN))
Get #XFN, 1, T
Close #XFN
Dim D as String
For X as UInteger = 1 to Len(T)
Select Case T[X - 1]
Case 32, C_Wall, C_Target, C_Stone, C_StoneTarget, C_Man: D += Chr(T[X - 1])
End Select
Next
If Len(D) < (G_FieldW * G_FieldH) Then Return -2
Dim Z as UInteger
For Y as UInteger = 1 to G_FieldH
For X as UInteger = 1 to G_FieldW
G_Field(X, Y) = 0
G_Stone(X, Y) = 0
Select Case D[Z]
Case C_Wall, C_Target: G_Field(X, Y) = D[Z]
Case C_Stone: G_Stone(X, Y) = C_Stone
Case C_StoneTarget
G_Field(X, Y) = C_Target
G_Stone(X, Y) = C_Stone
Case C_Man: G_ManX = X: G_ManY = Y
End Select
Z += 1
Next
Next
Return 1
End Function
Function TimeFormat(V_Value as UInteger) as String
Dim XR as UInteger = V_Value
Dim XH as UInteger = XR \ 3600: XR = XR mod 3600
Dim XM as UInteger = XR \ 60: XR = XR mod 60
Dim T as String = *IIf(Len(Str(XH)) < 2, @" ", @"") & Str(XH) & ":" & *IIf(Len(Str(XM)) < 2, @"0", @"") & Str(XM) & ":" & *IIf(Len(Str(XR)) < 2, @"0", @"") & Str(XR)
Return T
End Function
Sub DoDraw()
ScreenLock()
Line(0, 0)-(G_Width - 1, G_Height + 13), &HC0C0C0, BF
For Y as UInteger = 0 to G_FieldH - 1
For X as UInteger = 0 to G_FieldW - 1
Select Case G_Field(X + 1, Y + 1)
Case C_Wall: Put (G_RasterW * X, G_RasterH * Y), G_IMGWall, PSet
Case C_Target: Put (G_RasterW * X, G_RasterH * Y), G_IMGTarget, PSet
End Select
If G_Stone(X + 1, Y + 1) <> 0 Then
If G_Field(X + 1, Y + 1) = C_Target Then
Put (G_RasterW * X, G_RasterH * Y), G_IMGStoneK, PSet
Else: Put (G_RasterW * X, G_RasterH * Y), G_IMGStoneN, PSet
End If
End if
Next
Next
Put (G_RasterW * (G_ManX - 1), G_RasterH * (G_ManY - 1)), G_IMGMan, PSet
Dim T as String
Dim V as Double = Timer() - G_Time
T += *IIf(Len(Str(V mod 3600)) < 2, @" ", @"") & Str(V mod 3600) & ":": V \= 3600
T += *IIf(Len(Str(V mod 60)) < 2, @"0", @"") & Str(V mod 60) & ":": V \= 60
T += *IIf(Len(V) < 2, @"0", @"") & Str(V)
Draw String (3, G_Height + 3), "Level:" & Str(G_Level) & " Steps:" & Str(G_NeedSteps) & " Time:" & TimeFormat(CUInt(Timer() - G_Time)), &H000000
ScreenUnLock()
End Sub
Function DoMove(V_Direction as UByte) as Integer
Dim TNPosX as UByte = G_ManX
Dim TNPosY as UByte = G_ManY
Dim TNPosX2 as UByte = G_ManX
Dim TNPosY2 as UByte = G_ManY
Select Case V_Direction
Case 1: TNPosX -= 1: TNPosX2 -= 2 'left
Case 2: TNPosX += 1: TNPosX2 += 2 'right
Case 3: TNPosY -= 1: TNPosY2 -= 2 'top
Case 4: TNPosY += 1: TNPosY2 += 2 'bot
End Select
If TNPosX <= 0 Then Return 1
If TNPosX > G_FieldW Then Return 1
If TNPosY <= 0 Then Return 1
If TNPosY > G_FieldH Then Return 1
If G_Field(TNPosX, TNPosY) = C_Wall Then Return 1
If G_Stone(TNPosX, TNPosY) = C_Stone Then
If G_Field(TNPosX2, TNPosY2) = C_Wall Then Return 1
If G_Stone(TNPosX2, TNPosY2) = C_Stone Then Return 1
G_Stone(TNPosX2, TNPosY2) = G_Stone(TNPosX, TNPosY)
G_Stone(TNPosX, TNPosY) = 0
End If
G_ManX = TNPosX
G_ManY = TNPosY
G_NeedSteps += 1
If G_NeedStepTableX <= G_NeedSteps - 1 Then
G_NeedStepTable += Space(100)
G_NeedStepTableX = Len(G_NeedStepTable)
End If
G_NeedStepTable[G_NeedSteps] = V_Direction
For Y as UInteger = 0 to G_FieldH - 1
For X as UInteger = 0 to G_FieldW - 1
If G_Field(X + 1, Y + 1) = C_Target Then If G_Stone(X + 1, Y + 1) <> C_Stone Then Return 1
Next
Next
Return 2
End Function
Sub Main()
ScreenRes G_Width, G_Height + 13, 32
G_IMGWall = ImageCreate(G_FieldW, G_FieldW, 32) : BLoad "wall.bmp", G_IMGWall
G_IMGStoneK = ImageCreate(G_FieldW, G_FieldW, 32) : BLoad "stonek.bmp", G_IMGStoneK
G_IMGStoneN = ImageCreate(G_FieldW, G_FieldW, 32) : BLoad "stonen.bmp", G_IMGStoneN
G_IMGTarget = ImageCreate(G_FieldW, G_FieldW, 32) : BLoad "target.bmp", G_IMGTarget
G_IMGMan = ImageCreate(G_FieldW, G_FieldW, 32) : BLoad "man.bmp", G_IMGMan
Print
Print " ###################################"
Print " ### ###"
Print " ### 2011 By.: ThePuppetMaster ###"
Print " ### ###"
Print " ###################################"
Print
Print
Print
Print " =[ USING ]="
Print " -------"
Print: Print
Print " Left / Right / Up / Down"
Print " move man"
Print: Print
Print " ESC / X-Button"
Print " Exit SoKoBan"
Print: Print
Print " Backspace = Abort level and begin again"
Print: Print: Print
Print " =[ Goal of game ]="
Print " --------------"
Print: Print
Print " Move blue stones to circle positions."
Print " U can move a stone by pushing it whis the man."
Print: Print: Print: Print
'Print " if u want to download new levels then u must"
'Print " accept the score publications via internet."
Print: Print: Print: Print
'Print " if u ready and accept publications, press 'Y'!"
'Print " else press 'any key'!"
Print " press 'any key'!"
Sleep
Dim TKey as String
Dim TKey1 as UByte
Dim TKey2 as UByte
Dim RV as Integer = 2
Dim TFL as UByte = 0
Dim XFN as Integer
G_Level = CUInt(Command())
If G_Level = 0 Then
XFN = FreeFile
Open "curlevel.dat" for Binary as XFN
TKey = Space(Lof(XFN))
Get #XFN, 1, Str(TKey)
Close #XFN
G_Level = CUInt(TKey)
Else: G_Level -= 1
End If
Do
If RV >= 2 Then
CLS()
If RV = 2 Then
If TFL = 1 Then
Print " U need '" & STr(Fix(G_NeedTime)) & "' seconds and '" & Str(G_NeedSteps) & "' steps!"
'G_NeedTime = Benötigte Zeit
'G_NeedSteps = Benötigte Schritte
' Draw String (10, 10), "Connecting so level-server...", &H000000
' Draw String (10, 20), "Check level steps...", &H888888
' Draw String (10, 30), "Download new level...", &H888888
Else: Print
End If
TFL = 1
Print
Print
G_Level += 1
Print " loading new level (" & Str(G_Level) & ")...";
End If
If LoadLevel(G_Level) <> 1 Then
Print " No more levels avaible!"
Print: Print
Print " CONGRATULATIONS!!! ... nerd! :)"
Sleep
Print: Print
Print " Game exit now!"
Sleep
End
End If
G_NeedSteps = 0
RV = 1
Print "DONE!"
Print: Print: Print
Print " if u ready, press 'any key'!"
Sleep
G_Time = Timer()
End If
TKey = InKey()
TKey1 = 0: TKey2 = 0
If Len(TKey) > 0 Then TKey1 = TKey[0]
If Len(TKey) > 1 Then TKey2 = TKey[1]
Select Case TKey1
Case 0
Case 8: RV = 3
Case 27: Exit Do
Case Else
Select Case TKey2
Case 75: RV = DoMove(1) 'left
Case 77: RV = DoMove(2) 'right
Case 72: RV = DoMove(3) 'top
Case 80: RV = DoMove(4) 'bot
Case 107: Exit Do
End Select
End Select
DoDraw()
If RV = 2 Then
G_NeedTime = Timer() - G_Time
Line (G_Width / 2 - 75, G_Height / 2 - 15)-(G_Width / 2 + 75, G_Height / 2 + 15), &H000000, BF
Draw String (G_Width / 2 - 59, G_Height / 2 - 4), "CONRATULATIONS!", &HFFFFFF
Sleep
Open "curlevel.dat" for Binary as XFN
Print #XFN, Str(G_Level);
Close #XFN
End If
Sleep 10, 1
Loop
ImageDestroy(G_IMGWall)
ImageDestroy(G_IMGStoneK)
ImageDestroy(G_IMGStoneN)
ImageDestroy(G_IMGTarget)
ImageDestroy(G_IMGMan)
Screen 0
End Sub
Main()
End 0