Programmer 7500/MAX_PROGRAMMERS.iso/VISUAL_B/CODIGO_1/CARDGAME/PFIELDS.BAS

BASIC Source File | 1992-05-12 | 19.5 KB | 686 lines

' Crispy1 (Kings on top, Queens on the side, and Jacks in the corners)
' A diversion by Chris Pando
' IF IT IS SQUINKY, THEN YOU KNOW IT IS BrilligWare!
'
' I dedicate this program to the public domain.
'
DefInt A-Z

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

Declare Sub GetCard Lib "VBCards.dll" (ByVal Card As Integer)
Declare Sub GetCardBack Lib "VBCards.dll" (ByVal C As Integer)
Declare Sub GetCardMisc 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 GetPrivateProfileInt Lib "Kernel" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal nDefault As Integer, ByVal lpFileName As String) As Integer
Declare Function WritePrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String, ByVal lpFileName As String) As Integer



Const TRUE = -1
Const FALSE = 0
Const PIXEL = 3
Const ROYALMOD = 13
Const KING = 0
Const QUEEN = 12
Const JACK = 11

Const KING1 = 1   ' valid squares for face cards
Const KING2 = 2
Const KING3 = 13
Const KING4 = 14
Const QUEEN1 = 4
Const QUEEN2 = 7
Const QUEEN3 = 8
Const QUEEN4 = 11
Const JACK1 = 0
Const JACK2 = 3
Const JACK3 = 12
Const JACK4 = 15

Const CENTER1 = 5   'symbolic values for the center squares
Const CENTER2 = 6
Const CENTER3 = 9
Const CENTER4 = 10

Const CLOSEDFIELD = 1   ' here are the various states
Const OPENFIELD = 2
Const APENDING = 3
Const CPENDING = 4

Dim Deck(1 To 52) As Integer    'Deck contains the deal
Dim Field(15) As Integer        'Field contains the playing field

            ' State Variables

Dim FromCard As Integer         'Contains Card to Match
Dim NumberOpen As Integer       'open places on field
Dim NextCard As Integer         'Pointer to Deck
Dim State As Integer            'Current State
Dim BackDesign As Integer       'Card Back

Sub ShuffleDeck ()
   For i = 1 To 10
      For J = 1 To 52
         K = Int(1 + (52 * Rnd))
         Temp = Deck(J)
         Deck(J) = Deck(K)
         Deck(K) = Temp
      Next
   Next
End Sub

Sub DealDeck ()

   NextCard = 1
   For i = 0 To 15
      Field(i) = Deck(NextCard)
      NextCard = NextCard + 1
      GetCard (Field(i))
      Pfield.Picture1(i).Picture = ClipBoard.GetData(2)
   Next

   GetCardBack (BackDesign)
   Pfield.NewCards.Picture = ClipBoard.GetData(2)

   GetCardMisc (1)
   Pfield.OldCards.Picture = ClipBoard.GetData(2)

   CtlEnable 2
   NumberOpen = 0
   State = CLOSEDFIELD

End Sub

Sub AppExit ()
   WriteProfile
   End
End Sub

Function RoyalCard (Index As Integer) As Integer
   i = Field(Index) Mod ROYALMOD
   If (i = KING Or i = QUEEN Or i = JACK) Then
      RoyalCard = TRUE
   Else
      RoyalCard = FALSE
   End If
End Function

Sub ReverseImage (Source As Control)
' assumes drawmode and fillcolor,fillstyle have all been set
   Source.Line (0, 0)-(Source.ScaleWidth, Source.ScaleHeight), , B
End Sub

Sub OpenOrClosed ()
'
' if any places are open, the we want OPENFIELD & ENABLED
'
   i = -1
   State = CLOSEDFIELD
   CtlEnable 2              'click2 off, menus on

   Do
      i = i + 1
      If Field(i) = -1 Then
         State = OPENFIELD
         CtlEnable 3        'everything enabled
      End If
  Loop Until (i = 15 Or Field(i) = -1)

