CardContestEntryJLT

 
 ' Card DLL Contest 
 ' Anandis 
 ' http://www.pagat.com/invented/anandis.html 
 ' August, 2011 
 ' Uses Qcard32.dll, a freeware library of playing card images. 
 ' DLL by Stephen Murphy. Qcard32.DLL website: 
 ' http://www.telusplanet.net/public/stevem/ 
 
 ' Rules 
 ' 2 Players 
 ' 17 card deck (4 Aces, 12 face cards, one Joker) 
 ' 8 cards alternately dealt to each player 
 ' Last card is placed face down in middle of table 
 ' Object of the game is to guess the card in the middle 
 ' Player opposite the dealer starts first 
 ' Play options are 
 ' Guess the card in the middle 
 ' Correct guess = WIN game 
 ' Incorrect guess = LOSE game 
 ' Either way, game ends 
 ' Play a card 
 ' Opponent lays down all cards of the 
 ' same suit and same rank 
 ' Play then passes to the opposing player 
 ' Pass the Joker 
 ' If held, the player may pass the Joker 
 ' to the opposing player, forcing that 
 ' player to play 
 ' A player with less than 2 cards MUST 
 ' guess the middle card 
 ' Winner is the best of 7 hands 
 
 
 WindowWidth = 800 
 WindowHeight = 500 
 UpperLeftX = Int((DisplayWidth - WindowWidth) / 2) 
 UpperLeftY = Int((DisplayHeight - WindowHeight) / 2) 
 graphicbox #main.g, 0, 0, 800, 500 
 
 open "Simple Anandis" for window as #main 
 #main "trapclose [quit]" 
 
 hGbox = hWnd(#main.g) 
 #main.g "down; color 0 192 0; backcolor 0 192 0" 
 #main.g "font verdana 12 bold" 
 #main.g "place 0 0; boxfilled 800 500; flush bg" 
 #main.g "place 355 305; boxfilled 425 385" 
 #main.g "flush clearGuess" 
 #main.g "color black" 
 #main.g "place 365 325" 
 #main.g "\ ???" 
 #main.g "\Guess" 
 #main.g "\ Card" 
 #main.g "\ ???" 
 #main.g "flush playerGuess" 
 #main.g "color 0 192 0" 
 
 ' Initialize the deck 
 call InitializeDeck hGbox 
 call SetCurrentBack 3 
 
 ' Select (by number) only the cards to be used 
 ' 11 = Jack Clubs, 24 = Jack Diamonds 
 ' 37 = Jack Hearts, 50 = Jack Spades 
 dim dCards(17) 
 dCards(1) = 11 
 dCards(2) = 24 
 dCards(3) = 37 
 dCards(4) = 50 
 ' 12 = Queen Clubs, 25 = Queen Diamonds 
 ' 38 = Queen Hearts, 51 = Queen Spades 
 dCards(5) = 12 
 dCards(6) = 25 
 dCards(7) = 38 
 dCards(8) = 51 
 ' 13 = King Clubs, 26 = King Diamonds 
 ' 39 = King Hearts, 52 = King Spades 
 dCards(9) = 13 
 dCards(10) = 26 
 dCards(11) = 39 
 dCards(12) = 52 
 ' 1 = Ace Clubs, 14 = Ace Diamonds 
 ' 27 = Ace Hearts, 40 = Ace Spades 
 dCards(13) = 1 
 dCards(14) = 14 
 dCards(15) = 27 
 dCards(16) = 40 
 ' 110 = Joker 
 dCards(17) = 110 
 
 ' Set up array to hold nCards to shuffle 
 dim nCards(17) 
 
 ' Set up an array to hold visibility of cards 
 dim iCards(17) 
 
 ' Set up array to hold xCards to determine best guess 
 dim xCards(17) 
 
 ' Fill arrays 
 call InitCards 
 
 ' Set up array to hold cards 
 dim hand1(2, 8) 
 dim hand2(2, 8) 
 ' (1, = computer's hand 
 ' (2, = player's hand 
 ' , 1-8) = nCard 
 ' , 9: 1-8 = nCard 
 
 ' Set GameInProgressFlag 
 GameInProgressFlag = 0 
 
 ' Select dealer 
 dealer = int(rnd(1) * 2) + 1 
 if dealer = 1 then 
 human = 2 
 computer = 1 
 else 
 human = 1 
 computer = 2 
 end if 
 
 ' Define coordinates 
 x1 = 50 ' x of dealt cards 
 x2 = 50 ' x of revealed cards 
 y1 = 300 ' y of human cards 
 y2 = 30 ' y of computer cards 
 
 [AnnounceDealer] 
 call AnnounceDealer dealer 
 
 [ShuffleCards] 
 ' Remove cards from hand 
 redim hand1(2, 8) 
 redim hand2(2, 8) 
 
 ' Shuffle the cards 
 call ShuffleCards dealer 
 
 ' Deal the cards 
 call NewDeal dealer, hGbox 
 
 [AnnouncePlayer] 
 if dealer = human then 
 playerTurn = computer 
 else 
 playerTurn = human 
 end if 
 call AnnouncePlayer playerTurn 
 
 if playerTurn = human then 
 ' Human's Turn 
 #main.g "when leftButtonDown [PlayerClick]" 
 wait 
 end if 
 
 ' Computer's Turn 
 wait 
 
 [quit] 
 close #qc 
 close #main 
 end 
 
 
 [PlayerClick] 
 xPos = MouseX 
 yPos = MouseY 
 clickCard = -1 
 select case 
 case yPos < 300 
 clickCard = 0 
 case yPos > 395 
 clickCard = 0 
 case xPos > 400 
 clickCard = 0 
 case xPos > 352 
 clickCard = 9 
 case xPos > 260 
 if xPos < 330 then 
 clickCard = 8 
 else 
 clickCard = 0 
 end if 
 if clickCard = 8 then 
 if hand1(1, 8) = 0 then 
 clickCard = 0 
 if hand1(1, 7) > 0 then 
 if xPos < 300 then 
 clickCard = 7 
 end if 
 end if 
 end if 
 end if 
 case xPos > 230 
 if xPos < 300 then 
 clickCard = 7 
 else 
 clickCard = 0 
 end if 
 if clickCard = 7 then 
 if hand1(1, 7) = 0 then 
 clickCard = 0 
 if hand1(1, 6) > 0 then 
 if xPos < 270 then 
 clickCard = 6 
 end if 
 end if 
 end if 
 end if 
 case xPos > 200 
 if xPos < 270 then 
 clickCard = 6 
 else 
 clickCard = 0 
 end if 
 if clickCard = 6 then 
 if hand1(1, 6) = 0 then 
 clickCard = 0 
 if hand1(1, 5) > 0 then 
 if xPos < 240 then 
 clickCard = 5 
 end if 
 end if 
 end if 
 end if 
 case xPos > 170 
 if xPos < 240 then 
 clickCard = 5 
 else 
 clickCard = 0 
 end if 
 if clickCard = 5 then 
 if hand1(1, 5) = 0 then 
 clickCard = 0 
 if hand1(1, 4) > 0 then 
 if xPos < 210 then 
 clickCard = 4 
 end if 
 end if 
 end if 
 end if 
 case xPos > 140 
 if xPos < 210 then 
 clickCard = 4 
 else 
 clickCard = 0 
 end if 
 if clickCard = 4 then 
 if hand1(1, 4) = 0 then 
 clickCard = 0 
 if hand1(1, 3) > 0 then 
 if xPos < 180 then 
 clickCard = 3 
 end if 
 end if 
 end if 
 end if 
 case xPos > 110 
 if xPos < 180 then 
 clickCard = 3 
 else 
 clickCard = 0 
 end if 
 if clickCard = 3 then 
 if hand1(1, 3) = 0 then 
 clickCard = 0 
 if hand1(1, 2) > 0 then 
 if xPos < 150 then 
 clickCard = 2 
 end if 
 end if 
 end if 
 end if 
 case xPos > 80 
 if xPos < 150 then 
 clickCard = 2 
 else 
 clickCard = 0 
 end if 
 if clickCard = 2 then 
 if hand1(1, 2) = 0 then 
 clickCard = 0 
 if hand1(1, 1) > 0 then 
 if xPos < 120 then 
 clickCard = 1 
 end if 
 end if 
 end if 
 end if 
 case xPos > 50 
 if xPos < 120 then 
 clickCard = 1 
 else 
 clickCard = 0 
 end if 
 end select 
 if clickCard < 1 then 
 call RefreshCards hGbox, 1 
 call RefreshCards hGbox, 2 
 wait 
 end if 
 nCard = hand1(1, clickCard) 
 hand2(1, clickCard) = hand1(1, clickCard) 
 hand1(1, clickCard) = 0 
 call RefreshCards hGbox, 1 
 
 [computerDiscardsLikes] 
 ' Find all invisible cards 
 for i = 1 to 17 
 iC = iCards(i) 
 for j = 1 to 8 
 if hand2(1, j) = iC then 
 iCards(i) = 0 
 end if 
 if hand1(2, j) = iC then 
 iCards(i) = 0 
 end if 
 if hand2(2, j) = iC then 
 iCards(i) = 0 
 end if 
 next j 
 next i 
 sort iCards(), 17, 1 
 
 nChoices = 0 
 for i = 1 to 17 
 if iCards(i) > 0 then 
 nChoices = nChoices + 1 
 end if 
 next i 
 cValue = GetCardValue(hand2(1, clickCard)) 
 if cValue = 99 then 
 cValue = -1 
 end if 
 cSuit = GetCardSuit(hand2(1, clickCard)) 
 for i = 1 to 8 
 if GetCardValue(hand1(2, i)) = cValue then 
 call SetCardStatus hand1(2, i), 1 
 hand2(2, i) = hand1(2, i) 
 hand1(2, i) = 0 
 end if 
 if GetCardSuit(hand1(2, i)) = cSuit then 
 call SetCardStatus hand1(2, i), 1 
 hand2(2, i) = hand1(2, i) 
 hand1(2, i) = 0 
 end if 
 next i 
 
 call RefreshCards hGbox, 2 
 wait 
 
 
 sub Pause ms 
 calldll #kernel32,"Sleep", _ 
 ms as long, _ 
 result as void 
 end sub 
 
 sub InitializeDeck hGbox 
 open "qcard32.dll" for dll as #qc 
 calldll #qc, "InitializeDeck", _ 
 hGbox as ulong, _ 
 result as long 
 end sub 
 
 sub SetCardStatus nCard, face 
 'nC is number of card - 1-52 in first deck and 
 '53-104 in second deck, if used 
 'face: 0=facedown,1=faceup 
 calldll #qc, "SetCardStatus", _ 
 nCard as long,_ 
 face as long,_ 
 result as void 
 end sub 
 
 sub DealCard hGbox, nCard, xPos, yPos 
 'places card on window whose handle is hGbox at xPos, yPos 
 'nC is number of card - 1-52 in first deck and 
 '53-104 in second deck, if used 
 calldll #qc, "DealCard", _ 
 hGbox as ulong, _ 
 nCard as long,_ 
 xPos as long, _ 
 yPos as long, _ 
 result as void 
 end sub 
 
 sub RemoveCard hGbox,nCard 
 'removes a card from screen that was 
 'drawn with DealCard, replacing screen background 
 calldll #qc, "RemoveCard", _ 
 hGbox as ulong, _ 
 nCard as long, _ 
 result as void 
 end sub 
 
 sub SetCurrentBack nDesign 
 'nDesign can be 1,2,3,4,5,6 for 6 possible designs 
 calldll #qc, "SetCurrentBack", _ 
 nDesign as long, _ 
 result as void 
 end sub 
 
 sub RefreshCards hGbox, player 
 for i = 1 to 8 
 call RemoveCard hGbox, hand1(player, i) 
 call RemoveCard hGbox, hand2(player, i) 
 next i 
 if player = 1 then 
 #main.g "place 40 295; boxfilled 340 400" 
 yPos = 300 
 else 
 #main.g "place 40 45; boxfilled 340 150" 
 yPos = 50 
 end if 
 x1Pos = 50 
 x2Pos = 450 
 for i = 1 to 8 
 n1Card = hand1(player, i) 
 if n1Card > 0 then 
 call DealCard hGbox, n1Card, x1Pos, yPos 
 end if 
 n2Card = hand2(player, i) 
 if n2Card > 0 then 
 call DealCard hGbox, n2Card, x2Pos, yPos 
 end if 
 x1Pos = x1Pos + 30 
 x2Pos = x2Pos + 30 
 next i 
 end sub 
 
 sub InitCards 
 for i = 1 to 17 
 nCards(i) = dCards(i) 
 iCards(i) = dCards(i) 
 xCards(i) = dCards(i) 
 next i 
 end sub 
 
 sub ShuffleCards dealer 
 for i = 17 to 2 step -1 
 n = int(rnd(1) * i) + 1 
 temp = nCards(i) 
 nCards(i) = nCards(n) 
 nCards(n) = temp 
 next i 
 if dealer = 1 then 
 hand1 = 2 
 hand2 = 1 
 else 
 hand1 = 1 
 hand2 = 2 
 end if 
 ct = 0 
 for i = 1 to 15 step 2 
 ct = ct + 1 
 hand1(hand1, ct) = nCards(i) 
 hand1(hand2, ct) = nCards(i + 1) 
 hand2(hand1, ct) = 0 
 hand2(hand2, ct) = 0 
 next i 
 questCard = nCards(17) 
 end sub 
 
 sub NewDeal dealer, hGbox 
 xPos = 50 
 if dealer=1 then 
 hand1 = 2 
 hand2 = 1 
 vis1 = 0 
 vis1 = 1 ' Preserve computer CardStatus 0 for actual play 
 vis2 = 1 
 y1Pos = 50 
 y2Pos = 300 
 else 
 hand1 = 1 
 hand2 = 2 
 vis1 = 1 
 vis2 = 0 
 vis2 = 1 ' Preserve computer CardStatus to 0 for actual play 
 y1Pos = 300 
 y2Pos = 50 
 end if 
 for i = 1 to 8 
 call Pause 250 
 nCard = hand1(hand1, i) 
 call SetCardStatus nCard, vis1 
 call DealCard hGbox, nCard, xPos, y1Pos 
 call Pause 250 
 nCard = hand1(hand2, i) 
 call SetCardStatus nCard, vis2 
 call DealCard hGbox, nCard, xPos, y2Pos 
 xPos = xPos + 30 
 next i 
 call Pause 500 
 nCard = nCards(17) 
 ' Reset Middle (Guess) CardStatus to 1 for actual play 
 ' call SetCardStatus nCard, 0 
 Call DealCard hGbox, nCard, 162, 175 
 end sub 
 
 sub AnnounceDealer dealer 
 if dealer = 1 then 
 msg$ = "Your Deal" 
 else 
 msg$ = "Computer Deals" 
 end if 
 confirm msg$;yn$ ' Validates proper deal of cards 
 end sub 
 
 sub AnnouncePlayer playerTurn 
 if playerTurn = 1 then 
 msg$ = "Your Turn" 
 y = 420 
 else 
 msg$ = "Computer's Turn" 
 y = 40 
 end if 
 #main.g "stringwidth? msg$ width" 
 #main.g "place ";int(200 - width/2);" ";y 
 #main.g "\";msg$ 
 end sub 
 
 function GetCardSuit(nCard) 
 calldll #qc, "GetCardSuit", _ 
 nCard as long, _ 
 GetCardSuit as long 
 'returns 1=Clubs, 2=Diamonds, 3=Hearts, 4=Spades 
 end function 
 
 function GetCardValue(nCard) 
 calldll #qc, "GetCardValue", _ 
 nCard as long, _ 
 GetCardValue as long 
 'ace=1,deuce=2....jack=11,queen=12,king=13,joker=99 
 end function