'Set' Card Game

james klutho
Member
Join Date: Apr 2001
Posts: 637
4 Jan 2009, 02:02 PM
I got the 'Set' card game for Christmas and I am addicted. The idea is simple but I find it maddening difficult. Many of you probably already play it and some maybe be very good at recognizing the sets when displayed. For those of you not aquainted with the game you can read about it here.
America's Favorite Card Games®
http://www.setgame.com/set/index.html
I wrote a solitaire version for the computer to try and hone my skills so when I go into battle I can at least hold my own. The computer kicks my butt. I tried to stay true to the game (my shapes are altered for programming ease). Just click on three cards and press 'Ok' to see if it is a set. You can reclick on a card to deselect it or press 'Clear' to deselect all. You can also choose 'Hint' from the file menu to highlight a set. You can start the Timer to play against the computer. Have fun.
Code:
'Set Practice  by Jim Klutho
 '   * Given any two cards, there exists one and only one card which forms a set with those two cards.
 '
 '   * Therefore the probability of producing a Set from 3 randomly drawn cards is 1/79.
 '
 '   * The largest group of cards you can put together without creating a set is 20.[1]
 '
 '   * There are 1080 unique sets

#COMPILE EXE
#DIM ALL
#INCLUDE "WIN32API.INC"

'--------Constants-----------------------
%IDM_FILE_EXIT   = 1001
%IDM_FILE_NEW    = 1002
%IDM_FILE_SHOWSET= 1003
%IDM_FILE_INFO= 1004
%IDM_FILE_RESETSCORE= 1005
%IDC_NOTIME = 105
%IDC_15SEC = 110
%IDC_30SEC = 115
%IDC_TIME = 120
%IDC_ME = 130
%IDC_COMP = 140
%IDC_NUMSETS =150
%IDC_CARDS=160

%IDC_SET         = 1011
%IDOK            =    1
%IDCLEAR         =    2

'Card Colors
%REDCOLOR=1
%GREENCOLOR=2
%BLUECOLOR=3
'Card Shape
%DIAMONDSHAPE=1
%SQUARESHAPE=2
%OVALSHAPE=3
'Card Fill
%NOFILL=1
%SHADEFILL=2
%SOLIDFILL=3
'Card Count
%ONECOUNT=1
%TWOCOUNT=2
%THREECOUNT=3
'--------Types--------------------------
 TYPE Card
     CardColor AS LONG
     CardCount AS LONG
     CardShape AS LONG
     CardFill  AS LONG
 END TYPE

 TYPE DealtCard
     WhichCard AS LONG
     Selected  AS LONG
     Position AS RECT
     Sets AS LONG
     Temp1 AS LONG
     Temp2 AS LONG
 END TYPE

 TYPE PolyPoints
  count AS LONG
  x1 AS SINGLE
  y1 AS SINGLE
  x2 AS SINGLE
  y2 AS SINGLE
  x3 AS SINGLE
  y3 AS SINGLE
  x4 AS SINGLE
  y4 AS SINGLE
END TYPE



'--------Globals------------------------
GLOBAL c() AS Card
GLOBAL d() AS DealtCard
GLOBAL gShCard() AS LONG
GLOBAL lpx AS LONG
GLOBAL lpy AS LONG
GLOBAL lpPoint AS POINTAPI
GLOBAL hMenu AS DWORD
GLOBAL hDlg AS LONG
GLOBAL hBoard AS LONG
GLOBAL cols AS LONG
GLOBAL mycountdown AS LONG
GLOBAL mycountdownlimit AS LONG
GLOBAL runflag AS LONG
GLOBAL TopCard AS LONG
GLOBAL errMessage AS STRING
GLOBAL MyScore AS LONG
GLOBAL CompScore AS LONG
GLOBAL TrickCount AS LONG
'--------Declares------------------------
DECLARE SUB SetRedraw
DECLARE FUNCTION FindSet(op AS LONG) AS LONG
DECLARE SUB InitGame
'--------Functions-----------------------