End Sub

Sub Remove (Card1 As Integer, Card2 As Integer)
 '
 ' remove the matching cards, and update state varaible NumberOpen
 '
    Pfield.OldCards.Picture = Pfield.Picture1(Card1).Picture
    GetCardMisc (1)
    Pfield.Picture1(Card1).Picture = ClipBoard.GetData(2)
    Pfield.Picture1(Card2).Picture = ClipBoard.GetData(2)
    Field(Card1) = -1
    Field(Card2) = -1
    NumberOpen = NumberOpen + 2
End Sub

Function ValidEmpty (Index As Integer) As Integer
' determine if a valid TO location for a face card
   ValidEmpty = FALSE
   If (Field(Index) = -1) Then

      i = Field(FromCard) Mod ROYALMOD
      Select Case i
         Case KING
            If (Index = KING1 Or Index = KING2 Or Index = KING3 Or Index = KING4) Then
               ValidEmpty = TRUE
            End If
         Case QUEEN
            If (Index = QUEEN1 Or Index = QUEEN2 Or Index = QUEEN3 Or Index = QUEEN4) Then
               ValidEmpty = TRUE
            End If
         Case JACK
            If (Index = JACK1 Or Index = JACK2 Or Index = JACK3 Or Index = JACK4) Then
               ValidEmpty = TRUE
            End If
      End Select

   End If
End Function

Sub Swap (Card1 As Integer, Card2 As Integer)
    Pfield.Picture1(Card2).Picture = Pfield.Picture1(Card1).Picture
    GetCardMisc (1)
    Pfield.Picture1(Card1).Picture = ClipBoard.GetData(2)
    Field(Card2) = Field(Card1)
    Field(Card1) = -1
End Sub

Sub LoadCardBack ()
   Load CardBack

   CardBack.WindowState = 0
   CardBack.AutoRedraw = TRUE
   CardBack.BackColor = RGB(192, 192, 192)
   CardBack.ScaleMode = PIXEL

   For i = 0 To 6

   'resize a little bit
      CardBack.CardBackPic(i).Width = 71
      CardBack.CardBackPic(i).Height = 96

   'now assign card back
      J = i + 1
      GetCardBack (J)
      CardBack.CardBackPic(i).Picture = ClipBoard.GetData(2)

   'now raise card - 4 thick, raised
      RaiseControl CardBack, CardBack.CardBackPic(i), 3, 1

   'now set the properties for reverse imaging
      CardBack.CardBackPic(i).FillStyle = 0                   'solid
      CardBack.CardBackPic(i).FillColor = RGB(192, 0, 0)
      CardBack.CardBackPic(i).DrawMode = 10                   'NOT XOR
      CardBack.CardBackPic(i).AutoRedraw = TRUE
   Next i

   ReverseImage CardBack.CardBackPic(BackDesign - 1)
   CardBack.Top = 690
   CardBack.Left = 480
   CardBack.Height = 6135
   CardBack.Width = 5055


' go ahead and center the command button
   CenterCtlBottom CardBack, CardBack.CardBackOK, 15

' go ahead and frame the form
   FrameForm CardBack

' now lets print something
   CardBack.FontName = "Helv"
   CardBack.FontSize = 24

   CardBack.ForeColor = RGB(128, 128, 128)
   CardBack.CurrentX = 40
   CardBack.CurrentY = 20
   CardBack.Print "Pick A Card Back"

   CardBack.ForeColor = RGB(128, 128, 128)
   CardBack.CurrentX = 41
   CardBack.CurrentY = 19
   CardBack.Print "Pick A Card Back"

   CardBack.ForeColor = RGB(255, 255, 255)
   CardBack.CurrentX = 42
   CardBack.CurrentY = 18
   CardBack.Print "Pick A Card Back"

   CardBack.Show 1
End Sub

