Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
tetrix.bas
| Uploader: |  ThePuppetMaster |
| Datum/Zeit: | 14.08.2012 11:42:01 |
'#######################################################################################################################################
Dim Shared G_Width as UInteger = 300
Dim Shared G_Height as UInteger = 600
Dim Shared G_FieldWidth as UInteger = 15
Dim Shared G_FieldHeight as UInteger = 30
Dim Shared G_FieldM() as UByte
Dim Shared G_StoneT(0 to 2, 0 to 2) as UByte
Dim Shared G_StoneX as Integer
Dim Shared G_StoneY as Integer
Dim Shared G_LineC as UInteger
'#######################################################################################################################################
Sub DoDraw()
Dim X as Integer
Dim Y as Integer
Dim TDX as Single = G_Width / G_FieldWidth
Dim TDY as Single = G_Height / G_FieldHeight
ScreenLock()
CLS()
'raster zeichnen
For X = 1 to G_FieldWidth - 1
Line(TDX * X, 0)-(TDX * X, G_Height), IIf((X mod 4) = 0, &H00444444, &H00111111)
Next
For Y = 1 to G_FieldHeight - 1
Line(0, TDY * Y)-(G_Width, TDY * Y), &H00111111
Next
'feld zeichnen
Dim C as UInteger
For Y = 0 to G_FieldHeight - 1
For X = 0 to G_FieldWidth - 1
Select Case G_FieldM(Y, X)
Case 0: C = &H00000000
Case 1: C = &H00FF0000
Case 2: C = &H0000FF00
Case 3: C = &H000000FF
Case 4: C = &H00FFFF00
Case 5: C = &H00FF00FF
End Select
Line(TDX * X + 1, TDY * Y + 1)-(TDX * (X + 1) - 1, TDY * (Y + 1) - 1), C, BF
Next
Next
'Stein zeichnen
For Y = 0 to 2
For X = 0 to 2
Select Case G_StoneT(Y, X)
Case 0: C = &H00000000
Case 1: C = &H00FF0000
Case 2: C = &H0000FF00
Case 3: C = &H000000FF
Case 4: C = &H00FFFF00
Case 5: C = &H00FF00FF
End Select
If C <> 0 Then Line(TDX * (G_StoneX + X) + 1, TDY * (G_StoneY + Y) + 1)-(TDX * (G_StoneX + X + 1) - 1, TDY * (G_StoneY + Y + 1) - 1), C, BF
Next
Next
Draw String (0, 0), "Zeilen:" & Str(G_LineC), &H00000000
Draw String (1, 1), "Zeilen:" & Str(G_LineC), &H00FFFFFF
ScreenUnLock()
End Sub
'#######################################################################################################################################
Sub StoneRnd()
'zufallsstein
Dim X as Integer
Dim Y as Integer
Dim C as UByte = Int((Rnd * 5) + 1)
For Y = 0 to 2
For X = 0 to 2
G_StoneT(Y, X) = 0
If Int(Rnd * 2) = 1 Then G_StoneT(Y, X) = C
Next
Next
G_StoneX = G_FieldWidth \ 2
G_StoneY = 0
End Sub
'#######################################################################################################################################
Sub StoneRnd2()
'zufallsstein nach vorgaben
Dim C as UByte = Int((Rnd * 5) + 1)
Dim X as Integer
Dim Y as Integer
For Y = 0 to 2
For X = 0 to 2
G_StoneT(Y, X) = 0
Next
Next
Select Case Int(Rnd * (6 + 1))
Case 0
'...
'.#.
'...
G_StoneT(1, 1) = C
Case 1
'.#.
'.#.
'.#.
G_StoneT(0, 1) = C
G_StoneT(1, 1) = C
G_StoneT(2, 1) = C
Case 2
'.#.
'.##
G_StoneT(0, 1) = C
G_StoneT(1, 1) = C
G_StoneT(1, 2) = C
Case 3
'##.
'##.
'##.
For X = 0 to 2
G_StoneT(X, 0) = C
G_StoneT(X, 1) = C
Next
Case 4
'#..
'.#.
'...
G_StoneT(0, 0) = C
G_StoneT(1, 1) = C
Case 5
'#..
'###
'#..
G_StoneT(0, 0) = C
G_StoneT(1, 0) = C
G_StoneT(1, 1) = C
G_StoneT(1, 2) = C
G_StoneT(2, 0) = C
Case 6
'#.#
'.#.
'...
G_StoneT(0, 0) = C
G_StoneT(0, 2) = C
G_StoneT(1, 1) = C
End Select
G_StoneX = G_FieldWidth \ 2
G_StoneY = 0
End Sub
'#######################################################################################################################################
Function StoneCheckPosible(V_Stone() as UByte, V_NewPosX as Integer, V_NewPosY as Integer) as Integer
'prüfen ob zug möglich ist
Dim X as Integer
Dim Y as Integer
For Y = 0 to 2
For X = 0 to 2
If V_Stone(Y, X) <> 0 Then
If (V_NewPosX + X) < 0 Then Return -1
If (V_NewPosX + X) >= G_FieldWidth Then Return -2
If (V_NewPosY + Y) >= G_FieldHeight Then Return -3
If G_FieldM(V_NewPosY + Y, V_NewPosX + X) <> 0 Then
If V_NewPosY <= 1 then Return -5
Return -4
End If
End If
Next
Next
Return 1
End Function
'#######################################################################################################################################
Sub StoneCopy(V_Stone() as UByte, R_Stone() as UByte)
For Y as Integer = 0 to 2
For X as Integer = 0 to 2
R_Stone(Y, X) = V_Stone(Y, X)
Next
Next
End Sub
'#######################################################################################################################################
Sub StonePlace()
For Y as Integer = 0 to 2
For X as Integer = 0 to 2
If G_StoneT(Y, X) <> 0 Then G_FieldM(G_StoneY + Y, G_StoneX + X) = G_StoneT(Y, X)
Next
Next
End Sub
'#######################################################################################################################################
Sub StoneRot(R_Stone() as UByte)
Dim X as Integer
For X = 0 to 2
R_Stone(0, X) = G_StoneT(X, 2)
R_Stone(0, X) = G_StoneT(X, 2)
R_Stone(0, X) = G_StoneT(X, 2)
R_Stone(1, X) = G_StoneT(X, 1)
R_Stone(2, X) = G_StoneT(X, 0)
R_Stone(2, X) = G_StoneT(X, 0)
R_Stone(2, X) = G_StoneT(X, 0)
Next
End Sub
'#######################################################################################################################################
Function FieldClear(V_All as UByte = 0) as Integer
Dim X as Integer
Dim Y as Integer = G_FieldHeight - 1
If V_All = 1 Then
For Y = 0 to G_FieldHeight - 1
For X as Integer = 0 to G_FieldWidth - 1
G_FieldM(Y, X) = 0
Next
Next
Return 1
End If
Dim Y1 as Integer
Dim C as UInteger
Dim RV as Integer
Do
C = 0
For X as Integer = 0 to G_FieldWidth - 1
If G_FieldM(Y, X) <> 0 Then C += 1
Next
If C = G_FieldWidth Then
For Y1 = Y to 1 Step -1
For X as Integer = 0 to G_FieldWidth - 1
G_FieldM(Y1, X) = G_FieldM(Y1 - 1, X)
Next
Next
RV = 1
G_LineC += 1
Else: Y -= 1
End If
If Y = 0 Then Return RV
Loop
Return RV
End Function
'#######################################################################################################################################
Randomize Timer()
Screenres G_Width, G_Height, 32
Redim G_FieldM(0 to G_FieldHeight - 1, 0 to G_FieldWidth - 1) as UByte
StoneRnd()
Dim TTot as Double
Dim TWaitT as Double = 500
Dim TKey as String
Dim TKey1 as UByte
Dim TKey2 as UByte
Dim TStep as Ubyte
Dim TStoneT(0 to 2, 0 to 2) as UByte
Dim X as Integer
Dim Y as Integer
TTot = Timer() + (TWaitT / 1000)
Do
TStep = 0
Do
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: Exit Do
Case 13 'enter
Y = G_StoneY
Do
Select Case StoneCheckPosible(G_StoneT(), G_StoneX, Y)
Case -3, -4
G_StoneY = Y - 1
StonePlace()
StoneRnd()
If StoneCheckPosible(G_StoneT(), G_StoneX, G_StoneY) <> 1 Then FieldClear(1): StoneRnd()
TTot = Timer() + (TWaitT / 1000)
Exit Do
End Select
Y += 1
Loop
If FieldClear() = 1 Then If TWaitT > 0 Then TWaitT -= 1
Case 27 'esc
End 0
Case 255
Select Case TKey2
Case 80 'down
TStep = 1
Case 72 'hoch
StoneRot(TStoneT())
X = G_StoneX
Do
Select Case StoneCheckPosible(TStoneT(), X, G_StoneY)
Case 1
StoneCopy(TStoneT(), G_StoneT())
G_StoneX = X
Exit Do
Case -1: X += 1
Case -2: X -= 1
Case Else: Exit Do
End Select
Loop
FieldClear()
Case 75 'left
If StoneCheckPosible(G_StoneT(), G_StoneX - 1, G_StoneY) = 1 Then G_StoneX -= 1
If FieldClear() = 1 Then If TWaitT > 0 Then TWaitT -= 1
Case 77 'right
If StoneCheckPosible(G_StoneT(), G_StoneX + 1, G_StoneY) = 1 Then G_StoneX += 1
If FieldClear() = 1 Then If TWaitT > 0 Then TWaitT -= 1
'Case Else: Print TKey1 & " " & TKey2: Sleep 1000, 1
End Select
'Case Else: Print TKey1 & " " & TKey2: Sleep 1000, 1
End Select
Loop
If TTot < Timer() Then
TStep = 1
End If
If TStep = 1 Then
G_StoneY += 1
Select Case StoneCheckPosible(G_StoneT(), G_StoneX, G_StoneY)
Case -3, -4
G_StoneY -= 1
StonePlace()
StoneRnd()
If StoneCheckPosible(G_StoneT(), G_StoneX, G_StoneY) <> 1 Then FieldClear(1): StoneRnd()
End Select
If FieldClear() = 1 Then If TWaitT > 0 Then TWaitT -= 1
TTot = Timer() + (TWaitT / 1000)
End If
DoDraw()
Sleep 50, 1
Loop
Screen 0
End 0