Microsoft Small Basic

Program Listing: VHT007-0

List Program

' Deal 0.6
' Copyright (c) 2012-2014 Nonki Takahashi. All rights reserved.
'
' History :
' 0.6 2014-02-20 Changed to use Stack. (VHT007-0)
' 0.5 2014-02-19 Rewrote only for shuffle and deal. (VHT007)
' 0.4 2014-01-09 Changed for performance. (RMP814-0)
' 0.3 2014-01-06 Rewrote to check full house probability. (RMP814)
' 0.2 2013-04-04 Modified for Challenge of the Month. (CZJ358-0)
' 0.1 2012-08-21 Created. (CZJ358)
'
GraphicsWindow.Title = "Deal 0.6"
Not = "False=True;True=False;"
WQ = Text.GetCharacter(34)
Cards_Init()
Program.Delay(2000)
While "True"
ShuffleCards()
DealCards()
Program.Delay(2000)
RecombineCards()
Program.Delay(2000)
EndWhile
Sub DealCards
col = 1
row = 2
i = 0
While 0 < Stack.GetCount("deck")
index = Stack.PopValue("deck")
i = i + 1
field[i] = index
Cards_Move()
Cards_Open()
col = col + 1
If nNumbers < col Then
col = 1
row = row + 1
EndIf
EndWhile
EndSub
Sub RecombineCards
col = 1
row = 1
For i = 1 To nSuites * nNumbers
index = field[i]
Cards_Close()
Cards_Move()
EndFor
EndSub
Sub ShuffleCards
' Shuffle cards
num1 = num
For n = nSuites * nNumbers To 1 Step -1
i = Math.GetRandomNumber(n)
ix = Array.GetAllIndices(num1)
Stack.PushValue("deck", num1[ix[i]])
num1[ix[i]] = ""
EndFor
EndSub
Sub Cards_Init
' return cards - array for cards properties
' return nSuites - number of suites
' return nNumbers - number of numbers
width = 50
height = 70
cards["width"] = width
cards["height"] = height
cards["xs"] = 4 ' offset for suite in a card
cards["ys"] = 30
cards["xn"] = 4 ' offset for number in a card
cards["yn"] = 5
cards["xp"] = 6 ' offset for pattern in card
cards["yp"] = 0
pattern = "color=DarkBlue;code=2593;"
suites["club"] = "color=Black;code=2663;"
suites["diamond"] = "color=#AA0000;code=2666;"
suites["heart"] = "color=#AA0000;code=2665;"
suites["spade"] = "color=Black;code=2660;"
numbers = "1=A;2=2;3=3;4=4;5=5;6=6;7=7;8=8;9=9;10=10;11=J;12=Q;13=K;"
nSuites = Array.GetItemCount(suites)
nNumbers = Array.GetItemCount(numbers)
iSuites = Array.GetAllIndices(suites)
GraphicsWindow.BackgroundColor = "#004400"
GraphicsWindow.PenWidth = 0
GraphicsWindow.FontName = "Courier New"
GraphicsWindow.Width = (width + 10) * nNumbers + 10
GraphicsWindow.Height = (height + 10) * (nSuites + 1) + 10
col = 1
row = 1
x0 = 10
y0 = 10
sHex = pattern["code"]
Math_Hex2Dec()
pChar = Text.GetCharacter(iDec)
For s = 1 To nSuites
suite = iSuites[s]
sHex = suites[suite]["code"]
Math_Hex2Dec()
sChar = Text.GetCharacter(iDec)
For n = 1 To nNumbers
index = index + 1
num[index] = index
GraphicsWindow.BrushColor = "White"
cards[index]["oCard"] = Shapes.AddRectangle(width, height)
GraphicsWindow.BrushColor = suites[suite]["color"]
GraphicsWindow.FontSize = 28
cards[index]["oSuite"] = Shapes.AddText(sChar)
cards[index]["oNumber"] = Shapes.AddText(numbers[n])
GraphicsWindow.BrushColor = "White"
cards[index]["oCard2"] = Shapes.AddRectangle(width, height)
GraphicsWindow.BrushColor = pattern["color"]
GraphicsWindow.FontSize = 60
cards[index]["oPattern"] = Shapes.AddText(pChar)
Cards_Move()
EndFor
EndFor
EndSub
Sub Cards_Close
' param index
Shapes.ShowShape(cards[index]["oCard2"])
Shapes.ShowShape(cards[index]["oPattern"])
EndSub
Sub Cards_Open
' param index
Shapes.HideShape(cards[index]["oPattern"])
Shapes.HideShape(cards[index]["oCard2"])
EndSub
Sub Cards_Move
' param index - index of a card
' param col, row - position to move
cards[index]["col"] = col
cards[index]["row"] = row
x = x0 + (col - 1) * (width + 10)
y = y0 + (row - 1) * (height + 10)
Shapes.Animate(cards[index]["oCard"], x, y, 300)
Shapes.Animate(cards[index]["oSuite"], x + cards["xs"], y + cards["ys"], 300)
Shapes.Animate(cards[index]["oNumber"], x + cards["xn"], y + cards["yn"], 300)
Shapes.Animate(cards[index]["oCard2"], x, y, 300)
Shapes.Animate(cards[index]["oPattern"], x + cards["xp"], y + cards["yp"], 300)
EndSub
Sub Math_Hex2Dec
' Math | Convert hexadecimal to decimal
' param sHex
' return iDec
iDec = 0
iLen = Text.GetLength(sHex)
For iPtr = 1 To iLen
iDec = iDec * 16 + Text.GetIndexOf("0123456789ABCDEF", Text.GetSubText(sHex, iPtr, 1)) - 1
EndFor
EndSub