SUB Deal3Cards
   LOCAL countx AS LONG
   LOCAL county AS LONG
   LOCAL result AS LONG
   DIM tempstack(20) AS LONG
   LOCAL s AS ASCIIZ * 50

   INCR Trickcount
   'Go through a series of possible downward revisions of the columns
   IF cols = 4 THEN
     IF d(4,0).Selected = 0 THEN INCR tempstack(0):tempstack(tempstack(0))=d(4,0).WhichCard
     IF d(4,1).Selected = 0 THEN INCR tempstack(0):tempstack(tempstack(0))=d(4,1).WhichCard
     IF d(4,2).Selected = 0 THEN INCR tempstack(0):tempstack(tempstack(0))=d(4,2).WhichCard
     cols=3
   END IF

   IF TrickCount=24 THEN
     IF d(3,0).Selected = 0 THEN INCR tempstack(0):tempstack(tempstack(0))=d(3,0).WhichCard
     IF d(3,1).Selected = 0 THEN INCR tempstack(0):tempstack(tempstack(0))=d(3,1).WhichCard
     IF d(3,2).Selected = 0 THEN INCR tempstack(0):tempstack(tempstack(0))=d(3,2).WhichCard
     cols=2
   END IF

   IF TrickCount=25 THEN
     IF d(2,0).Selected = 0 THEN INCR tempstack(0):tempstack(tempstack(0))=d(2,0).WhichCard
     IF d(2,1).Selected = 0 THEN INCR tempstack(0):tempstack(tempstack(0))=d(2,1).WhichCard
     IF d(2,2).Selected = 0 THEN INCR tempstack(0):tempstack(tempstack(0))=d(2,2).WhichCard
     cols=1
   END IF

   IF TrickCount=26 THEN
       s="Last Trick - Redeal."
       MessageBox hDlg, s, "Message" & CHR$(0), %MB_OK
       InitGame
       EXIT SUB
   END IF

    FOR county = 0 TO 2
     FOR countx = 0 TO cols
         IF d(countx,county).Selected = 1 THEN
            d(countx,county).Selected = 0
            IF tempstack(0) > 0 THEN
               d(countx,county).WhichCard = tempstack(tempstack(0))
               DECR tempstack(0)
              ELSE
                IF TopCard <> 82 THEN d(countx,county).WhichCard = TopCard
                IF TopCard < 82 THEN INCR TopCard
                IF TopCard > 81 THEN EXIT SUB
            END IF
         END IF
     NEXT countx
    NEXT county
    CONTROL SET TEXT hDlg,%IDC_CARDS,STR$(TopCard)
    result = FindSet(0)
    IF result=0 THEN CONTROL SET TEXT hDlg,%IDC_NUMSETS,"Exists" ELSE CONTROL SET TEXT hDlg,%IDC_NUMSETS,"No Sets"
    IF result <> 0 THEN  '79 80 81
         IF cols <> 4 AND TopCard < 80 THEN AdjustCardCountDisplay 15
         result = FindSet(0)
         IF result=0 THEN CONTROL SET TEXT hDlg,%IDC_NUMSETS,"Exists" ELSE CONTROL SET TEXT hDlg,%IDC_NUMSETS,"No Sets"
    END IF
END SUB

FUNCTION TestForSet() AS LONG
   LOCAL countx AS LONG
   LOCAL county AS LONG
   LOCAL cardcount AS LONG
   LOCAL result AS LONG
   LOCAL product AS LONG
   DIM mycards(3,4) AS LONG
   LOCAL I,J AS LONG
   errMessage = "This is a Set - Score one for Me"
    FOR county = 0 TO 2
     FOR countx = 0 TO cols
         IF d(countx,county).Selected = 1 THEN
            INCR cardcount
            mycards(cardcount,1)=c(d(countx,county).WhichCard).CardColor
            mycards(cardcount,2)=c(d(countx,county).WhichCard).CardCount
            mycards(cardcount,3)=c(d(countx,county).WhichCard).CardShape
            mycards(cardcount,4)=c(d(countx,county).WhichCard).CardFill
         END IF
     NEXT countx
    NEXT county
    result = 0
    IF cardcount <> 3 THEN
        result = -1
      ELSE
         FOR I=1 TO 3
           IF I = 1 THEN Product= mycards(I,1) ELSE Product=Product * mycards(I,1)
         NEXT I
         IF Product <> 1 AND Product <> 6 AND Product <> 8 AND Product <> 27 THEN
             Result = 1
             errMessage =  "Failed Color"
             GOTO bail
           ELSE
            'Nothing for now
         END IF
         FOR I=1 TO 3
           IF I = 1 THEN Product= mycards(I,2) ELSE Product=Product * mycards(I,2)
         NEXT I
         IF Product <> 1 AND Product <> 6 AND Product <> 8 AND Product <> 27 THEN
              Result = 1
              errMessage =  "Failed Count"
              GOTO bail
          ELSE
             'Nothing for now
         END IF
         FOR I=1 TO 3
           IF I = 1 THEN Product= mycards(I,3) ELSE Product=Product * mycards(I,3)
         NEXT I
         IF Product <> 1 AND Product <> 6 AND Product <> 8 AND Product <> 27 THEN
               Result = 1
               errMessage =  "Failed Shape"
               GOTO bail
           ELSE
               'Nothing for now
         END IF
         FOR I=1 TO 3
           IF I = 1 THEN Product= mycards(I,4) ELSE Product=Product * mycards(I,4)
         NEXT I
         IF Product <> 1 AND Product <> 6 AND Product <> 8 AND Product <> 27 THEN
             Result = 1
             errMessage = "Failed Fill"
             GOTO bail
         ELSE
             'Nothing for now
         END IF
    END IF
    bail:
     FUNCTION= result
