Solved

# Rummy Game, Complete Application  400 Points

Posted on 2000-04-28
465 Views
I need an entire program and here's the entire program description:

The game is called Rummy.

There are two players in the game, playing against each other.

Seven cards are alternately dealt face down to each player.

The remaining cards are placed face down on the table between them.

The object of the game is to have 4 of one kind of card, and 3 of another as in four kings and three queens or four jacks and three sevens.   4 hearts and 3 tens does not win.

The top card of the face down pile is turned over and placed face up next to the face down pile.

The player that was dealt the first card will go first.

Player 1 has the choice of either picking up the top card of the face up pile or picking up the top card of the face down pile.  The other player knows the value of the face up card, but the face down card is kept secret, only known by the player that picked it up.

Now player 1 has 8 cards and must decide which card to remove from his hand.  He can choose to discard the card he just picked up, or discard one from the hand.  This card will be placed on the top of the face up pile.  Player 2 now has to decide whether to pick the face up card up or choose one from the face down pile.   This continues until one of the players has 3 of one kind and 4 of another and that player is the winner.

It must be simulated in 10, 50 and 100 tournaments.

Anyone has any thoughts on this, especially regarding the algorithms on deciding what card to discard and when they win.

Tax
0
Question by:prosit
• 19
• 15

LVL 2

Expert Comment

ID: 2759747
I am currently writing a Pedro game using the Cards.DLL supplied by Windows.  I am currently working on the algorithms.  Rummy is some what easier.  I will take a look at puting together the algorithms for rummy if noone else has them.  It will naturally take me some time to do this, so I will keep refering to any comments that appear here.
0

LVL 2

Expert Comment

ID: 2759781
The algorithms here really aren't that tough.  The Cards.DLL give you the ability to have two decks of cards.  The cards for the first deck are numbered 1-52 and 53 - 104 for the second.  The suits are broken up in suits, so the first 13 are the same suit.  If you were looking for cards with the same value, you would only have to increment the cards by 13 to see if the cards exist.  If 3 out of the posible 4 exist you have a play.  As far as the run, this is even easier because the value of the cards would be in number order.  I can email you what I have done so far in my pedro game so you can take a look at the use of the Cards.Dll
0

LVL 2

Expert Comment

ID: 2759820
Have you started this project yet?
0

LVL 2

Expert Comment

ID: 2759869
Here is an example of my Cards.Bas file:

Option Explicit

Declare Function WinHelp Lib "user32" Alias "WinHelpA" (ByVal hwnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Long) As Long

' Some useful constants
Global Const FACEDOWN = 0
Global Const FACEUP = 1
Global Const CARDWIDTH = 71
Global Const CARDHEIGHT = 96
Global Const OFFSET = 16

' Required in Form Load to use dll
Declare Function InitializeDeck Lib "qcard32.dll" (ByVal hwnd As Long) As Long
' Reset all card values to defaults
Declare Sub SetDefaultValues Lib "qcard32.dll" ()
' Set the currently used card back design for cards 105 to 109
Declare Sub SetCurrentBack Lib "qcard32.dll" (ByVal nIndex As Long)

' Card drawing subs
Declare Sub DrawSymbol Lib "qcard32.dll" (ByVal hwnd As Long, ByVal nValue As Long, ByVal X As Long, ByVal Y As Long)
Declare Sub DrawCard Lib "qcard32.dll" (ByVal hwnd As Long, ByVal nCard As Long, ByVal X As Long, ByVal Y As Long)
Declare Sub DrawBack Lib "qcard32.dll" (ByVal hwnd As Long, ByVal nValue As Long, ByVal X As Long, ByVal Y As Long)
Declare Sub DealCard Lib "qcard32.dll" (ByVal hwnd As Long, ByVal nCard As Long, ByVal X As Long, ByVal Y As Long)
Declare Sub RemoveCard Lib "qcard32.dll" (ByVal hwnd As Long, ByVal nCard As Long)

