Programmer 7500/MAX_PROGRAMMERS.iso/VISUAL_B/CODIGO_1/ACCRDI/CARDDECK.BAS

BASIC Source File | 1991-09-26 | 5.2 KB | 194 lines

DefInt A-Z

Declare Function CardVersion Lib "VBCards.Dll" () As Integer

Declare Sub GetCard Lib "VBCards.dll" (ByVal Card As Integer)
Declare Function SameSuit Lib "VBCards.Dll" (ByVal c1 As Integer, ByVal c2 As Integer) As Integer
Declare Function SuitOf Lib "VBCards.DLL" (ByVal C As Integer) As Integer
Declare Function CardValue Lib "vbCards.dll" (ByVal C As Integer)
Declare Function SameCardValue Lib "VBCards.Dll" (ByVal c1 As Integer, ByVal c2 As Integer) As Integer

Declare Function GetProfileInt Lib "Kernel" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal nDefault As Integer) As Integer
Declare Function GetProfileString Lib "Kernel" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer) As Integer
Declare Function WriteProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String) As Integer

' This routine deletes the card that has just been moved and
' moves the cards following it up one.  Then it deletes the
' last card.  The TABLE array is maintained
Sub Compact (ByVal Source As Integer)
  Piles = Piles - 1
  For i = Source + 1 To Piles
     Form1.Picture1(i - 1).Picture = Form1.Picture1(i).Picture
     Table(i) = Table(i + 1)
  Next i
  Unload Form1.Picture1(Piles)
End Sub

' This returns the actual card position
Function CurrentRow (Pile%) As Integer
  CardHeight = Form1.Picture1(0).Height
  If Compressed Then
    CardHeight = Int(CardHeight / 2)
  End If
  NumRows = CurrentLevel(Pile%) - 1

  ' Now calcuate the correct row position
  J = NumRows * CardHeight
  J = J + (NumRows * CardSpace)
  CurrentRow = J + Form1.Picture1(0).Top
End Function

' Calcuate the position of this the next card delt
Function CurrentCol (Pile As Integer) As Integer
  CardWidth = Form1.Picture1(0).Width

  ' First calculate the indention
  Level = CurrentLevel(Pile) - 1
  J = Form1.Picture1(0).Left + (Level * CardWidth)
  J = J + (Level * CardSpace)

  ' Now calculate the exact card position
  Level = Pile - (4 * Level) - 1
  J = J + (Level * CardSpace) + (Level * CardWidth)
  CurrentCol = J
End Function

' This returns the logical row of the Card% specified
Function CurrentLevel (Pile%) As Integer
  NumRows = Int(Pile% / 4)
  If (NumRows * 4) < Pile% Then
    NumRows = NumRows + 1
  End If
  CurrentLevel = NumRows
End Function

Sub ShowError (Msg$)
  If DisplayError Then
    Beep
    MsgBox Msg$, 0, "Sorry!"
  End If
End Sub

Sub ShuffleCards ()

   For i = 1 To 52
      cards(i) = i
   Next i

   For J = 1 To 10
     For i = 1 To 52
        K = Int(52 * Rnd + 1)
        Temp = cards(i)
        cards(i) = cards(K)
        cards(K) = Temp
     Next i
   Next J

End Sub

Function MorePlays () As Integer
  ' Only check for more plays if we have no cards left to
  ' deal.
  MorePlays = -1
  If NextCard = 53 Then
    If Piles > 1 Then 'we haven't won yet
      MorePlays = 0
      For i = 2 To Piles
        If ValidMove(i - 1, i - 2) Then 'still more moves
          MorePlays = -1
        Else
           If i > 3 Then
             If ValidMove(i - 1, i - 4) Then 'still more moves
               MorePlays = -1
             End If
           End If
        End If
      Next
    End If
  End If
End Function

Sub Main ()
   Randomize

   ' Get the various WIN.INI options
   DisplayError = GetProfileInt(AppName$, "Errors", 0) - 1
   GamesWon = GetProfileInt(AppName$, "Won", 0)
   GamesLost = GetProfileInt(AppName$, "Lost", 0)
   Compressed = GetProfileInt(AppName$, "Compressed", 1) - 1

   Form1.Show
   Form1.WindowState = GetProfileInt(AppName$, "WinState", 0)

   Do While -1
     Do While DoEvents() And MorePlays()
     Loop

     If NextCard = 53 Then
        If Piles = 1 Then
           WonForm.Show 1
           GamesWon = GamesWon + 1
        Else
           Lost.Show 1
           GamesLost = GamesLost + 1
        End If

        ' Start New Game!
        NewGame

     Else
        Exit Do
     End If

   Loop

   UpdateIni
   End
End Sub

Sub UpdateIni ()
   ' Write our WIN.INI values
   X = WriteProfileString(AppName$, "Errors", Str$(DisplayError + 1))
   X = WriteProfileString(AppName$, "WinState", Str$(Form1.WindowState))
   X = WriteProfileString(AppName$, "Won", Str$(GamesWon))
   X = WriteProfileString(AppName$, "Lost", Str$(GamesLost))
   X = WriteProfileString(AppName$, "Compressed", Str$(Compressed + 1))
End Sub

Sub NewGame ()
   Undone = -1
   Form1.Command1.Enabled = -1

   'Clear out old cards first
   For i = 1 To Piles - 1
      Unload Form1.Picture1(i)
   Next

   Piles = 1

   ShuffleCards

   GetCard (cards(1))
   Table(1) = cards(1)
   Form1.Picture1(0).Picture = ClipBoard.GetData(2)

   NextCard = 2

End Sub

Function ValidMove (ByVal c1, ByVal c2 As Integer) As Integer
    c1 = Table(c1 + 1)
    c2 = Table(c2 + 1)
    ValidMove = SameSuit(c1, c2) Or SameCardValue(c1, c2)
End Function

Sub UndoSave ()
   Undone = 0
   UndoPiles = Piles
   UndoNextCard = NextCard
   For i = 1 To Piles
      Undoer(i) = Table(i)
   Next
End Sub