END FUNCTION

FUNCTION FindSet(op AS LONG) AS LONG
   LOCAL countx AS LONG
   LOCAL county AS LONG
   LOCAL countxx AS LONG
   LOCAL countyy AS LONG
   LOCAL countxxx AS LONG
   LOCAL countyyy AS LONG
   LOCAL result AS LONG
   LOCAL loopcount AS LONG

   'Save the selection
    FOR county = 0 TO 2
     FOR countx = 0 TO cols
         IF d(countx,county).Selected = 1 THEN
            d(countx,county).Selected = 0
            d(countx,county).Temp1 = 1
         END IF
     NEXT countx
    NEXT county

   '----------------------------------------------------
  FOR countyyy = 0 TO 2
   FOR countxxx = 0 TO cols
        FOR countyy = 0 TO 2
         FOR countxx = 0 TO cols
            FOR county = 0 TO 2
             FOR countx = 0 TO cols
                 d(countxxx,countyyy).Selected = 1
                 d(countxx,countyy).Selected = 1
                 d(countx,county).Selected = 1

                 Result=TestforSet
                 IF result = 0 THEN GOTO finished

                 d(countxxx,countyyy).Selected = 0
                 d(countxx,countyy).Selected = 0
                 d(countx,county).Selected = 0
             NEXT countx
            NEXT county
         NEXT countxx
        NEXT countyy
     NEXT countxxx
    NEXT countyyy

    finished:

  'Put back the selection if op <> 0
   IF op=0 THEN
    FOR county = 0 TO 2
     FOR countx = 0 TO cols
         d(countx,county).Selected = 0
         IF d(countx,county).Temp1 = 1 THEN
            d(countx,county).Selected = 1
            d(countx,county).Temp1 = 0
         END IF
     NEXT countx
    NEXT county
   END IF
   FUNCTION = Result
END FUNCTION

SUB ShuffleDeck
  LOCAL I AS LONG, J AS LONG

  RANDOMIZE                                   'seed the random number generator
  gShCard(0) = INT((81) * RND((81)))          'start with first card
  FOR I = 1 TO 80                             'then loop through the rest
     gShCard(I) = INT((81) * RND((81)))
     FOR J = 0 TO I - 1                       'run second loop to make sure all is unique
        IF gShCard(J) = gShCard(I) THEN
           gShCard(I) = INT((81) * RND((81)))
           J = -1                             'reset J to restart this second loop
        END IF
     NEXT J
  NEXT I
END SUB

SUB AdjustCardCountDisplay(cards AS LONG)
    IF cards <> 15 THEN EXIT SUB
    cols=4
    d(4,0).WhichCard = TopCard : INCR TopCard
    d(4,1).WhichCard = TopCard : INCR TopCard
    d(4,2).WhichCard = TopCard : INCR TopCard
END SUB