' Get card information functions
Declare Function GetCardColor Lib "qcard32.dll" (ByVal nCard As Long) As Long
Declare Function GetCardSuit Lib "qcard32.dll" (ByVal nCard As Long) As Long
Declare Function GetCardValue Lib "qcard32.dll" (ByVal nCard As Long) As Long
Declare Function GetCardStatus Lib "qcard32.dll" (ByVal nCard As Long) As Long
Declare Function GetCardBlocked Lib "qcard32.dll" (ByVal nCard As Long) As Long
Declare Function IsCardDisabled Lib "qcard32.dll" (ByVal nCard As Long) As Long
Declare Function GetCardX Lib "qcard32.dll" (ByVal nCard As Long) As Long
Declare Function GetCardY Lib "qcard32.dll" (ByVal nCard As Long) As Long
Declare Function GetUser1 Lib "qcard32.dll" (ByVal nCard As Long) As Long
Declare Function GetUser2 Lib "qcard32.dll" (ByVal nCard As Long) As Long
Declare Function GetUser3 Lib "qcard32.dll" (ByVal nCard As Long) As Long
Declare Function GetUser4 Lib "qcard32.dll" (ByVal nCard As Long) As Long

' Set card information subs
Declare Sub SetCardStatus Lib "qcard32.dll" (ByVal nCard As Long, ByVal bValue As Long)
Declare Sub AdjustCardBlocked Lib "qcard32.dll" (ByVal nCard As Long, ByVal bValue As Long)
Declare Sub SetCardDisabled Lib "qcard32.dll" (ByVal nCard As Long, ByVal bValue As Long)
Declare Sub SetCardX Lib "qcard32.dll" (ByVal nCard As Long, ByVal X As Long)
Declare Sub SetCardY Lib "qcard32.dll" (ByVal nCard As Long, ByVal Y As Long)
Declare Sub SetUser1 Lib "qcard32.dll" (ByVal nCard As Long, ByVal bValue As Long)
Declare Sub SetUser2 Lib "qcard32.dll" (ByVal nCard As Long, ByVal nValue As Long)
Declare Sub SetUser3 Lib "qcard32.dll" (ByVal nCard As Long, ByVal nValue As Long)
Declare Sub SetUser4 Lib "qcard32.dll" (ByVal nCard As Long, ByVal nValue As Long)
Declare Sub SetOffSet Lib "qcard32.dll" (ByVal nValue As Long)

' Dragging subs and functions
Declare Function InitDrag Lib "qcard32.dll" (ByVal hwnd As Long, ByVal X As Long, ByVal Y As Long) As Long
Declare Sub AbortDrag Lib "qcard32.dll" ()
Declare Sub DoDrag Lib "qcard32.dll" (ByVal hwnd As Long, ByVal X As Long, ByVal Y As Long)
Declare Function EndDrag Lib "qcard32.dll" (ByVal hwnd As Long, ByVal X As Long, ByVal Y As Long) As Long
Declare Sub ReturnDrag Lib "qcard32.dll" (ByVal hwnd As Long, ByVal nCard As Long, ByVal nOldX As Long, ByVal nOldY As Long)
Declare Sub BlockDrag Lib "qcard32.dll" (ByVal hwnd As Long, nFirst As Long, ByVal nNumCards As Long, ByVal X As Long, ByVal Y As Long)
Declare Function EndBlockDrag Lib "qcard32.dll" (ByVal hwnd As Long, nFirst As Long, ByVal nNumCards As Long, ByVal X As Long, ByVal Y As Long) As Long
Declare Sub ReturnBlockDrag Lib "qcard32.dll" (ByVal hwnd As Long, nFirst As Long, ByVal nNumCards As Long, ByVal X As Long, ByVal Y As Long)
Declare Function GetFreeDestination Lib "qcard32.dll" (ByVal nSource As Long) As Long

' Undocumented functions, generally not used

