chapter5

Private Declare Function GetTickCount Lib "kernel32" () As Long 'this function lets us not use timer
'timers are bad :)

'main body... each part of the snake has X and Y
Private Type Part
X As Integer
Y As Integer
End Type

'Dynamic array to store part coordinates
Dim Part() As Part

'Velocity in X and Y direction of the snake
Dim vX As Integer, vY As Integer
Dim i As Integer 'for loops
Dim CS As Single 'cell size

Dim FX As Integer, FY As Integer 'food coordinates
Dim X As Integer, Y As Integer

Dim bRunning As Boolean, died As Boolean

Private Sub Form_Load()
Randomize 'random generation

'Initialize controls******************
Picture1.BackColor = vbWhite
Picture1.ScaleMode = 3 'pixels

CS = 20 'cell size in pixels
X = Int(Picture1.ScaleWidth / CS)
Y = Int(Picture1.ScaleHeight / CS)

Picture1.AutoRedraw = True
Picture1.ScaleWidth = X * CS
Picture1.ScaleHeight = Y * CS

Me.WindowState = 2
Me.Show

DrawGrid Picture1, CS
'*************************************

died = False
'set up the game
ReDim Part(0)
Part(0).X = 0
Part(0).Y = 0

FX = Int(Rnd * X)
FY = Int(Rnd * Y)
'go to main loop
bRunning = True
MainLoop
End Sub

Sub MainLoop()
Do While bRunning = True
   Update
   Draw
   WAIT (50) 'increasing this number makes game slower
Loop

Unload Me
End Sub

Sub Update()
'MOVE PARTS
For i = UBound(Part) To 1 Step -1
   Part(i).X = Part(i - 1).X
   Part(i).Y = Part(i - 1).Y
Next i

'MOVE HEAD
Part(0).X = Part(0).X + vX
Part(0).Y = Part(0).Y + vY

'HAS HE GONE OUT OF BOUNDS ?
If Part(0).X <>= X Or Part(0).Y <>= Y Then
died = True
End If

'HAS HE CRASHED INTO HIMSELF ?
For i = 1 To UBound(Part)
If Part(i).X = Part(0).X And Part(i).Y = Part(0).Y Then
died = True
End If
Next i

'DID HE EAT FOOD ?
If Part(0).X = FX And Part(0).Y = FY Then
   ReDim Preserve Part(UBound(Part) + 1)
   Part(UBound(Part)).X = -CS
   Part(UBound(Part)).Y = -CS
   FX = Int(Rnd * X)
   FY = Int(Rnd * Y)
  
   Form1.Caption = "Parts: " & UBound(Part)
End If

'IS HE DEAD ?
If died = True Then NewGame
End Sub

Sub Draw()
   'DRAW WHITENESS
   Rectangle 0, 0, X * CS, Y * CS, vbWhite
   'DRAW SNAKE. PARTS IN BLUE, HEAD IN GREEN
   For i = 1 To UBound(Part)
   Rectangle Part(i).X * CS, Part(i).Y * CS, Part(i).X * CS + CS, Part(i).Y * CS + CS, vbBlue
   Next i
   Rectangle Part(0).X * CS, Part(0).Y * CS, Part(0).X * CS + CS, Part(0).Y * CS + CS, vbGreen
   'DRAW FOOD
   Rectangle FX * CS, FY * CS, FX * CS + CS, FY * CS + CS, vbRed
  
   DrawGrid Picture1, CS
End Sub

Sub Rectangle(X1 As Integer, Y1 As Integer, X2 As Integer, Y2 As Integer, color As Long)
   Picture1.Line (X1, Y1)-(X2, Y2), color, BF
End Sub

Sub NewGame()
'SET UP NEW GAME
died = False

ReDim Part(0)
Part(0).X = 0
Part(0).Y = 0

vX = 0
vY = 0

FX = Int(Rnd * X)
FY = Int(Rnd * Y)
End Sub

Sub DrawGrid(Pic As Control, CS As Single)
   '**************************************************************************
   'DRAW GRID
   '**************************************************************************
   Dim i As Integer, Across As Single, Up As Single
  
   Across = Pic.ScaleWidth / CS
   Up = Pic.ScaleHeight / CS
  
   For i = 0 To Across
       Pic.Line (i * CS, 0)-(i * CS, Up * CS)
   Next i
  
   For i = 0 To Up
       Pic.Line (0, i * CS)-(Across * CS, i * CS)
   Next i
End Sub

Sub WAIT(Tim As Integer)
   '**************************************************************************
   'WAIT FUNCTION
   '**************************************************************************
   Dim LastWait As Long
   LastWait = GetTickCount
  
   Do While Tim > GetTickCount - LastWait
   DoEvents
   Loop
End Sub

Private Sub Picture1_KeyDown(KeyCode As Integer, Shift As Integer)
'USER KEYPRESSES HANDLED HERE
Select Case KeyCode
Case vbKeyRight
vX = 1
vY = 0
Case vbKeyLeft
vX = -1
vY = 0
Case vbKeyUp
vX = 0
vY = -1
Case vbKeyDown
vX = 0
vY = 1
End Select
End Sub

Private Sub Picture1_KeyPress(KeyAscii As Integer)
'27 is ESC. IF user presses ESC, QUIT
If KeyAscii = 27 Then bRunning = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
'This function can be left out
End
End Sub