SUB InitGame
   LOCAL countx AS LONG
   LOCAL county AS LONG
   LOCAL x,s,n,f,y AS LONG
   LOCAL result AS LONG
    TrickCount=0
    cols = 3
    REDIM gshCard(81) AS LONG
    REDIM c(81) AS Card
    REDIM d(4,2) AS DealtCard
    ShuffleDeck
    'Establish card rectangles on the board
    FOR county = 0 TO 2
     FOR countx = 0 TO 4
        d(countx,county).Position.nLeft= (20 + countx * 120)
        d(countx,county).Position.nTop= (20 + county * 170)
        d(countx,county).Position.nRight= (20 + countx * 120)+100
        d(countx,county).Position.nBottom= (20 + county * 170)+150
     NEXT countx
    NEXT county
    'Initalize the timer variables
    mycountdownlimit=15
    mycountdown = mycountdownlimit

    'Assign Color,Count,Shape, and fill to the shuffled deck
    y=0
    FOR x=1 TO 3
        FOR s=1 TO 3
            FOR n=1 TO 3
                FOR f=1 TO 3
                   c(gshcard(y)).cardcolor=x
                   c(gshcard(y)).cardcount=s
                   c(gshcard(y)).cardshape=n
                   c(gshcard(y)).cardfill=f
                   INCR y
                NEXT f
            NEXT n
        NEXT s
    NEXT c
   TopCard=0
   FOR county = 0 TO 2
     FOR countx = 0 TO cols
       d(countx,county).WhichCard=TopCard
       INCR TopCard
     NEXT countx
    NEXT county
    CONTROL SET TEXT hDlg,%IDC_CARDS,STR$(81-Topcard)
    result = FindSet(0)
    IF result=0 THEN CONTROL SET TEXT hDlg,%IDC_NUMSETS,"Exists" ELSE CONTROL SET TEXT hDlg,%IDC_NUMSETS,"No Sets"
    IF result <> 0 THEN
        IF cols <> 4 AND TopCard < 80 THEN AdjustCardCountDisplay 15
         result = FindSet(0)
         IF result=0 THEN CONTROL SET TEXT hDlg,%IDC_NUMSETS,"Exists" ELSE CONTROL SET TEXT hDlg,%IDC_NUMSETS,"No Sets"
    END IF

END SUB

FUNCTION CountSelected() AS LONG
   LOCAL countx AS LONG
   LOCAL county AS LONG
   LOCAL cardcount AS LONG

    FOR county = 0 TO 2
     FOR countx = 0 TO cols
         IF d(countx,county).Selected = 1 THEN
            INCR cardcount
         END IF
     NEXT countx
    NEXT county

    FUNCTION= cardcount
END FUNCTION

SUB ScoreOneForTheComputer
    LOCAL result AS LONG
    LOCAL s AS ASCIIZ * 50
    LOCAL temp AS LONG
    Result=FindSet(1)
    IF result = 0 THEN
        BEEP

        SetRedraw
        SLEEP 3000
        INCR CompScore
        Deal3Cards
        SetRedraw
        CONTROL DISABLE hDlg,%IDOK
        CONTROL POST hDlg,%IDCLEAR, %BM_CLICK, 0, 0
        CONTROL SET TEXT hDlg,%IDC_COMP,"Computer = " + STR$(CompScore)
        mycountdown=mycountdownlimit
        temp=runflag
        runflag=0
        s="Score one for the computer."
        MessageBox hDlg, s, "Message" & CHR$(0), %MB_OK
        runflag=temp
    END IF

END SUB