Sub ChangeCardBack (Index As Integer)
    ReverseImage CardBack.CardBackPic(BackDesign - 1)
    ReverseImage CardBack.CardBackPic(Index)
    BackDesign = Index + 1
    If (NextCard <> 53) Then
       Pfield.NewCards.Picture = CardBack.CardBackPic(Index).Picture
    End If
End Sub

Sub FrameForm (Source As Form)
   Source.Line (0, 0)-(Source.ScaleWidth - 1, Source.ScaleHeight - 1), RGB(0, 0, 0), B
   Source.Line (1, 1)-(Source.ScaleWidth - 2, Source.ScaleHeight - 2), RGB(255, 255, 255), B
   Source.Line (4, 4)-(Source.ScaleWidth - 5, Source.ScaleHeight - 5), RGB(128, 128, 128), B
End Sub

Sub RaiseControl (Source1 As Form, Source2 As Control, Thickness As Integer, TopColor As Integer)
'
' will draw a border around a control, with actual graphics on the form
' assuming everthing is done in pixels
'
Dim Color1 As Long
Dim Color2 As Long

   x = Source2.Left
   y = Source2.Top
   w = Source2.Width
   h = Source2.Height

   If TopColor = 1 Then
      Color1 = RGB(255, 255, 255)
      Color2 = RGB(128, 128, 128)
   Else
      Color1 = RGB(128, 128, 128)
      Color2 = RGB(255, 255, 255)
   End If

   For i = 1 To Thickness
      Source1.Line (x - i, y - i)-Step(w + (2 * i - 1), 0), Color1
      Source1.Line -Step(0, h + (2 * i - 1)), Color1
      Source1.Line -Step(-(w + (2 * i - 1)), 0), Color2
      Source1.Line -Step(0, -(h + 2 * i)), Color2
   Next


End Sub

Sub LoadHelp ()

   Dim Color1 As Long
   Dim Color2 As Long

   Color2 = RGB(255, 255, 255)
   Color1 = RGB(128, 128, 128)

   Load Form1

   Form1.WindowState = 0
   Form1.AutoRedraw = TRUE
   Form1.BackColor = RGB(192, 192, 192)

   Form1.Top = 690
   Form1.Left = 480
   Form1.Height = 6135
   Form1.Width = 5055

' position command button
   CenterCtlBottom Form1, Form1.Command1, 10

' go ahead and frame the form
   FrameForm Form1

' now lets print something
   Form1.FontName = "Helv"
   Form1.FontSize = 24

   Form1.ForeColor = Color2
   Form1.CurrentX = 10
   Form1.CurrentY = 10
   Form1.Print "Crispy1 Quick Help"

   Form1.ForeColor = Color1
   Form1.CurrentX = 9
   Form1.CurrentY = 9
   Form1.Print "Crispy1 Quick Help"

   Form1.ForeColor = Color1
   Form1.CurrentX = 8
   Form1.CurrentY = 8
   Form1.Print "Crispy1 Quick Help"

' now lets print the actual Form1 text
   Form1.FontName = "Helv"
   Form1.FontSize = 9.75

   Print3D Form1, 10, 55, -1, -1, Color1, Color2, "        Kings on Top, Queens on the Side     "
   Print3D Form1, 10, 70, -1, -1, Color1, Color2, "             and Jacks in the Corner         "
   Print3D Form1, 10, 90, -1, -1, Color1, Color2, "The object of the game is to place the face  "
   Print3D Form1, 10, 110, -1, -1, Color1, Color2, "cards on the edges while removing all non-   "
   Print3D Form1, 10, 130, -1, -1, Color1, Color2, "face cards a pair at a time. To remove a     "
   Print3D Form1, 10, 150, -1, -1, Color1, Color2, "pair, click the first card. It will reverse  "
   Print3D Form1, 10, 170, -1, -1, Color1, Color2, "image. Click matching card and the pair will "
   Print3D Form1, 10, 190, -1, -1, Color1, Color2, "be removed. To migrate a face card to the    "
   Print3D Form1, 10, 210, -1, -1, Color1, Color2, "edge, first click the face card, and then the"
   Print3D Form1, 10, 230, -1, -1, Color1, Color2, "eligible edge position to which you wish to  "
   Print3D Form1, 10, 250, -1, -1, Color1, Color2, "move it. (Kings go on top (and bottom),      "
   Print3D Form1, 10, 270, -1, -1, Color1, Color2, "queens go on the sides, and jacks in the cor-"
   Print3D Form1, 10, 290, -1, -1, Color1, Color2, "ner). Click a reverse imaged card to cancel  "
   Print3D Form1, 10, 310, -1, -1, Color1, Color2, "the operation. If the face cards are all in  "
   Print3D Form1, 10, 330, -1, -1, Color1, Color2, "valid edge positions and all other cards have"
   Print3D Form1, 10, 350, -1, -1, Color1, Color2, "been removed, then you have won!.            "

  Form1.Show 1
