Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/tab100/tab.bas

BASIC Source File | 1995-09-06 | 20.2 KB | 795 lines

Sub TestForJack (Pv As Integer, Vp As String, Flag As Integer)
        If Pv = 12 Then
           Vp = "Y"
        End If
End Sub

Sub TestEqualRank (Pv As Integer, Vp As String, RCds As Integer)
    Dim i As Integer

    For i = 1 To TableNo
        If Pv = TableArray(i) Then
            Vp = "Y"
            NewTableArray(i) = 0
            RCds = RCds - 1
        End If
    Next i

End Sub

Sub TestEqualValue (Pv As Integer, Vp As String, RCds As Integer)

    Dim MatchFound As Integer
    Dim j As Integer
    Dim k As Integer

    For j = 1 To TableNo - 1
        For k = j + 1 To TableNo
            If Pv = TableArray(j) + TableArray(k) Then
                Vp = "Y"
                NewTableArray(j) = 0
                NewTableArray(k) = 0
                RCds = RCds - 2
                Exit Sub
            End If
            TestAsAces TableArray(j), TableArray(k), Pv, RCds, Vp, MatchFound
            If MatchFound = TRUE Then
                NewTableArray(j) = 0
                NewTableArray(k) = 0
                RCds = RCds - 2
                Exit Sub
            End If
        Next k
    Next j

End Sub

Sub TestForTypeOfPlay (Pv As Integer, Vp As String, Pos As Integer, RCds As Integer, TyOP As Integer)

    Dim i As Integer
    Dim SumRCds As Integer

    SumRCds = 0

    If Pv = 12 Then
        TyOP = JACK
        Exit Sub
    End If

    If RCds = 0 Then
        TyOP = TABLENETTE
        Exit Sub
    End If

    For i = 1 To TableNo
        SumRCds = SumRCds + NewTableArray(i)
    Next i

    If SumRCds = 12 Then
        TyOP = TOTAL_12
        Exit Sub
    End If

    If RCds = 1 Then
        If SumRCds > 11 Then
            SumRCds = SumRCds - 1
        End If
        If SumRCds = 11 Then
            SumRCds = 1
        End If
        Select Case EqualRankGone(SumRCds)
            Case 3
                TyOP = ONECARD_NOEQUAL
            Case 2
                TyOP = ONECARD_ONEEQUAL
            Case 1, 0
                Vp = ""
                TyOP = REJECTED_MOVE
        End Select
        Exit Sub
    End If


    If RCds >= 3 Then
        TyOP = THREECARDS_PLUS
    Else
        TyOP = TWOCARDS
    End If

End Sub

Sub AddToCardsTotal (Count As Integer)
    If GameSwitch = PLAYER_MOVE Then
        PlayerCardsNo = PlayerCardsNo + Count
    Else
        ComputerCardsNo = ComputerCardsNo + Count
    End If
End Sub

Sub AddToEqualRank (C1 As Integer)
    EqualRankGone(C1) = EqualRankGone(C1) + 1
End Sub

Sub AddToScore (C1 As Integer)

    Dim Score As Integer
    If GameSwitch = PLAYERMOVE Then
        Score = PSCore
        PickUpSwitch = PLAYER
    Else
        Score = CSCore
        PickUpSwitch = COMPUTER
    End If

    Select Case C1
        Case 1, 14, 27, 40          'Aces count 1
            Score = Score + 1
        Case 13, 26, 39, 52         'Kings count 1
            Score = Score + 1
        Case 12, 25, 38, 51         'Queens count 1
            Score = Score + 1
        Case 11, 24, 37, 50         'Jacks count 1
            Score = Score + 1
        Case 10, 23, 36             '10s except Diamonds score 1
            Score = Score + 1
        Case 49                     '10 Diamonds scores 2
            Score = Score + 2
        Case 28                     '2 Clubs scores 1
            Score = Score + 1
    End Select

    If GameSwitch = PLAYER_MOVE Then
        PSCore = Score
        If Val(Form1.PlayerScore.Caption) <> PSCore Then
            Form1.PlayerScore.Caption = Str$(PSCore)
        End If
    Else
        CSCore = Score
        If Val(Form1.ComputerScore.Caption) <> CSCore Then
            Form1.ComputerScore.Caption = Str$(CSCore)
        End If
    End If

End Sub