CALLBACK FUNCTION ShowSetProc()

    LOCAL Result AS LONG
    LOCAL countx AS LONG
    LOCAL county AS LONG
    LOCAL cardcount AS LONG
    LOCAL s AS ASCIIZ * 1000
    LOCAL temp AS LONG

    STATIC idTimer AS LONG

    SELECT CASE AS LONG CBMSG
        CASE %WM_INITDIALOG
           idTimer = SetTimer(CBHNDL, BYVAL &H0000FEED, 1000, BYVAL %NULL)
           mycountdown=15

        CASE %WM_NCACTIVATE
            STATIC hWndSaveFocus AS DWORD
            IF ISFALSE CBWPARAM THEN
                hWndSaveFocus = GetFocus()
            ELSEIF hWndSaveFocus THEN
                SetFocus(hWndSaveFocus)
                hWndSaveFocus = 0
            END IF

        CASE %WM_TIMER
            IF runflag > 0 THEN DECR mycountdown
            IF mycountdown= < 0 THEN
                ScoreOneForTheComputer
                mycountdown=mycountdownlimit
            END IF
            CONTROL SET TEXT CBHNDL,%IDC_TIME,STR$(mycountdown)


        CASE %WM_COMMAND
            SELECT CASE AS LONG CBCTL
                CASE %IDC_SET
                  '%STN_CLICKED or %STN_DBLCLK assumed
                  Result=GetCursorPos (lpPoint)
                  Result=ScreenToClient (CBHNDL,lpPoint)
                  cardcount=CountSelected
                 ' IF runflag = 0 THEN EXIT FUNCTION
                  FOR county = 0 TO 2
                     FOR countx = 0 TO cols
                         Result=PtinRect(d(countx,county).Position,lpPoint.x,lpPoint.y)
                         IF Result <> 0 THEN
                             IF cardcount =3 AND d(countx,county).Selected = 0 THEN BEEP : EXIT FUNCTION
                             IF d(countx,county).Selected = 0 THEN d(countx,county).Selected = 1 ELSE d(countx,county).Selected = 0
                             SetRedraw
                         END IF
                     NEXT countx
                  NEXT county
                  cardcount=CountSelected
                  IF cardcount=3 THEN
                     CONTROL ENABLE CBHNDL,%IDOK
                    ELSE
                      CONTROL DISABLE CBHNDL,%IDOK
                  END IF


                CASE %IDC_30SEC
                    runflag=1
                    mycountdownlimit=30
                    mycountdown=mycountdownlimit
                CASE %IDC_15SEC
                    runflag=1
                    mycountdownlimit=15
                    mycountdown=mycountdownlimit
                CASE %IDC_NOTIME
                    runflag=0
                    mycountdownlimit=1000
                CASE %IDOK
                    temp=runflag
                    runflag = 0
                    Result=TestforSet
                    s=errMessage
                    MessageBox CBHNDL, s, "Set Error" & CHR$(0), %MB_OK

                    mycountdown=mycountdownlimit
                    IF result = 0 THEN
                        INCR MyScore
                        Deal3Cards
                        SetRedraw
                        CONTROL DISABLE CBHNDL,%IDOK
                        CONTROL POST CBHNDL,%IDCLEAR, %BM_CLICK, 0, 0
                       ELSE
                        DECR MyScore
                        CONTROL DISABLE CBHNDL,%IDOK
                        CONTROL POST CBHNDL,%IDCLEAR, %BM_CLICK, 0, 0
                    END IF
                    CONTROL SET TEXT CBHNDL,%IDC_ME,"Me = " + STR$(MyScore)
                    runflag = temp
                CASE %IDCLEAR
                  CONTROL DISABLE CBHNDL,%IDOK
                  FOR county = 0 TO 2
                     FOR countx = 0 TO cols
                       d(countx,county).Selected = 0
                     NEXT countx
                  NEXT county
                  SetRedraw
                CASE %IDM_FILE_NEW
                      InitGame
                      SetRedraw

                CASE %IDM_FILE_RESETSCORE
                      MyScore = 0
                      CONTROL SET TEXT CBHNDL,%IDC_ME,"Me = " + STR$(MyScore)
                      CompScore = 0
                      CONTROL SET TEXT CBHNDL,%IDC_COMP,"Computer = " + STR$(CompScore)

                CASE %IDM_FILE_INFO
                       s="A 'Set' consists of three cards in which each feature is EITHER the same on each card OR is different on each card."
                       s=s + " That is to say, any feature in the 'Set' of three cards is either common to all three cards or is different on each card."
                       s=s + " The four features of the cards are:  1)Count, 2)Color, 3)Shape, and 4)Fill."
                       MessageBox CBHNDL, s, "Set Help" & CHR$(0), %MB_OK
                CASE %IDM_FILE_SHOWSET
                      Result=FindSet(1)
                      s="No Set was found"
                      IF Result <> 0 THEN
                          MessageBox CBHNDL, s, "Message" & CHR$(0), %MB_OK
                        ELSE
                          CONTROL ENABLE CBHNDL,%IDOK
                      END IF
                      SetRedraw
                CASE %IDM_FILE_EXIT
                    KillTimer %NULL, idTimer
                    DIALOG END CBHNDL , 0

            END SELECT
    END SELECT
END FUNCTION