' returns the number of any unblocked card which lies beneath the mouse coordinates x, y
Declare Function PointInFreeCard Lib "qcard32.dll" (ByVal X As Long, ByVal Y As Long) As Long

' returns the number of any card whose top 16 (or OffSet) pixels lie beneath the mouse coordinates x, y
Declare Function PointInCardTop Lib "qcard32.dll" (ByVal X As Long, ByVal Y As Long) As Long

' manually sets the active drag card for a subsequent DoDrag or BlockDrag call
Declare Sub SetActiveCard Lib "qcard32.dll" (ByVal nCard As Long)

Public PassArray As Variant
Public intPassNum As Integer
Public blnExtra As Boolean
0

LVL 2

Author Comment

ID: 2759885
No I haven't started it yet, more than declaring some variables and such.

I don't have to make the game as far as showing cards being dealt.  It's only a simulation.

Please email whatever you have to taxman@coolemail.com.

thanks

me
0

LVL 2

Expert Comment

ID: 2759917
I'm sorry, I though you were making a game.  I emailed you what I have done so far.  I should be done by monday if I have time.  The simulation would work the same way.  You just won't need a GUI.  You would probally want to assign the cards numerical values in the same suit as described above.  Use a random order generater to shuffle the cards.  (This code has been emailed to you.)

Are you allowing the computer to pick up a card in the discarded pile under other cards?
0

LVL 2

Author Comment

ID: 2763093
Oh you are not even supposed to play with the computer, it's just supposed to be a simulation of the computer playing against itself.

Tax
0

LVL 2

Author Comment

ID: 2763094

T
0

LVL 2

Expert Comment

ID: 2764802
I should have somehthing for you on monday that should satisfy your need.
0

LVL 2

Author Comment

ID: 2764957
I appreciate it dude!

Thanks

tax
0

LVL 2

Expert Comment

ID: 2767266
Tax,  I nuked it.  I should be done shortly.  I was counting consecutive runs also.
0

LVL 2

Author Comment

ID: 2767392
thanks dude!

let me know!

tax
0

LVL 2

Expert Comment

ID: 2767475
Option Explicit
Option Base 1

Public Winner%

Public Player%(2, 8)
Public Deck%()
Public Played(13, 4)
Public Points(2)
Public Sub InitCards()

Dim iCards%
ReDim Deck(52)

Winner = 0
For iCards = 1 To 52
Deck(iCards) = iCards
Next iCards

End Sub

Public Sub ShuffleCards()

Dim iTimes%, iCards%, iRand%, iTemp%

For iTimes = 1 To 10
For iCards = 1 To 52
iRand = Int(Rnd * 52) + 1
iTemp = Deck(iCards)
Deck(iCards) = Deck(iRand)
Deck(iRand) = iTemp
Next iCards
Next iTimes

End Sub

Public Sub DealCards()

Dim iCtr%
Dim iCards%

iCards = 53
For iCtr = 1 To 7
iCards = iCards - 1
Player(1, iCtr) = Deck(iCards)
iCards = iCards - 1
Player(2, iCtr) = Deck(iCards)
Next iCtr

iCards = iCards - 1

iCards = iCards - 1
ReDim Preserve Deck(iCards)

End Sub

Public Sub Play(Turn As Integer)

Dim Checking%(7)
Dim iOne%
Dim iTwo%
Dim iThree%
Dim iFour%
Dim iPossiblePlay%
Dim iDefPlay%

'If iDraw remains zero, player will draw from downward pile
'If iDraw in 1, then player will pickup discard
iDraw = 0

'Check possible runs
For iCards = 1 To 7
Checking(iCards) = Player(Turn, iCards)
Next iCards

