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 = 15
    
  5. Dim Shared G_FieldHeight                As Uinteger = 30
    
  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. Dim Shared G_LineC                      As Uinteger
    
  13. 
    
  14. 
    
  15. 
    
  16. '#######################################################################################################################################
    
  17. Sub DoDraw()
    
  18. Dim X As Integer
    
  19. Dim Y As Integer
    
  20. Dim TDX As Single = G_Width / G_FieldWidth
    
  21. Dim TDY As Single = G_Height / G_FieldHeight
    
  22. Screenlock()
    
  23. Cls()
    
  24. 'raster zeichnen
    
  25. For X = 1 To G_FieldWidth - 1
    
  26.     Line(TDX * X, 0)-(TDX * X, G_Height), Iif((X Mod 4) = 0, &H00444444, &H00111111)
    
  27. Next
    
  28. For Y = 1 To G_FieldHeight - 1
    
  29.     Line(0, TDY * Y)-(G_Width, TDY * Y), &H00111111
    
  30. Next
    
  31. 'feld zeichnen
    
  32. Dim C As Uinteger
    
  33. For Y = 0 To G_FieldHeight - 1
    
  34.     For X = 0 To G_FieldWidth - 1
    
  35.         Select Case G_FieldM(Y, X)
    
  36.             Case 0: C = &H00000000
    
  37.             Case 1: C = &H00FF0000
    
  38.             Case 2: C = &H0000FF00
    
  39.             Case 3: C = &H000000FF
    
  40.             Case 4: C = &H00FFFF00
    
  41.             Case 5: C = &H00FF00FF
    
  42.         End Select
    
  43.         Line(TDX * X + 1, TDY * Y + 1)-(TDX * (X + 1) - 1, TDY * (Y + 1) - 1), C, BF
    
  44.     Next
    
  45. Next
    
  46. 'Stein zeichnen
    
  47. For Y = 0 To 2
    
  48.     For X = 0 To 2
    
  49.         Select Case G_StoneT(Y, X)
    
  50.             Case 0: C = &H00000000
    
  51.             Case 1: C = &H00FF0000
    
  52.             Case 2: C = &H0000FF00
    
  53.             Case 3: C = &H000000FF
    
  54.             Case 4: C = &H00FFFF00
    
  55.             Case 5: C = &H00FF00FF
    
  56.         End Select
    
  57.         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
    
  58.     Next
    
  59. Next
    
  60. Draw String (0, 0), "Zeilen:" & Str(G_LineC), &H00000000
    
  61. Draw String (1, 1), "Zeilen:" & Str(G_LineC), &H00FFFFFF
    
  62. Screenunlock()
    
  63. End Sub
    
  64. 
    
  65. 
    
  66. 
    
  67. '#######################################################################################################################################
    
  68. Sub StoneRnd()
    
  69. 'zufallsstein
    
  70. Dim X As Integer
    
  71. Dim Y As Integer
    
  72. Dim C As Ubyte = Int((Rnd * 5) + 1)
    
  73. For Y = 0 To 2
    
  74.     For X = 0 To 2
    
  75.         G_StoneT(Y, X) = 0
    
  76.         If Int(Rnd * 2) = 1 Then G_StoneT(Y, X) = C
    
  77.     Next
    
  78. Next
    
  79. G_StoneX = G_FieldWidth \ 2
    
  80. G_StoneY = 0
    
  81. End Sub
    
  82. 
    
  83. 
    
  84. 
    
  85. '#######################################################################################################################################
    
  86. Sub StoneRnd2()
    
  87. 'zufallsstein nach vorgaben
    
  88. Dim C As Ubyte = Int((Rnd * 5) + 1)
    
  89. Dim X As Integer
    
  90. Dim Y As Integer
    
  91. For Y = 0 To 2
    
  92.     For X = 0 To 2
    
  93.         G_StoneT(Y, X) = 0
    
  94.     Next
    
  95. Next
    
  96. Select Case Int(Rnd * (6 + 1))
    
  97.     Case 0
    
  98.         '...
    
  99.         '.#.
    
  100.         '...
    
  101.         G_StoneT(1, 1) = C
    
  102.         
    
  103.     Case 1
    
  104.         '.#.
    
  105.         '.#.
    
  106.         '.#.
    
  107.         G_StoneT(0, 1) = C
    
  108.         G_StoneT(1, 1) = C
    
  109.         G_StoneT(2, 1) = C
    
  110.         
    
  111.     Case 2
    
  112.         '.#.
    
  113.         '.##
    
  114.         G_StoneT(0, 1) = C
    
  115.         G_StoneT(1, 1) = C
    
  116.         G_StoneT(1, 2) = C
    
  117.         
    
  118.     Case 3
    
  119.         '##.
    
  120.         '##.
    
  121.         '##.
    
  122.         For X = 0 To 2
    
  123.             G_StoneT(X, 0) = C
    
  124.             G_StoneT(X, 1) = C
    
  125.         Next
    
  126.         
    
  127.     Case 4
    
  128.         '#..
    
  129.         '.#.
    
  130.         '...
    
  131.         G_StoneT(0, 0) = C
    
  132.         G_StoneT(1, 1) = C
    
  133.         
    
  134.     Case 5
    
  135.         '#..
    
  136.         '###
    
  137.         '#..
    
  138.         G_StoneT(0, 0) = C
    
  139.         G_StoneT(1, 0) = C
    
  140.         G_StoneT(1, 1) = C
    
  141.         G_StoneT(1, 2) = C
    
  142.         G_StoneT(2, 0) = C
    
  143.         
    
  144.     Case 6
    
  145.         '#.#
    
  146.         '.#.
    
  147.         '...
    
  148.         G_StoneT(0, 0) = C
    
  149.         G_StoneT(0, 2) = C
    
  150.         G_StoneT(1, 1) = C
    
  151.         
    
  152. End Select
    
  153. G_StoneX = G_FieldWidth \ 2
    
  154. G_StoneY = 0
    
  155. End Sub
    
  156. 
    
  157. 
    
  158. 
    
  159. '#######################################################################################################################################
    
  160. Function StoneCheckPosible(V_Stone() As Ubyte, V_NewPosX As Integer, V_NewPosY As Integer) As Integer
    
  161. 'prüfen ob zug möglich ist
    
  162. Dim X As Integer
    
  163. Dim Y As Integer
    
  164. For Y = 0 To 2
    
  165.     For X = 0 To 2
    
  166.         If V_Stone(Y, X) <> 0 Then
    
  167.             If (V_NewPosX + X) < 0 Then Return -1
    
  168.             If (V_NewPosX + X) >= G_FieldWidth Then Return -2
    
  169.             If (V_NewPosY + Y) >= G_FieldHeight Then Return -3
    
  170.             If G_FieldM(V_NewPosY + Y, V_NewPosX + X) <> 0 Then
    
  171.                 If V_NewPosY <= 1 Then Return -5
    
  172.                 Return -4
    
  173.             End If
    
  174.         End If
    
  175.     Next
    
  176. Next
    
  177. Return 1
    
  178. End Function
    
  179. 
    
  180. 
    
  181. 
    
  182. '#######################################################################################################################################
    
  183. Sub StoneCopy(V_Stone() As Ubyte, R_Stone() As Ubyte)
    
  184. For Y As Integer = 0 To 2
    
  185.     For X As Integer = 0 To 2
    
  186.         R_Stone(Y, X) = V_Stone(Y, X)
    
  187.     Next
    
  188. Next
    
  189. End Sub
    
  190. 
    
  191. 
    
  192. 
    
  193. '#######################################################################################################################################
    
  194. Sub StonePlace()
    
  195. For Y As Integer = 0 To 2
    
  196.     For X As Integer = 0 To 2
    
  197.         If G_StoneT(Y, X) <> 0 Then G_FieldM(G_StoneY + Y, G_StoneX + X) = G_StoneT(Y, X)
    
  198.     Next
    
  199. Next
    
  200. End Sub
    
  201. 
    
  202. 
    
  203. 
    
  204. '#######################################################################################################################################
    
  205. Sub StoneRot(R_Stone() As Ubyte)
    
  206. Dim X As Integer
    
  207. For X = 0 To 2
    
  208.     R_Stone(0, X) = G_StoneT(X, 2)
    
  209.     R_Stone(1, X) = G_StoneT(X, 1)
    
  210.     R_Stone(2, X) = G_StoneT(X, 0)
    
  211. Next
    
  212. End Sub
    
  213. 
    
  214. 
    
  215. 
    
  216. '#######################################################################################################################################
    
  217. Function FieldClear(V_All As Ubyte = 0) As Integer
    
  218. Dim X As Integer
    
  219. Dim Y As Integer = G_FieldHeight - 1
    
  220. If V_All = 1 Then
    
  221.     For Y = 0 To G_FieldHeight - 1
    
  222.         For X As Integer = 0 To G_FieldWidth - 1
    
  223.             G_FieldM(Y, X) = 0
    
  224.         Next
    
  225.     Next
    
  226.     Return 1
    
  227. End If
    
  228. Dim Y1 As Integer
    
  229. Dim C As Uinteger
    
  230. Dim RV As Integer
    
  231. Do
    
  232.     C = 0
    
  233.     For X As Integer = 0 To G_FieldWidth - 1
    
  234.         If G_FieldM(Y, X) <> 0 Then C += 1
    
  235.     Next
    
  236.     If C = G_FieldWidth Then
    
  237.         For Y1 = Y To 1 Step -1
    
  238.             For X As Integer = 0 To G_FieldWidth - 1
    
  239.                 G_FieldM(Y1, X) = G_FieldM(Y1 - 1, X)
    
  240.             Next
    
  241.         Next
    
  242.         RV = 1
    
  243.         G_LineC += 1
    
  244.     Else: Y -= 1
    
  245.     End If
    
  246.     If Y = 0 Then Return RV
    
  247. Loop
    
  248. Return RV
    
  249. End Function
    
  250. 
    
  251. 
    
  252. 
    
  253. '#######################################################################################################################################
    
  254. Randomize Timer()
    
  255. Screenres G_Width, G_Height, 32
    
  256. Redim G_FieldM(0 To G_FieldHeight - 1, 0 To G_FieldWidth - 1) As Ubyte
    
  257. 
    
  258. StoneRnd()
    
  259. 
    
  260. Dim TTot As Double
    
  261. Dim TWaitT As Double = 500
    
  262. Dim TKey As String
    
  263. Dim TKey1 As Ubyte
    
  264. Dim TKey2 As Ubyte
    
  265. Dim TStep As Ubyte
    
  266. Dim TStoneT(0 To 2, 0 To 2) As Ubyte
    
  267. Dim X As Integer
    
  268. Dim Y As Integer
    
  269. TTot = Timer() + (TWaitT / 1000)
    
  270. Do
    
  271.     TStep = 0
    
  272.     Do
    
  273.         TKey = Inkey()
    
  274.         TKey1 = 0
    
  275.         TKey2 = 0
    
  276.         If Len(TKey) > 0 Then TKey1 = TKey[0]
    
  277.         If Len(TKey) > 1 Then TKey2 = TKey[1]
    
  278.         Select Case TKey1
    
  279.             Case 0: Exit Do
    
  280.             Case 13 'enter
    
  281.                 Y = G_StoneY
    
  282.                 Do
    
  283.                     Select Case StoneCheckPosible(G_StoneT(), G_StoneX, Y)
    
  284.                         Case -3, -4
    
  285.                             G_StoneY = Y - 1
    
  286.                             StonePlace()
    
  287.                             StoneRnd()
    
  288.                             If StoneCheckPosible(G_StoneT(), G_StoneX, G_StoneY) <> 1 Then FieldClear(1): StoneRnd()
    
  289.                             TTot = Timer() + (TWaitT / 1000)
    
  290.                             Exit Do
    
  291.                     End Select
    
  292.                     Y += 1
    
  293.                 Loop
    
  294.                 If FieldClear() = 1 Then If TWaitT > 0 Then TWaitT -= 1
    
  295.                 
    
  296.             Case 27 'esc
    
  297.                 End 0
    
  298.                 
    
  299.             Case 255
    
  300.                 Select Case TKey2
    
  301.                     Case 80 'down
    
  302.                         TStep = 1
    
  303.                         
    
  304.                     Case 72 'hoch
    
  305.                         StoneRot(TStoneT())
    
  306.                         X = G_StoneX
    
  307.                         Do
    
  308.                             Select Case StoneCheckPosible(TStoneT(), X, G_StoneY)
    
  309.                                 Case 1
    
  310.                                     StoneCopy(TStoneT(), G_StoneT())
    
  311.                                     G_StoneX = X
    
  312.                                     Exit Do
    
  313.                                 Case -1: X += 1
    
  314.                                 Case -2: X -= 1
    
  315.                                 Case Else: Exit Do
    
  316.                             End Select
    
  317.                         Loop
    
  318.                         FieldClear()
    
  319.                         
    
  320.                     Case 75 'left
    
  321.                         If StoneCheckPosible(G_StoneT(), G_StoneX - 1, G_StoneY) = 1 Then G_StoneX -= 1
    
  322.                         If FieldClear() = 1 Then If TWaitT > 0 Then TWaitT -= 1
    
  323.                         
    
  324.                     Case 77 'right
    
  325.                         If StoneCheckPosible(G_StoneT(), G_StoneX + 1, G_StoneY) = 1 Then G_StoneX += 1
    
  326.                         If FieldClear() = 1 Then If TWaitT > 0 Then TWaitT -= 1
    
  327.                         
    
  328.                     'Case Else: Print TKey1 & " " & TKey2: Sleep 1000, 1
    
  329.                 End Select
    
  330.             'Case Else: Print TKey1 & " " & TKey2: Sleep 1000, 1
    
  331.         End Select
    
  332.     Loop
    
  333.     If TTot < Timer() Then
    
  334.         TStep = 1
    
  335.     End If
    
  336.     If TStep = 1 Then
    
  337.         G_StoneY += 1
    
  338.         Select Case StoneCheckPosible(G_StoneT(), G_StoneX, G_StoneY)
    
  339.             Case -3, -4
    
  340.                 G_StoneY -= 1
    
  341.                 StonePlace()
    
  342.                 StoneRnd()
    
  343.                 If StoneCheckPosible(G_StoneT(), G_StoneX, G_StoneY) <> 1 Then FieldClear(1): StoneRnd()
    
  344.         End Select
    
  345.         If FieldClear() = 1 Then If TWaitT > 0 Then TWaitT -= 1
    
  346.         TTot = Timer() + (TWaitT / 1000)
    
  347.     End If
    
  348.     DoDraw()
    
  349.     Sleep 50, 1
    
  350. Loop
    
  351. 
    
  352. 
    
  353. Screen 0
    
  354. End 0
    
  355. 
    
  356.