Programming Tool Box/SIMS_2.iso/vb_code2/tab100/tab.bas

BASIC Source File | 1991-12-03 | 21KB | 795 lines

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 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 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 LoadSuits ()
    Suits(1) = "Spades"
    Suits(2) = "Hearts"
    Suits(3) = "Clubs"
    Suits(4) = "Diamonds"
End Sub

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

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 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 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

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 ClearValidPlays ()
    For i = 1 To 6
        ValidPlay(i) = ""
        TypeOfPlay(i) = 0
    Next i
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 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 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 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 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

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 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 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

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 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

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

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

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 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 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 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