End Sub

Sub Print3D (Source As Form, x As Integer, y As Integer, xdir As Integer, ydir As Integer, Color1 As Long, Color2 As Long, PrintMe As String)
   Dim OldColor As Long
   OldColor = Source.ForeColor

   Source.ForeColor = Color1
   Source.CurrentX = x
   Source.CurrentY = y
   Source.Print PrintMe

   Source.ForeColor = Color2
   Source.CurrentX = x + xdir
   Source.CurrentY = y + ydir
   Source.Print PrintMe

   Source.ForeColor = OldColor
End Sub

Sub Init ()
   GetProfile
   InitDeck
   ShuffleDeck
   DealDeck
End Sub

Sub InitDeck ()
' randomize, load cards into array, and condition control array
   Randomize

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

   For i = 0 To 15
      Pfield.Picture1(i).FillStyle = 0                   'solid
      Pfield.Picture1(i).FillColor = RGB(192, 192, 192)  'gray
      Pfield.Picture1(i).DrawMode = 10           ' NOT XOR
      Pfield.Picture1(i).ScaleMode = PIXEL
      Pfield.Picture1(i).ScaleHeight = 96
      Pfield.Picture1(i).ScaleWidth = 71
   Next i
End Sub

Sub CtlEnable (SetMe As Integer)
' 1 = Click2 off, menus off
' 2 = Click2 off, menus on
' 3 = Click2 on, menus on

   Select Case SetMe
      Case 1
         Pfield.Click2.Enabled = FALSE
         Pfield.CardBacks.Enabled = FALSE
         Pfield.Shelp.Enabled = FALSE
         Pfield.CAbout.Enabled = FALSE
      Case 2
         Pfield.Click2.Enabled = FALSE
         Pfield.CardBacks.Enabled = TRUE
         Pfield.Shelp.Enabled = TRUE
         Pfield.CAbout.Enabled = TRUE
      Case 3
         Pfield.Click2.Enabled = TRUE
         Pfield.CardBacks.Enabled = TRUE
         Pfield.Shelp.Enabled = TRUE
         Pfield.CAbout.Enabled = TRUE
   End Select

End Sub

Sub LoadAbout ()
   Dim Color1 As Long
   Dim Color2 As Long

   Color2 = RGB(255, 255, 255)
   Color1 = RGB(128, 128, 128)

   Load Form1

   Form1.WindowState = 0
   Form1.AutoRedraw = TRUE
   Form1.ScaleMode = PIXEL
   Form1.BackColor = RGB(192, 192, 192)

   Form1.Top = 690
   Form1.Left = 480
   Form1.Height = 6135
   Form1.Width = 5055

' position the command botton
   CenterCtlBottom Form1, Form1.Command1, 10

' go ahead and frame the form
   FrameForm Form1

