' Created by Tom Kloosterman - 13/3/2010 in freebasic
' This is a simple program that simulates a slotmachine
' use spacebar to spin the reels or esc to quit

Randomize Timer

#Include "fbgfx.bi"
Using FB

Declare Sub blit2screen(image As Any Ptr)
Declare Function makereel(R1 As Integer, R2 As Integer, R3 As Integer) As Any Ptr
Declare Function checkprize(R1 As Integer, R2 As Integer, R3 As Integer) As Integer
Declare Function update()As Any Ptr
Declare Function rollreels()As Integer

Dim Shared As Any Ptr image, Rimage1, Rimage2, Rimage3
Dim Shared As Integer workpage, R1, R2, R3, Coins

' MainCode
WindowTitle("Toms simple slotmachine")
ScreenRes 320,180,32,2
SetMouse 0,0,0
Coins = 50
makereel(0,1,2) ' create the initial Rimage ptrs
Do
' listen if spacebar is pressed
If MultiKey(SC_SPACE) Then
Beep()
Coins -= 1
rollreels()
makereel(R1,R2,R3)
checkprize(R1,R2,R3)
EndIf
' update image
update()
' blit image to screen
blit2screen(image)
Sleep 100,1
Loop Until MultiKey(SC_ESCAPE)

' Subs
Sub blit2screen(image As Any Ptr)
ScreenLock
screenset workpage, workpage xor 1
Cls
Put (0,0),image
workpage xor = 1
ScreenUnLock
ImageDestroy(image)
ScreenSync
End Sub

' Funcs
Function rollreels()As Integer
If Coins > 0 Then
R1 = Int(Rnd(1)*6)
R2 = Int(Rnd(1)*6)
R3 = Int(Rnd(1)*6)
Return R1
Return R2
Return R3
Else ' if coins gets below 0 then coins is reset to 1
Coins = 1
EndIf
End Function

Function makereel(R1 As Integer, R2 As Integer, R3 As Integer) As Any Ptr
Rimage1 = ImageCreate (80,60,RGB(255,255,255),32)
Select Case R1
Case 0
Circle Rimage1,(40,30),15,RGB(255,0,0),,,,F
Case 1
Circle Rimage1,(40,30),15,RGB(0,255,0),,,,F
Case 2
Circle Rimage1,(40,30),15,RGB(0,0,255),,,,F
Case 3
Circle Rimage1,(40,30),15,RGB(255,255,0),,,,F
Case 4
Line Rimage1,(8,8)-(72,52),RGB(255,0,0),BF
Case 5
Line Rimage1,(8,8)-(72,52),RGB(0,255,0),BF
Case 6
Line Rimage1,(8,8)-(72,52),RGB(0,0,255),BF
End Select
Rimage2 = ImageCreate (80,60,RGB(255,255,255),32)
Select Case R2
Case 0
Circle Rimage2,(40,30),15,RGB(255,0,0),,,,F
Case 1
Circle Rimage2,(40,30),15,RGB(0,255,0),,,,F
Case 2
Circle Rimage2,(40,30),15,RGB(0,0,255),,,,F
Case 3
Circle Rimage2,(40,30),15,RGB(255,255,0),,,,F
Case 4
Line Rimage2,(8,8)-(72,52),RGB(255,0,0),BF
Case 5
Line Rimage2,(8,8)-(72,52),RGB(0,255,0),BF
Case 6
Line Rimage2,(8,8)-(72,52),RGB(0,0,255),BF
End Select
Rimage3 = ImageCreate (80,60,RGB(255,255,255),32)
Select Case R3
Case 0
Circle Rimage3,(40,30),15,RGB(255,0,0),,,,F
Case 1
Circle Rimage3,(40,30),15,RGB(0,255,0),,,,F
Case 2
Circle Rimage3,(40,30),15,RGB(0,0,255),,,,F
Case 3
Circle Rimage3,(40,30),15,RGB(255,255,0),,,,F
Case 4
Line Rimage3,(8,8)-(72,52),RGB(255,0,0),BF
Case 5
Line Rimage3,(8,8)-(72,52),RGB(0,255,0),BF
Case 6
Line Rimage3,(8,8)-(72,52),RGB(0,0,255),BF
End Select

Return Rimage1
Return Rimage2
Return Rimage3
ImageDestroy(Rimage1)
ImageDestroy(Rimage2)
ImageDestroy(Rimage3)
End Function

Function checkprize(R1 As Integer, R2 As Integer, R3 As Integer) As Integer
If R1 = R2 And R1 = R3 Then
Select Case R3
Case 0
Coins = Coins + 25
Case 1
Coins = Coins + 25
Case 2
Coins = Coins + 25
Case 3
Coins = Coins + 50
Case 4
Coins = Coins + 100
Case 5
Coins = Coins + 100
Case 6
Coins = Coins + 200
End Select
ElseIf R1 = R2 And R1 <> R3 Then
Select Case R2
Case 0
Coins = Coins + 5
Case 1
Coins = Coins + 5
Case 2
Coins = Coins + 5
Case 3
Coins = Coins + 10
Case 4
Coins = Coins + 15
Case 5
Coins = Coins + 15
Case 6
Coins = Coins + 20
End Select
EndIf
Return Coins
End Function

Function update()As Any Ptr
image = ImageCreate (320,240,RGB(0,0,0),32)

Put image,(21,20),Rimage1,PSet
Put image,(121,20),Rimage2,PSet
Put image,(221,20),Rimage3,PSet

Draw String image,(10,120),"Coins: "+Str(Coins),RGB(255,255,255)
Line (8,130)-(312,130),RGB(255,255,255)
Draw String image,(10,140),"Press space to spin the reels.",RGB(255,255,255)
Draw String image,(10,150),"Press escape to quit program.",RGB(255,255,255)
Draw String image,(10,160),"Programmed by Tom Kloosterman.",RGB(255,255,255)
Draw String image,(10,170),"Version 1.0 - TKGAMES 2010",RGB(255,255,255)
Return image
ImageDestroy(image)
End Function