SUB SetRedraw
    LOCAL countx AS LONG
    LOCAL county AS LONG
    LOCAL mycolor AS LONG
    LOCAL myfillstyle AS LONG
    LOCAL myfillcolor AS LONG
    LOCAL mypoly AS PolyPoints

    GRAPHIC CLEAR %WHITE

    GRAPHIC COLOR %BLACK, %WHITE
    GRAPHIC BOX (0, 0) - (625, 530)

    FOR county = 0 TO 2
     FOR countx = 0 TO cols
         IF d(countx,county).Selected=1 THEN GRAPHIC WIDTH 3 ELSE GRAPHIC WIDTH  1
         GRAPHIC BOX (d(countx,county).Position.nLeft, d(countx,county).Position.nTop) - (d(countx,county).Position.nRight,d(countx,county).Position.nBottom), 20
         GRAPHIC WIDTH  3

         SELECT CASE c(d(countx,county).WhichCard).CardColor
           CASE %REDCOLOR
               MyColor = %RED
               MyFillColor = %RED
           CASE %GREENCOLOR
               MyColor = %GREEN
               MyFillColor = %GREEN
           CASE %BLUECOLOR
               MyColor = %BLUE
               MyFillColor = %BLUE
         END SELECT

         SELECT CASE c(d(countx,county).WhichCard).CardFill
           CASE %NOFILL
              MyFillstyle = 0  'No Fill Solid with White
              MyFillColor = %WHITE
           CASE %SHADEFILL
              MyFillstyle = 2  'Cross Hatched
           CASE %SOLIDFILL
              MyFillstyle = 0  'Solid
         END SELECT

         SELECT CASE c(d(countx,county).WhichCard).CardCount
             CASE %ONECOUNT
                SELECT CASE c(d(countx,county).WhichCard).CardShape
                    CASE %DIAMONDSHAPE
                       GRAPHIC BOX (d(countx,county).Position.nLeft + 10, d(countx,county).Position.nTop + 60) - (d(countx,county).Position.nRight-10,d(countx,county).Position.nBottom-60), 10,mycolor,myfillcolor,myfillstyle
                    CASE %SQUARESHAPE
                       MyPoly.count=4
                       MyPoly.x1=d(countx,county).Position.nLeft + 10
                       MyPoly.x2=d(countx,county).Position.nLeft + 50
                       MyPoly.x3=d(countx,county).Position.nRight -10
                       MyPoly.x4=d(countx,county).Position.nLeft + 50
                       MyPoly.y1=d(countx,county).Position.nTop + 75
                       MyPoly.y2=d(countx,county).Position.nTop + 60
                       MyPoly.y3=d(countx,county).Position.nTop + 75
                       MyPoly.y4=d(countx,county).Position.nTop + 90
                       GRAPHIC POLYGON MyPoly,mycolor,myfillcolor,myfillstyle
                    CASE %OVALSHAPE
                       GRAPHIC ELLIPSE (d(countx,county).Position.nLeft + 10, d(countx,county).Position.nTop + 60) - (d(countx,county).Position.nRight-10,d(countx,county).Position.nBottom-60),mycolor,myfillcolor,myfillstyle
                END SELECT
             CASE %TWOCOUNT
               SELECT CASE c(d(countx,county).WhichCard).CardShape
                    CASE %DIAMONDSHAPE
                       GRAPHIC BOX (d(countx,county).Position.nLeft + 10, d(countx,county).Position.nTop + 30) - (d(countx,county).Position.nRight-10,d(countx,county).Position.nBottom-90), 10,mycolor,myfillcolor,myfillstyle
                       GRAPHIC BOX (d(countx,county).Position.nLeft + 10, d(countx,county).Position.nTop + 90) - (d(countx,county).Position.nRight-10,d(countx,county).Position.nBottom-30), 10,mycolor,myfillcolor,myfillstyle
                    CASE %SQUARESHAPE
                       MyPoly.count=4
                       MyPoly.x1=d(countx,county).Position.nLeft + 10
                       MyPoly.x2=d(countx,county).Position.nLeft + 50
                       MyPoly.x3=d(countx,county).Position.nRight -10
                       MyPoly.x4=d(countx,county).Position.nLeft + 50
                       MyPoly.y1=d(countx,county).Position.nTop + 45
                       MyPoly.y2=d(countx,county).Position.nTop + 30
                       MyPoly.y3=d(countx,county).Position.nTop + 45
                       MyPoly.y4=d(countx,county).Position.nTop + 60
                       GRAPHIC POLYGON MyPoly,mycolor,myfillcolor,myfillstyle
                       MyPoly.y1=d(countx,county).Position.nTop + 105
                       MyPoly.y2=d(countx,county).Position.nTop + 90
                       MyPoly.y3=d(countx,county).Position.nTop + 105
                       MyPoly.y4=d(countx,county).Position.nTop + 120
                       GRAPHIC POLYGON MyPoly,mycolor,myfillcolor,myfillstyle
                    CASE %OVALSHAPE
                       GRAPHIC ELLIPSE (d(countx,county).Position.nLeft + 10, d(countx,county).Position.nTop + 30) - (d(countx,county).Position.nRight-10,d(countx,county).Position.nBottom-90),mycolor,myfillcolor,myfillstyle
                       GRAPHIC ELLIPSE (d(countx,county).Position.nLeft + 10, d(countx,county).Position.nTop + 90) - (d(countx,county).Position.nRight-10,d(countx,county).Position.nBottom-30),mycolor,myfillcolor,myfillstyle
                END SELECT

             CASE %THREECOUNT
                SELECT CASE c(d(countx,county).WhichCard).CardShape
                    CASE %DIAMONDSHAPE
                       GRAPHIC BOX (d(countx,county).Position.nLeft + 10, d(countx,county).Position.nTop + 10) - (d(countx,county).Position.nRight-10,d(countx,county).Position.nBottom-110), 10,mycolor,myfillcolor,myfillstyle
                       GRAPHIC BOX (d(countx,county).Position.nLeft + 10, d(countx,county).Position.nTop + 60) - (d(countx,county).Position.nRight-10,d(countx,county).Position.nBottom-60), 10,mycolor,myfillcolor,myfillstyle
                       GRAPHIC BOX (d(countx,county).Position.nLeft + 10, d(countx,county).Position.nTop + 110) - (d(countx,county).Position.nRight-10,d(countx,county).Position.nBottom-10), 10,mycolor,myfillcolor,myfillstyle
                    CASE %SQUARESHAPE
                       MyPoly.count=4
                       MyPoly.x1=d(countx,county).Position.nLeft + 10
                       MyPoly.x2=d(countx,county).Position.nLeft + 50
                       MyPoly.x3=d(countx,county).Position.nRight -10
                       MyPoly.x4=d(countx,county).Position.nLeft + 50
                       MyPoly.y1=d(countx,county).Position.nTop + 25
                       MyPoly.y2=d(countx,county).Position.nTop + 10
                       MyPoly.y3=d(countx,county).Position.nTop + 25
                       MyPoly.y4=d(countx,county).Position.nTop + 40
                       GRAPHIC POLYGON MyPoly,mycolor,myfillcolor,myfillstyle
                       MyPoly.y1=d(countx,county).Position.nTop + 75
                       MyPoly.y2=d(countx,county).Position.nTop + 60
                       MyPoly.y3=d(countx,county).Position.nTop + 75
                       MyPoly.y4=d(countx,county).Position.nTop + 90
                       GRAPHIC POLYGON MyPoly,mycolor,myfillcolor,myfillstyle
                       MyPoly.y1=d(countx,county).Position.nTop + 125
                       MyPoly.y2=d(countx,county).Position.nTop + 110
                       MyPoly.y3=d(countx,county).Position.nTop + 125
                       MyPoly.y4=d(countx,county).Position.nTop + 140
                       GRAPHIC POLYGON MyPoly,mycolor,myfillcolor,myfillstyle

                     CASE %OVALSHAPE
                       GRAPHIC ELLIPSE (d(countx,county).Position.nLeft + 10, d(countx,county).Position.nTop + 10) - (d(countx,county).Position.nRight-10,d(countx,county).Position.nBottom-110),mycolor,myfillcolor,myfillstyle
                       GRAPHIC ELLIPSE (d(countx,county).Position.nLeft + 10, d(countx,county).Position.nTop + 60) - (d(countx,county).Position.nRight-10,d(countx,county).Position.nBottom-60),mycolor,myfillcolor,myfillstyle
                       GRAPHIC ELLIPSE (d(countx,county).Position.nLeft + 10, d(countx,county).Position.nTop + 110) - (d(countx,county).Position.nRight-10,d(countx,county).Position.nBottom-10),mycolor,myfillcolor,myfillstyle

                END SELECT

         END SELECT

      NEXT countx
    NEXT county

    GRAPHIC REDRAW