Sub AskForNewGame ()

    Dim MsgBoxResponse As Integer

    MsgBoxResponse = MsgBox("Do You Wish to Play Again", MBB_YNCAN + MBI_INFO)
    If MsgBoxResponse = MB_YES Then
        NewGame
        FirstDeal
    Else
        End
    End If
End Sub

Function BestComputerDiscard ()

    Dim i As Integer


    If TableNo = 0 Then
        DiscardOnZero
    Else
        If TableNo > 0 Then
            DiscardOnOne
        End If
    End If

    For i = 1 To 10
        For j = 1 To ComputerNo
                If TypeOfDiscard(j) = i Then
                    BestComputerDiscard = j
                    Exit Function
                End If
        Next j
    Next i


End Function

Function BestComputerMove ()
    Dim i As Integer
    Dim j As Integer

    Flag = False

    For i = 1 To 7
        For j = 1 To ComputerNo
            If ValidPlay(j) = "Y" Then
                If TypeOfPlay(j) = i Then
                    BestComputerMove = j
                    Flag = True
                    Exit Function
                End If
            End If
        Next j
    Next i

End Function

Sub CheckFor27Cards ()
    If PlayerCardsNo > 27 Then
        PSCore = PSCore + 3
        Form1.PlayerScore.Caption = Str$(PSCore)
    End If
    If ComputerCardsNo > 27 Then
        CSCore = CSCore + 3
        Form1.ComputerScore.Caption = Str$(CSCore)
    End If
End Sub

Function CheckForWin ()

    Flag = False

    If Val(Form1.PlayerScore.Caption) > 251 Then
        If Val(Form1.PlayerScore.Caption) > Val(Form1.ComputerScore.Caption) Then
            MsgBox ("Well done you've Won")
            CheckForWin = True
        Else
            MsgBox ("Computer Wins This Game")
            Flag = True
        End If
    Else
        If Val(Form1.ComputerScore.Caption) > 251 Then
            MsgBox ("Computer Wins This Game")
            CheckForWin = True
        End If
    End If

End Function

Sub CheckTableCards (A() As String, V As Integer, Pos As Integer, VNo As Integer)


    Dim TableVal As Integer
    Dim FirstCardVal As Integer
    Dim j As Integer


    TableVal = CardValue(Cards(Val(Form1.Picture1(Pos).Tag)))
    SetNewValue TableVal
    FirstCardVal = TableVal



    For j = Pos + 1 To TableNo
        TableVal = CardValue(Cards(Val(Form1.Picture1(j).Tag)))
        SetNewValue TableVal
        If V = FirstCardVal + TableVal Then
            A(VNo + 1) = Str$(Pos) + "," + Str$(j)
            VNo = VNo + 1
        Else
            CheckAcesAsOne FirstCardVal, TableVal, V, A(), Pos, j, VNo
        End If
    Next j

End Sub

Sub ClearValidPlays ()
    For i = 1 To 6
        ValidPlay(i) = ""
        TypeOfPlay(i) = 0
    Next i
End Sub

Sub DiscardOnOne ()

    Dim CompCard As Integer
    Dim TableCard As Integer
    Dim TwoCardVal  As Integer

    TableCard = CardValue(Cards(Val(Form1.Picture1(1).Tag)))
    SetNewValue TableCard


    For i = 1 To ComputerNo
        CompCard = CardValue(Cards(Val(Form1.Picture4(i).Tag)))
        SetNewValue CompCard

        If CompCard = TableCard Then
            TypeOfDiscard(i) = 10
        Else
            If CompCard + TableTotal = 12 Then
                If CompCard <> TableCard Then
                    TypeOfDiscard(i) = 1
                End If
            Else
                If CompCard + TableTotal > 14 Then
                    If CompCard <> TableCard Then
                        TypeOfDiscard(i) = 2
                    End If
                Else
                    Select Case EqualRankGone(CardValue(Cards(Val(Form1.Picture4(i).Tag))))
                        Case 3
                            TypeOfDiscard(i) = 3
                        Case 2
                            If CardValue(Cards(Val(Form1.Picture4(i).Tag))) < 7 Then
                                TypeOfDiscard(i) = 4
                            Else
                                TypeOfDiscard(i) = 5
                            End If
                        Case 1
                            If CardValue(Cards(Val(Form1.Picture4(i).Tag))) < 7 Then
                                TypeOfDiscard(i) = 6
                            Else
                                TypeOfDiscard(i) = 7
                            End If
                        Case 0
                            If CardValue(Cards(Val(Form1.Picture4(i).Tag))) < 7 Then
                                TypeOfDiscard(i) = 8
                            Else
                                TypeOfDiscard(i) = 9
                            End If
                    End Select
                End If
            End If
        End If


        Next i
