Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

'Set' Card Game

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • 'Set' Card Game

    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.

    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, 06:34 PM. Reason: found a little bug in the code

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

    Jim

    Comment


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

      Barry

      Comment


      • #4
        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

        Working...
        X