END SUB

FUNCTION AttachMENU1(BYVAL hDlg AS DWORD) AS DWORD

    LOCAL hPopUp1 AS DWORD

    MENU NEW BAR TO hMenu
    MENU NEW POPUP TO hPopUp1
    MENU ADD POPUP, hMenu, "File", hPopUp1, %MF_ENABLED
        MENU ADD STRING, hPopUp1, "New", %IDM_FILE_NEW, %MF_ENABLED
        MENU ADD STRING, hPopUp1, "-", 0, 0
        MENU ADD STRING, hPopUp1, "Reset Scores", %IDM_FILE_RESETSCORE, %MF_ENABLED
        MENU ADD STRING, hPopUp1, "Game Info", %IDM_FILE_INFO, %MF_ENABLED
        MENU ADD STRING, hPopUp1, "Hint", %IDM_FILE_SHOWSET, %MF_ENABLED
        MENU ADD STRING, hPopUp1, "-", 0, 0
        MENU ADD STRING, hPopUp1, "Exit", %IDM_FILE_EXIT, %MF_ENABLED
    MENU ATTACH hMenu, hDlg
    FUNCTION = hMenu
END FUNCTION



FUNCTION ShowSet(BYVAL hParent AS DWORD) AS LONG
    LOCAL lRslt AS LONG


    DIALOG NEW PIXELS, hParent, "Set Solitaire", 70, 70, 635, 610, TO hDlg

    CONTROL ADD GRAPHIC, hDlg, %IDC_Set, "", 5, 0, 625, 530, %SS_NOTIFY
    CONTROL HANDLE hDlg,%IDC_Set TO hBoard
    CONTROL ADD BUTTON ,hDlg,%IDOK,"Ok" ,175,550,50,25
    CONTROL ADD BUTTON ,hDlg,%IDCLEAR,"Clear" ,430,550,50,25
    CONTROL DISABLE hDlg,%IDOK

    CONTROL ADD OPTION, hDlg,%IDC_NOTIME,"Time Off", 5,545,60,12,%WS_GROUP
    CONTROL ADD OPTION, hDlg,%IDC_15SEC,"15 Sec", 5,560,60,12
    CONTROL ADD OPTION, hDlg,%IDC_30SEC,"30 Sec", 5,575,60,12
    CONTROL ADD LABEL, hDlg,%IDC_TIME,"15",90,560,40,12
    CONTROL ADD FRAME ,hDlg,-1,"Time Clock",2,531,150,60

    CONTROL ADD LABEL, hDlg,%IDC_ME,"Me = 0",265,550,90,12
    CONTROL ADD LABEL, hDlg,%IDC_COMP,"Computer = 0", 265,570,90,12
    CONTROL ADD FRAME ,hDlg,-1,"Score",250,531,100,60

    CONTROL ADD FRAME ,hDlg,-1,"A Set On This Board",500,531,120,60
    CONTROL ADD LABEL, hDlg,%IDC_NUMSETS,"",540,560,40,12

    CONTROL ADD FRAME ,hDlg,-1,"Deck",360,531,50,60
    CONTROL ADD LABEL, hDlg,%IDC_CARDS,"0",373,560,30,12

    GRAPHIC ATTACH hDlg, %IDC_Set, REDRAW
    CONTROL SET OPTION  hDlg,%IDC_NOTIME,%IDC_NOTIME,%IDC_30SEC
    runflag=0
    AttachMENU1 hDlg
    InitGame
    SetRedraw
    DIALOG SHOW MODAL hDlg, CALL ShowSetProc TO lRslt
    FUNCTION = lRslt