End Sub

Sub DiscardOnZero ()
    Dim i As Integer

    For i = 1 To ComputerNo
        Select Case EqualRankGone(CardValue(Cards(Val(Form1.Picture4(i).Tag))))
            Case 3
                TypeOfDiscard(i) = 1
            Case 2
                If CardValue(Cards(Val(Form1.Picture4(i).Tag))) < 7 Then
                    TypeOfDiscard(i) = 2
                Else
                    TypeOfDiscard(i) = 3
                End If
            Case 1
                If CardValue(Cards(Val(Form1.Picture4(i).Tag))) < 7 Then
                    TypeOfDiscard(i) = 4
                Else
                    TypeOfDiscard(i) = 5
                End If
            Case 0
                If CardValue(Cards(Val(Form1.Picture4(i).Tag))) < 7 Then
                    TypeOfDiscard(i) = 6
                Else
                    TypeOfDiscard(i) = 7
                End If
        End Select
    Next i
End Sub

Sub EnableComputerMove ()
    Form1.ComputerMove.Enabled = True
    For i = 1 To 6
        Form1.Picture2(i).Enabled = False
    Next i
    MakeComputerMove
End Sub

Sub EnablePlayerMove ()
    Form1.ComputerMove.Enabled = False
    For i = 1 To 6
        Form1.Picture2(i).Enabled = True
    Next i
End Sub

Sub JackPlayed ()
    For i = TableNo To 1 Step -1
        AddToScore CardValue(Cards(Val(Form1.Picture1(i).Tag)))
        AddToEqualRank CardValue(Cards(Val(Form1.Picture1(i).Tag)))
        ShiftLeftTable (i)
        AddToCardsTotal (TableNo + 1)
    Next i

End Sub

Sub LastPickup ()
    If PickUpSwitch = PLAYER Then
        GameSwitch = PLAYER_MOVE
    Else
        GameSwitch = COMPUTER_MOVE
    End If

    For i = TableNo To 1 Step -1
        AddToScore CardValue(Cards(Val(Form1.Picture1(i).Tag)))
        ShiftLeftTable (i)
        AddToCardsTotal (TableNo)
    Next i
End Sub

Sub LoadSuits ()
    Suits(1) = "Spades"
    Suits(2) = "Hearts"
    Suits(3) = "Clubs"
    Suits(4) = "Diamonds"
End Sub

Sub LoadTableArray ()

    For i = 1 To TableNo
        TableArray(i) = CardValue(Cards(Val(Form1.Picture1(i).Tag)))
        SetNewValue TableArray(i)
        NewTableArray(i) = TableArray(i)
    Next i
End Sub

Sub MakeComputerMove ()
    Dim X As Single
    Dim Y As Single
    Dim GoodMove As Integer
    Dim ValidCard As Integer
    Dim BestCard As Integer
    Dim CurrTime As Double
    Dim StartTime As Double
    ClearValidPlays
    TestPlays
    ValidCard = BestComputerMove()

    If ValidCard <> 0 Then
        Form1.Picture5(1).Visible = True
        Form1.Picture5(1).Picture = Form1.Picture4(ValidCard).Picture
        Beep
        CurrTime = TimeValue(Time$)
        StartTime = CurrTime + .0000075
        Do While StartTime > CurrTime
            CurrTime = TimeValue(Time$)
        Loop

        MakeMove 1, Form1.Picture4(ValidCard), X, Y
        Form1.Picture5(1).Visible = False
    Else
        BestCard = BestComputerDiscard()
        Form1.Picture5(1).Visible = True
        Form1.Picture5(1).Picture = Form1.Picture4(BestCard).Picture
        Beep
        CurrTime = TimeValue(Time$)
        StartTime = CurrTime + .0000075
        Do While StartTime > CurrTime
            CurrTime = TimeValue(Time$)
        Loop

        MakeMove TableNo + 1, Form1.Picture4(BestCard), X, Y

        Form1.Picture5(1).Visible = False
    End If




End Sub

Sub MakeMove (Index As Integer, Source As Control, X As Single, Y As Single)
    Dim HoldNo  As Integer