'Bubblesort Checking(), 1, 7
SuitSort Checking(), 1, 7
For iCards = 1 To 6
If Checking(iCards) Mod 13 = Checking(iCards + 1) Mod 13 Then
iTwo = 1
iPossiblePlay = 1
If iCards < 5 Then
If Checking(iCards + 1) Mod 13 = Checking(iCards + 2) Mod 13 Then
iThree = 1
iTwo = Checking(iCards + 1) Mod 13
End If
If Checking(iCards + 2) Mod 13 = Checking(iCards + 3) Mod 13 Then
iFour = 1
If iThree > 0 And iCards < 4 Then
iThree = 0
End If
If iCards < 3 Then
iCards = 3
End If
End If
End If
Else

iOne = iCards

End If

Next iCards

If iThree = 1 And iFour = 1 Then
Winner = Turn
End If

If iTwo = (iTop Mod 13) Then
iDraw = 1
End If

If iDraw <> 0 Then
Player(Turn, 8) = iTop
Else
Player(Turn, 8) = Deck(UBound(Deck))
End If

If (Player(Turn, 8) Mod 13) = iTwo Then
Winner = Turn
End If

If iOne > 0 Then
Checking(iOne) = Player(Turn, 8)
For iCards = 1 To 7
Player(Turn, iCards) = Checking(iCards)
Next iCards
'ReDim Preserve Player(Turn, 7)
'Player(Turn, 8) = Null
End If

End Sub

Public Sub SuitSort(List() As Integer, ByVal min As Long, ByVal max As Long)
Dim last_swap As Long
Dim i As Long
Dim j As Long
Dim tmp As Long
Dim iCtr%
' Repeat until we are done.

Do While min < max
' Bubble up.
last_swap = min - 1
' For i = min + 1 To max
i = min + 1
Do While i <= max
' Find a bubble.
If List(i - 1) Mod 13 > List(i) Mod 13 Then
' See where to drop the bubble.
tmp = List(i - 1)
j = i
Do
List(j - 1) = List(j)
j = j + 1
If j > max Then Exit Do
Loop While List(j) Mod 13 < tmp Mod 13
List(j - 1) = tmp
last_swap = j - 1
i = j + 1
Else
i = i + 1
End If
Loop
' Update max.
max = last_swap - 1

' Bubble down.
last_swap = max + 1
' For i = max - 1 To min Step -1
i = max - 1
Do While i >= min
' Find a bubble.
If List(i + 1) Mod 13 < List(i) Mod 13 Then
' See where to drop the bubble.
tmp = List(i + 1)
j = i
Do
List(j + 1) = List(j)
j = j - 1
If j < min Then Exit Do
Loop While List(j) Mod 13 > tmp Mod 13
List(j + 1) = tmp
last_swap = j + 1
i = j - 1
Else
i = i - 1
End If
Loop
' Update min.
min = last_swap + 1
Loop

End Sub

' ************************************************
' Bubblesort with:
'   - Alternating upward and downward passes
'   - Holding bubbled item in a temporary
'       variable
'   - Updating min and max to narrow the search
'       range
' ************************************************
Public Sub Bubblesort(List() As Integer, ByVal min As Long, ByVal max As Long)
Dim last_swap As Long
Dim i As Long
Dim j As Long
Dim tmp As Long

' Repeat until we are done.
Do While min < max
' Bubble up.
last_swap = min - 1
' For i = min + 1 To max
i = min + 1
Do While i <= max
' Find a bubble.
If List(i - 1) > List(i) Then
' See where to drop the bubble.
tmp = List(i - 1)
j = i
Do
List(j - 1) = List(j)
j = j + 1
If j > max Then Exit Do
Loop While List(j) < tmp
List(j - 1) = tmp
last_swap = j - 1
i = j + 1
Else
i = i + 1
End If
Loop
' Update max.
max = last_swap - 1

' Bubble down.
last_swap = max + 1
' For i = max - 1 To min Step -1
i = max - 1
Do While i >= min
' Find a bubble.
If List(i + 1) < List(i) Then
' See where to drop the bubble.
tmp = List(i + 1)
j = i
Do
List(j + 1) = List(j)
j = j - 1
If j < min Then Exit Do
Loop While List(j) > tmp
List(j + 1) = tmp
last_swap = j + 1
i = j - 1
Else
i = i - 1
End If
Loop
' Update min.
min = last_swap + 1
Loop
End Sub