' now lets print something
   Form1.FontName = "Helv"
   Form1.FontSize = 24

   Form1.ForeColor = Color2
   Form1.CurrentX = 85
   Form1.CurrentY = 15
   Form1.Print "Crispy1"

   Form1.ForeColor = Color1
   Form1.CurrentX = 84
   Form1.CurrentY = 14
   Form1.Print "Crispy1"

   Form1.ForeColor = Color1
   Form1.CurrentX = 83
   Form1.CurrentY = 13
   Form1.Print "Crispy1"

   'now lets print the actual Form1 text
   Form1.FontName = "Helv"
   Form1.FontSize = 18

   Print3D Form1, 10, 55, -1, -1, Color1, Color2, "A game by Chris Pando                        "
   Form1.FontSize = 9.75
   Print3D Form1, 10, 95, -1, -1, Color1, Color2, "71020,2545 (CIS)                             "
   Color2 = RGB(255, 0, 0)
   Color1 = RGB(0, 0, 0)
   Form1.FontSize = 18
   Print3D Form1, 10, 130, 2, -2, Color1, Color2, "If it is squinky, then you "
   Print3D Form1, 10, 155, 2, -2, Color1, Color2, "know it is BrilligWare!    "

   SplitFramedForm Form1

   Color2 = RGB(255, 255, 255)
   Color1 = RGB(128, 128, 128)
   Form1.FontSize = 9.75
   Print3D Form1, 10, 220, -1, -1, Color1, Color2, "Many thanks to Richard R. Sands, the creator "
   Print3D Form1, 10, 240, -1, -1, Color1, Color2, "of VBCARDS.DLL, who developed the tools      "
   Print3D Form1, 10, 260, -1, -1, Color1, Color2, "and techniques that made this game possible. "

 ' Print3D Form1, 10, 290, -1, -1, Color1, Color2, "Also, many thanks to my co-workers who,      "
 ' Print3D Form1, 10, 310, -1, -1, Color1, Color2, "despite great personal hardship, found the   "
 ' Print3D Form1, 10, 330, -1, -1, Color1, Color2, "time to test (and criticize) this game.      "

   Form1.Show 1
End Sub

Sub SplitFramedForm (Source As Form)
'assuming Source.ScaleMode = PIXEL
   Source.Line (5, (Int(Source.ScaleHeight / 2)))-Step(Source.ScaleWidth - 10, 0), RGB(0, 0, 0)
   Source.Line (5, (Int(Source.ScaleHeight / 2)) + 1)-Step(Source.ScaleWidth - 10, 0), RGB(255, 255, 255)
End Sub

Sub Engine (Index As Integer)
    ' This is the routine that does all the work
    ' I decided this routine would be most reliably implemented
    ' as a semi-rigorous finite state machine
    '
    '
    '
    Select Case State
       Case CLOSEDFIELD

          If (RoyalCard(Index) <> TRUE) Then
             ReverseImage Pfield.Picture1(Index)
             State = APENDING
             CtlEnable 1
             FromCard = Index
          End If


       Case OPENFIELD

          If (Field(Index) <> -1) Then
             If (RoyalCard(Index) <> TRUE) Then
                ReverseImage Pfield.Picture1(Index)
                State = APENDING
                CtlEnable 1
                FromCard = Index
             Else
                ReverseImage Pfield.Picture1(Index)
                State = CPENDING
                CtlEnable 1
                FromCard = Index
             End If
          End If

       Case APENDING
          If (FromCard = Index) Then
             ReverseImage Pfield.Picture1(Index)
             OpenOrClosed                        ' set state
          ElseIf (SameCardValue(Field(FromCard), Field(Index))) Then
             Remove FromCard, Index
             OpenOrClosed                        ' set state
          End If

       Case CPENDING

          If (FromCard = Index) Then
             ReverseImage Pfield.Picture1(Index)
             State = OPENFIELD
             CtlEnable 3
          ElseIf (ValidEmpty(Index)) Then
             Swap FromCard, Index
             State = OPENFIELD
             CtlEnable 3
          End If

    End Select

    If TestWin() Then
      LoadWin
    End If
End Sub