'   1. Players covers any card
'           If Jack all cards removed but
'               no Tablenette Scored
'       check if any 2 or 3 cards = its Value
'       check if Equal Rank cards exists
'       check if all Table cards taken "Tablenette score"
'
'   OR
'
'   2. Player drops card on table (the card back at end)
'       Game adds card to table

    HoldNo = TableNo

    CalculateTableTotal

    If CardValue(Cards(Val(Source.Tag))) = 11 Then
        JackPlayed
        AddToScore CardValue(Cards(Val(Source.Tag)))
        AddToEqualRank CardValue(Cards(Val(Source.Tag)))
        ShiftLeftWho (Source.Index)
        Exit Sub
    End If


    If Index <= TableNo Then

        CheckEqualRank Val(Source.Tag)
        CheckEqualValue Val(Source.Tag)

        If TableNo = HoldNo Then
            MsgBox ("No Valid Match with This Card")
            Exit Sub
        Else
            AddToScore CardValue(Cards(Val(Source.Tag)))
            AddToEqualRank CardValue(Cards(Val(Source.Tag)))
            If TableNo = 0 Then
                ScoreTablenette Val(Source.Tag)
            End If
            ShiftLeftWho (Source.Index)
        End If

    Else
        Form1.Picture1(Index + 1).Picture = Form1.Picture1(Index).Picture
        Form1.Picture1(Index).Picture = Source.Picture
        Form1.Picture1(Index).Tag = Source.Tag
        Form1.Picture1(Index + 1).Enabled = True
        Form1.Picture1(Index + 1).Visible = True
        Form1.Picture1(Index + 1).Tag = "End"
        TableNo = Index
        ShiftLeftWho (Source.Index)
    End If


End Sub

Sub NewGame ()

    CardNo = 1
    For i = 6 To 12
        Form1.Picture1(i).Visible = False
        Form1.Picture1(i).Enabled = False
    Next i
    CSCore = 0
    PSCore = 0
    Form1.ComputerScore.Caption = Str$(CSCore)
    Form1.PlayerScore.Caption = Str$(PSCore)
    DealSwitch = COMPUTER_DEAL
End Sub

Sub ScoreTablenette (C1 As Integer)

    Dim PlayVal As Integer
    Dim ComputerVal As Integer

    If GameSwitch = PLAYER_MOVE Then
        PlayVal = CardValue(Cards(C1))
        SetNewValue PlayVal
        PSCore = PSCore + TableTotal + PlayVal
        Form1.PlayerScore.Caption = Str$(PSCore)
    Else
        ComputerVal = CardValue(Cards(C1))
        SetNewValue ComputerVal
        CSCore = CSCore + TableTotal + ComputerVal
        Form1.ComputerScore.Caption = Str$(CSCore)
    End If

End Sub

Sub SetNewValue (Value As Integer)
'   Tablenette has the following Values:-
'   Ace 1 or 11, Jack 12, Queen 14, King 14
'   all other cards are face value.

    Select Case Value
        Case 13
            Value = 14
        Case 12
            Value = 13
        Case 11
            Value = 12
        Case 1
            Value = 11
    End Select

End Sub

Sub ShiftLeft (A() As Integer, First As Integer, Last As Integer)

'   Shift the specified region of the array 1 to the left.
'
    ' A() is the array
    ' First is the DiaryIndex of the first element to be shifted.
    ' Last is the DiaryIndex of the last element to be shifted.

    Dim i As Integer

    If First < 2 Then First = 2

    For i = First To Last
        A(i - 1) = A(i)
    Next

End Sub

Sub ShiftLeftComputer (Pos As Integer)
    Dim Win As Integer

    If ComputerNo = 1 Then
        Form1.Picture4(1).Visible = False
        Form1.Picture4(1).Enabled = False
        ComputerNo = 0
        Exit Sub
    End If

    For i = Pos To (ComputerNo - 1)
        Form1.Picture4(i).Picture = Form1.Picture4(i + 1).Picture
        Form1.Picture4(i).Tag = Form1.Picture4(i + 1).Tag
    Next i
    ComputerNo = ComputerNo - 1
    For i = ComputerNo + 1 To 6
        Form1.Picture4(i).Visible = False
        Form1.Picture4(i).Enabled = False
    Next i

End Sub