'Form command button with labels
Private Sub cmdStart_Click()

Dim iPlay%

'Init Cards
InitCards

'Shuffle
ShuffleCards

'Deal
DealCards

'Play
iPlay = 1
Do Until Winner Or UBound(Deck) = 0
DoEvents
Play (iPlay)
iPlay = iPlay + 1: If iPlay = 3 Then iPlay = 1
Loop

If Winner = 1 Then
lblScore(0) = Val(lblScore(0)) + 1
Else
lblScore(1) = Val(lblScore(1)) + 1
End If
'May wish a score for ties

End Sub

0

LVL 2

Expert Comment

ID: 2767489
The above is in its simplest form.  I am not excluding discarding any dead cards for example if the user picks up two 9's and the discard already has two 9's the player can not win.  I can add this logic for you, but I am not sure how deep you wanted to go with it.  Let me know how it goes.
0

LVL 2

Expert Comment

ID: 2773743
0

LVL 2

Author Comment

ID: 2773909
I get a compile error on this line:

Public Player%(2, 8)

Not allowed as public member of object modules.

Is there a switch I need to set?

Or something I forgot?

Sorry I didn't get back to you before now, was a little busy!

Tax
0

LVL 2

Expert Comment

ID: 2773980
Is the code in a form or code module?  Try changing it to Public(2,8) as integer.  I didn't have any problems with it, but I will look into it.
0

LVL 2

Author Comment

ID: 2774020
form, should it have been a module?

thanks

j
0

LVL 2

Author Comment

ID: 2774036
Argh sorry, it works, I just pasted everything into a form, I got it now, let me look through it and get back to you.

thanks a lot I appreciate it.

j
0

LVL 2

Expert Comment

ID: 2774042
I copied the code from my posting and inserted it into a new project.  I placed all the code in a module with the exception of the cmdStart_Click code at the end.  I commented out the references to the lables and compiled with no problem.  I think if you place your code in a .BAS module, you shouldn't have any problems.  Let me know if you do.
0

LVL 2

Expert Comment

ID: 2774046
Do you need the code or an app.  I can compile it and email it to you as well.
0

LVL 2

Author Comment

ID: 2774624
no I need the code, thanks though.

It doesn't seem to be random to me?

It the same sequence every time. ?

j
0

LVL 2

Expert Comment

ID: 2774726
It's in the shuffle routine.. It was intentional to help debug my pedro game... here is a substitute...

Public Sub ShuffleCards()

Dim iTimes%, iCards%, iRand%, iTemp%

For iTimes = 1 To Int(Rnd * 52) + 1
For iCards = 1 To 52
iRand = Int(Rnd * 52) + 1
iTemp = Deck(iCards)
Deck(iCards) = Deck(iRand)
Deck(iRand) = iTemp
Next iCards
Next iTimes

End Sub

....this shoudl fix you up
0

LVL 2

Author Comment

ID: 2774808
Actually that didn't work either but I inserted a Randomize:

Public Sub ShuffleCards()

Dim iTimes%, iCards%, iRand%, iTemp%
Randomize

For iTimes = 1 To Int(Rnd * 52) + 1
For iCards = 1 To 52
iRand = Int(Rnd * 52) + 1
iTemp = Deck(iCards)
Deck(iCards) = Deck(iRand)
Deck(iRand) = iTemp
Next iCards
Next iTimes

End Sub

Alright, now for a couple of other points.

1. Why does it jump one in a while?  Like player one has 4 points and then 6?  It shouldn't be possible of having a tie, since as soon as the player get's the hand he's the winner?

2. Why does player 1 always win?  I played 10 games and 1 won them all.

J
0

LVL 2

Expert Comment

ID: 2774865
Let me look into that real quick.
0