Sub DealCards ()
' deal a card to all empty positions on the playing field
   i = 0
   Do While (NextCard < 53 And NumberOpen > 0) 'NumberOpen > 0 implies that
      Do While (Field(i) <> -1)                ' there exists a Field(I)
         i = i + 1                             ' = -1
      Loop

      Field(i) = Deck(NextCard)
      GetCard (Field(i))
      Pfield.Picture1(i).Picture = ClipBoard.GetData(2)
      NumberOpen = NumberOpen - 1
      NextCard = NextCard + 1
      If (NextCard = 53) Then
         GetCardMisc (1)
      Else
         GetCardBack (BackDesign)
      End If
      Pfield.NewCards.Picture = ClipBoard.GetData(2)

      State = CLOSEDFIELD      'set state
      CtlEnable 2
   Loop
End Sub

Sub NewGame ()
   ShuffleDeck
   DealDeck
End Sub

Sub GetProfile ()
' set a couple of the global variables
   Pfield.WindowState = GetPrivateProfileInt("Crispy1", "WindowState", 2, "CRISPY.INI")
   BackDesign = GetPrivateProfileInt("Crispy1", "BackDesign", 1, "CRISPY.INI")
End Sub

Sub WriteProfile ()
   x = WritePrivateProfileString("Crispy1", "WindowState", Str$(Pfield.WindowState), "CRISPY.INI")
   x = WritePrivateProfileString("Crispy1", "BackDesign", Str$(BackDesign), "CRISPY.INI")
End Sub

Function TestWin () As Integer
' if the four center places are empty, and all cards have been dealt, then we have a winner
   If NextCard = 53 And Field(CENTER1) = -1 And Field(CENTER2) = -1 And Field(CENTER3) = -1 And Field(CENTER4) = -1 Then
      TestWin = TRUE
   Else
      TestWin = FALSE
   End If
End Function

Sub CenterCtlBottom (Source As Form, Ctl As Control, Alt As Integer)
 ' center control a specified distance above the bottom of the form
 ' works regardless of ScaleMode

   Ctl.Top = Source.ScaleHeight - Ctl.Height - Alt
   Ctl.Left = (Source.ScaleWidth - Ctl.Width) / 2
End Sub

Sub LoadWin ()
   Dim Color1 As Long
   Dim Color2 As Long

   Color2 = RGB(255, 255, 255)
   Color1 = RGB(128, 128, 128)

   Load Form1

   Form1.WindowState = 0
   Form1.AutoRedraw = TRUE
   Form1.ScaleMode = PIXEL
   Form1.BackColor = RGB(192, 192, 192)

   Form1.Top = 2250
   Form1.Left = 1800
   Form1.Height = 3015
   Form1.Width = 2415

' center the command button
   CenterCtlBottom Form1, Form1.Command1, 10

' go ahead and frame the form
   FrameForm Form1

' now lets print something
   Form1.FontName = "Helv"
   Form1.FontSize = 24

   Form1.ForeColor = Color2
   Form1.CurrentX = 15
   Form1.CurrentY = 15
   Form1.Print "CRISPY1"

   Form1.ForeColor = Color1
   Form1.CurrentX = 14
   Form1.CurrentY = 14
   Form1.Print "CRISPY1"

   Form1.ForeColor = Color1
   Form1.CurrentX = 13
   Form1.CurrentY = 13
   Form1.Print "CRISPY1"

   'now lets print the actual Form1 text
   Form1.FontName = "Helv"
   Form1.FontSize = 18

   Print3D Form1, 10, 55, -1, -1, Color1, Color2, "We Have  "
   Print3D Form1, 10, 75, -1, -1, Color1, Color2, "A Winner!"

   Form1.Show 1

End Sub

Sub PaintPfield ()
'not using persistent bit maps, so if Pfield is redisplayed
'(minimized, and then un-minimized) redo graphic effects
   If State = APENDING Or State = CPENDING Then
      ReverseImage Pfield.Picture1(FromCard)
   End If
End Sub