Sub ShiftLeftPlayer (Pos As Integer)

    Dim Win As Integer

    If PlayerNo = 1 Then
        Form1.Picture2(1).Visible = False
        Form1.Picture2(1).Enabled = False
        PlayerNo = 0
        Exit Sub
    End If

    For i = Pos To (PlayerNo - 1)
        Form1.Picture2(i).Picture = Form1.Picture2(i + 1).Picture
        Form1.Picture2(i).Tag = Form1.Picture2(i + 1).Tag
    Next i
    PlayerNo = PlayerNo - 1
    For i = PlayerNo + 1 To 6
        Form1.Picture2(i).Visible = False
        Form1.Picture2(i).Enabled = False
    Next i

End Sub

Sub ShiftLeftTable (Pos As Integer)
    If TableNo = 1 Then
        Form1.Picture1(1).Picture = Form1.Picture1(2).Picture
        Form1.Picture1(1).Tag = "End"
        Form1.Picture1(2).Visible = False
        Form1.Picture1(2).Enabled = False
        TableNo = 0
        Exit Sub
    End If

    For i = Pos To TableNo
        Form1.Picture1(i).Picture = Form1.Picture1(i + 1).Picture
        Form1.Picture1(i).Tag = Form1.Picture1(i + 1).Tag
    Next i

    Form1.Picture1(TableNo + 1).Visible = False
    Form1.Picture1(TableNo + 1).Enabled = False


    TableNo = TableNo - 1





End Sub

Sub ShiftLeftWho (Pos As Integer)

    Dim Win As Integer

    If GameSwitch = PLAYER_MOVE Then
        ShiftLeftPlayer Pos
    Else
        ShiftLeftComputer Pos
    End If

    If DealSwitch = PLAYER_DEAL Then
        If PlayerNo = 0 Then
            If CardNo > 52 Then
                LastPickup
                CheckFor27Cards
                Win = CheckForWin()
                If Win = True Then
                    AskForNewGame
                    Exit Sub
                End If
                DealSwitch = COMPUTER_DEAL
                FirstDeal
            Else
                PlayerDeal
                GameSwitch = COMPUTER_MOVE
                EnableComputerMove

            End If
        Else
            If GameSwitch = PLAYER_MOVE Then
                GameSwitch = COMPUTER_MOVE
                EnableComputerMove
            Else
                GameSwitch = PLAYER_MOVE
                EnablePlayerMove
            End If
        End If
    Else
        If ComputerNo = 0 Then
            If CardNo > 52 Then
                LastPickup
                CheckFor27Cards
                Win = CheckForWin()
                If Win = True Then
                    AskForNewGame
                    Exit Sub
                End If
                DealSwitch = PLAYER_DEAL
                FirstDeal
            Else
                ComputerDeal
                GameSwitch = PLAYER_MOVE
                EnablePlayerMove

            End If
        Else
            If GameSwitch = PLAYER_MOVE Then
                GameSwitch = COMPUTER_MOVE
                EnableComputerMove
            Else
                GameSwitch = PLAYER_MOVE
                EnablePlayerMove
            End If
        End If
    End If
End Sub

Sub TestAsAces (T1 As Integer, T2 As Integer, P1 As Integer, RCds As Integer, Vp As String, Flag As Integer)
    If T2 = 11 Then
        If P1 = T1 + 1 Then
            Vp = "Y"
            Flag = True
            Exit Sub
        End If
    Else
        If T1 = 11 Then
            If P1 = 1 + T2 Then
                Vp = "Y"
                Flag = True
                Exit Sub
            End If
        Else
            If T1 = 11 Then
                If T2 = 11 Then
                    If P1 = 2 Then
                        Vp = "Y"
                        Flag = True
                    End If
                End If
            End If
        End If
    End If


End Sub

Sub TestPlays ()
    Dim i As Integer

    Dim PlayVal As Integer
    Dim RemainingCards As Integer
    Dim MatchFound As Integer
    Dim JackFound As Integer



    For i = 1 To ComputerNo

        RemainingCards = TableNo
        LoadTableArray

        PlayVal = CardValue(Cards(Val(Form1.Picture4(i).Tag)))
        SetNewValue PlayVal

        TestForJack PlayVal, ValidPlay(i), JackFound

        If JackFound = False Then
            TestEqualRank PlayVal, ValidPlay(i), RemainingCards
            TestEqualValue PlayVal, ValidPlay(i), RemainingCards
        End If

        If ValidPlay(i) = "Y" Then
            TestForTypeOfPlay PlayVal, ValidPlay(i), i, RemainingCards, TypeOfPlay(i)
        End If

    Next i

End Sub