END FUNCTION




FUNCTION PBMAIN()
  ShowSet %HWND_DESKTOP
END FUNCTION
Last edited by james klutho; 4 Jan 2009, 05:34 PM. Reason: found a little bug in the code
Tags: None
james klutho

Member

Join Date: Apr 2001

Posts: 637
- Share
- Tweet
#2

4 Jan 2009, 05:36 PM

Re uploaded the code. Fixed a timer error I introduced right before I uploaded the source code the first time.

Jim
Comment
Barry Marks

Member

Join Date: Aug 2007

Posts: 406
- Share
- Tweet
#3

5 Jan 2009, 05:57 PM

Thank you for this. I haven't seen this game before. I don't know if I love it or hate it.

Barry
Comment
james klutho

Member

Join Date: Apr 2001

Posts: 637
- Share
- Tweet
#4

12 Sep 2012, 08:50 AM

To get this file to compile in PB10 change the following line:

Result=PtinRect(d(countx,county).Position,lpPoint.x,lpPoint.y)

to

LOCAL pt AS POINT
pt.x = lpPoint.x : pt.y =lpPoint.y
Result=PtinRect(d(countx,county).Position,pt)

Have fun

Jim
Comment
Previous template Next
Announcement

Forum Guidelines

'Set' Card Game

'Set' Card Game

Comment

Comment

Comment