LVL 2

Expert Comment

ID: 2774923
corrected subs...

Public Sub Play(Turn As Integer)

Dim Checking%(7)
Dim iOne%
Dim iTwo%
Dim iThree%
Dim iFour%
Dim iPossiblePlay%
Dim iDefPlay%

'If iDraw remains zero, player will draw from downward pile
'If iDraw in 1, then player will pickup discard
iDraw = 0

'Check possible runs
For iCards = 1 To 7
Checking(iCards) = Player(Turn, iCards)
Next iCards

'Bubblesort Checking(), 1, 7
SuitSort Checking(), 1, 7
For iCards = 1 To 6
If Checking(iCards) Mod 13 = Checking(iCards + 1) Mod 13 Then
iTwo = 1
iPossiblePlay = 1
If iCards < 5 Then
If Checking(iCards + 1) Mod 13 = Checking(iCards + 2) Mod 13 Then
iThree = 1
iTwo = Checking(iCards + 1) Mod 13
End If
If Checking(iCards + 2) Mod 13 = Checking(iCards + 3) Mod 13 Then
iFour = 1
If iThree > 0 And iCards < 4 Then
iThree = 0
End If
If iCards < 3 Then
iCards = 3
End If
End If
End If
Else

iOne = iCards

End If

Next iCards

If iThree = 1 And iFour = 1 Then
Winner = Turn
End If

If iTwo = (iTop Mod 13) Then
iDraw = 1
End If

If iDraw <> 0 Then
Player(Turn, 8) = iTop
Else
Player(Turn, 8) = Deck(UBound(Deck))
ReDim Preserve Deck(UBound(Deck) - 1)
End If

If (Player(Turn, 8) Mod 13) = iTwo Then
Winner = Turn
End If

If iOne > 0 Then
Checking(iOne) = Player(Turn, 8)
For iCards = 1 To 7
Player(Turn, iCards) = Checking(iCards)
Next iCards
End If

End Sub
0

LVL 2

Expert Comment

ID: 2774931
I needed to put the

ReDim Preserve Deck(UBound(Deck) - 1)

after the player drew the card, this removed it from the deck.
0

LVL 2

Author Comment

ID: 2776839
I'm mailing you what I altered.

When clicking a lot of times, the game gets a subscript out of range on this line:

ReDim Preserve Deck(UBound(Deck) - 1)

j
0

LVL 2

Author Comment

ID: 2776848
And for that I need your email :)

GIve it here, or send it to taxman@coolemail.com

thanks

J
0

LVL 2

Expert Comment

ID: 2777258
Happy to, here is my addy

sbray@cajunnet.com

0

LVL 2

Author Comment

ID: 2777302
In the mail

j
0

LVL 2

Accepted Solution

Sage020999 earned 500 total points
ID: 2777385
I am posting the correction so that anyone viewing your question will see it.

'Make sure you have at least one card left
if ubound(deck) > 1 then
ReDim Preserve Deck(UBound(Deck) - 1)
end if
0

LVL 2

Author Comment

ID: 2777967
Adjusted points from 400 to 500
0

LVL 2

Author Comment

ID: 2777968
This guy is incredible!

Did way more than could be expected from him.

Hence I raised the points to 500.

If anyone want the finished code, please send me an email to taxman@coolemail.com and I'll return it.

Thanks

Tax
0

Expert Comment

ID: 2784420
TAX, I want to see your code. I am going to send you an email now.
0

## Featured Post

When trying to find the cause of a problem in VBA or VB6 it's often valuable to know what procedures were executed prior to the error. You can use the Call Stack for that but it is often inadequate because it may show procedures you aren't interesteâ€¦
Most everyone who has done any programming in VB6 knows that you can do something in code like Debug.Print MyVar and that when the program runs from the IDE, the value of MyVar will be displayed in the Immediate Window. Less well known is Debug.Asseâ€¦
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). Uâ€¦
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This lâ€¦