Home

Add

Edit

Without Linenumbers

Code in Textfield

Download

  1. '#######################################################################################################################################
    
  2. Dim Shared G_Width                      As Uinteger = 300
    
  3. Dim Shared G_Height                     As Uinteger = 600
    
  4. Dim Shared G_FieldWidth                 As Uinteger = 20
    
  5. Dim Shared G_FieldHeight                As Uinteger = 40
    
  6. Dim Shared G_FieldM()                   As Ubyte
    
  7. 
    
  8. Dim Shared G_StoneT(0 To 2, 0 To 2)     As Ubyte
    
  9. Dim Shared G_StoneX                     As Integer
    
  10. Dim Shared G_StoneY                     As Integer
    
  11. 
    
  12. 
    
  13. 
    
  14. '#######################################################################################################################################
    
  15. Sub DoDraw()
    
  16. Dim X As Integer
    
  17. Dim Y As Integer
    
  18. Dim TDX As Single = G_Width / G_FieldWidth
    
  19. Dim TDY As Single = G_Height / G_FieldHeight
    
  20. Screenlock()
    
  21. Cls()
    
  22. 'raster zeichnen
    
  23. For X = 1 To G_FieldWidth - 1
    
  24.     Line(TDX * X, 0)-(TDX * X, G_Height), Iif((X Mod 4) = 0, &H00444444, &H00111111)
    
  25. Next
    
  26. For Y = 1 To G_FieldHeight - 1
    
  27.     Line(0, TDY * Y)-(G_Width, TDY * Y), &H00111111
    
  28. Next
    
  29. 'feld zeichnen
    
  30. Dim C As Uinteger
    
  31. For Y = 0 To G_FieldHeight - 1
    
  32.     For X = 0 To G_FieldWidth - 1
    
  33.         Select Case G_FieldM(Y, X)
    
  34.             Case 0: C = &H00000000
    
  35.             Case 1: C = &H00FF0000
    
  36.             Case 2: C = &H0000FF00
    
  37.             Case 3: C = &H000000FF
    
  38.             Case 4: C = &H00FFFF00
    
  39.             Case 5: C = &H00FF00FF
    
  40.         End Select
    
  41.         Line(TDX * X + 1, TDY * Y + 1)-(TDX * (X + 1) - 1, TDY * (Y + 1) - 1), C, BF
    
  42.     Next
    
  43. Next
    
  44. 'Stein zeichnen
    
  45. For Y = 0 To 2
    
  46.     For X = 0 To 2
    
  47.         Select Case G_StoneT(Y, X)
    
  48.             Case 0: C = &H00000000
    
  49.             Case 1: C = &H00FF0000
    
  50.             Case 2: C = &H0000FF00
    
  51.             Case 3: C = &H000000FF
    
  52.             Case 4: C = &H00FFFF00
    
  53.             Case 5: C = &H00FF00FF
    
  54.         End Select
    
  55.         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
    
  56.     Next
    
  57. Next
    
  58. Screenunlock()
    
  59. End Sub
    
  60. 
    
  61. 
    
  62. 
    
  63. '#######################################################################################################################################
    
  64. Sub StoneRnd()
    
  65. 'zufallsstein
    
  66. Dim X As Integer
    
  67. Dim Y As Integer
    
  68. Dim C As Ubyte = Int((Rnd * 5) + 1)
    
  69. For Y = 0 To 2
    
  70.     For X = 0 To 2
    
  71.         G_StoneT(Y, X) = 0
    
  72.         If Int(Rnd * 2) = 1 Then G_StoneT(Y, X) = C
    
  73.     Next
    
  74. Next
    
  75. G_StoneX = 0
    
  76. G_StoneY = 0
    
  77. End Sub
    
  78. 
    
  79. 
    
  80. 
    
  81. '#######################################################################################################################################
    
  82. Function StoneCheckPosible(V_Stone() As Ubyte, V_NewPosX As Integer, V_NewPosY As Integer) As Integer
    
  83. 'prüfen ob zug möglich ist
    
  84. Dim X As Integer
    
  85. Dim Y As Integer
    
  86. For Y = 0 To 2
    
  87.     For X = 0 To 2
    
  88.         If V_Stone(Y, X) <> 0 Then
    
  89.             If (V_NewPosX + X) < 0 Then Return -1
    
  90.             If (V_NewPosX + X) >= G_FieldWidth Then Return -2
    
  91.             If (V_NewPosY + Y) >= G_FieldHeight Then Return -3
    
  92.             If G_FieldM(V_NewPosY + Y, V_NewPosX + X) <> 0 Then
    
  93.                 If V_NewPosY <= 1 Then Return -5
    
  94.                 Return -4
    
  95.             End If
    
  96.         End If
    
  97.     Next
    
  98. Next
    
  99. Return 1
    
  100. End Function
    
  101. 
    
  102. 
    
  103. 
    
  104. '#######################################################################################################################################
    
  105. Sub StoneCopy(V_Stone() As Ubyte, R_Stone() As Ubyte)
    
  106. For Y As Integer = 0 To 2
    
  107.     For X As Integer = 0 To 2
    
  108.         R_Stone(Y, X) = V_Stone(Y, X)
    
  109.     Next
    
  110. Next
    
  111. End Sub
    
  112. 
    
  113. 
    
  114. 
    
  115. '#######################################################################################################################################
    
  116. Sub StonePlace()
    
  117. For Y As Integer = 0 To 2
    
  118.     For X As Integer = 0 To 2
    
  119.         If G_StoneT(Y, X) <> 0 Then G_FieldM(G_StoneY + Y, G_StoneX + X) = G_StoneT(Y, X)
    
  120.     Next
    
  121. Next
    
  122. End Sub
    
  123. 
    
  124. 
    
  125. 
    
  126. '#######################################################################################################################################
    
  127. Sub StoneRot(R_Stone() As Ubyte)
    
  128. Dim X As Integer
    
  129. For X = 0 To 2
    
  130.     R_Stone(0, X) = G_StoneT(X, 2)
    
  131.     R_Stone(0, X) = G_StoneT(X, 2)
    
  132.     R_Stone(0, X) = G_StoneT(X, 2)
    
  133.     R_Stone(1, X) = G_StoneT(X, 1)
    
  134.     R_Stone(2, X) = G_StoneT(X, 0)
    
  135.     R_Stone(2, X) = G_StoneT(X, 0)
    
  136.     R_Stone(2, X) = G_StoneT(X, 0)
    
  137. Next
    
  138. End Sub
    
  139. 
    
  140. 
    
  141. 
    
  142. '#######################################################################################################################################
    
  143. Sub FieldClear()
    
  144. Dim X As Integer
    
  145. Dim Y As Integer
    
  146. Dim C As Uinteger
    
  147. Do
    
  148.     C = 0
    
  149.     For X As Integer = 0 To G_FieldWidth - 1
    
  150.         If G_FieldM(Y, X) <> 0 Then C += 1
    
  151.     Next
    
  152.     If C = G_FieldWidth Then
    
  153.         For X As Integer = 0 To G_FieldWidth - 1
    
  154.             If G_FieldM(Y, X) <> 0 Then C += 1
    
  155.         Next
    
  156.     End If
    
  157.     Y += 1
    
  158.     If Y >= G_FieldHeight Then Exit Do
    
  159. Loop
    
  160. End Sub
    
  161. 
    
  162. 
    
  163. 
    
  164. '#######################################################################################################################################
    
  165. Randomize Timer()
    
  166. Screenres G_Width, G_Height, 32
    
  167. Redim G_FieldM(0 To G_FieldHeight - 1, 0 To G_FieldWidth - 1) As Ubyte
    
  168. 
    
  169. StoneRnd()
    
  170. 
    
  171. Dim TTot As Double
    
  172. Dim TWaitT As Double = 500
    
  173. Dim TKey As String
    
  174. Dim TKey1 As Ubyte
    
  175. Dim TKey2 As Ubyte
    
  176. Dim TStep As Ubyte
    
  177. Dim TStoneT(0 To 2, 0 To 2) As Ubyte
    
  178. Dim X As Integer
    
  179. Dim Y As Integer
    
  180. TTot = Timer() + (TWaitT / 1000)
    
  181. Do
    
  182.     TStep = 0
    
  183.     TKey = Inkey()
    
  184.     TKey1 = 0
    
  185.     TKey2 = 0
    
  186.     If Len(TKey) > 0 Then TKey1 = TKey[0]
    
  187.     If Len(TKey) > 1 Then TKey2 = TKey[1]
    
  188.     Select Case TKey1
    
  189.         Case 0
    
  190.         Case 13 'enter
    
  191.             Y = G_StoneY
    
  192.             Do
    
  193.                 Select Case StoneCheckPosible(G_StoneT(), G_StoneX, Y)
    
  194.                     Case -3, -4
    
  195.                         G_StoneY = Y - 1
    
  196.                         StonePlace()
    
  197.                         StoneRnd()
    
  198.                         Exit Do
    
  199.                 End Select
    
  200.                 Y += 1
    
  201.             Loop
    
  202.             
    
  203.         Case 27 'esc
    
  204.             Exit Do
    
  205.             
    
  206.         Case 255
    
  207.             Select Case TKey2
    
  208.                 Case 80 'down
    
  209.                     TStep = 1
    
  210.                     
    
  211.                 Case 72 'hoch
    
  212.                     StoneRot(TStoneT())
    
  213.                     X = G_StoneX
    
  214.                     Do
    
  215.                         Select Case StoneCheckPosible(TStoneT(), X, G_StoneY)
    
  216.                             Case 1
    
  217.                                 StoneCopy(TStoneT(), G_StoneT())
    
  218.                                 G_StoneX = X
    
  219.                                 Exit Do
    
  220.                             Case -1: X += 1
    
  221.                             Case -2: X -= 1
    
  222.                             Case Else: Exit Do
    
  223.                         End Select
    
  224.                     Loop
    
  225.                     
    
  226.                 Case 75 'left
    
  227.                     If StoneCheckPosible(G_StoneT(), G_StoneX - 1, G_StoneY) = 1 Then G_StoneX -= 1
    
  228.                     
    
  229.                 Case 77 'right
    
  230.                     If StoneCheckPosible(G_StoneT(), G_StoneX + 1, G_StoneY) = 1 Then G_StoneX += 1
    
  231.                     
    
  232.                 Case Else: Print TKey1 & " " & TKey2: Sleep 1000, 1
    
  233.             End Select
    
  234.         Case Else: Print TKey1 & " " & TKey2: Sleep 1000, 1
    
  235.     End Select
    
  236.     Do Until Inkey() = ""
    
  237.     Loop
    
  238.     If TTot < Timer() Then
    
  239.         TStep = 1
    
  240.     End If
    
  241.     If TStep = 1 Then
    
  242.         G_StoneY += 1
    
  243.         Select Case StoneCheckPosible(G_StoneT(), G_StoneX, G_StoneY)
    
  244.             Case -3, -4
    
  245.                 G_StoneY -= 1
    
  246.                 StonePlace()
    
  247.                 StoneRnd()
    
  248.         End Select
    
  249.         TTot = Timer() + (TWaitT / 1000)
    
  250.     End If
    
  251.     DoDraw()
    
  252.     Sleep 50, 1
    
  253. Loop
    
  254. 
    
  255. 
    
  256. Screen 0
    
  257. End 0
    
  258. 
    
  259.