(* * LANGUAGE : ANS Forth with extensions * PROJECT : Forth Environments * DESCRIPTION : Romanian Whist * CATEGORY : Card game * AUTHOR : Marcel Hendrix * LAST CHANGE : Sunday, January 04, 2004 9:17 PM, Marcel Hendrix * LAST CHANGE : Friday, January 09, 2004 2:12 PM, Marcel Hendrix; first version works * LAST CHANGE : Friday, January 09, 2004 9:29 PM, Marcel Hendrix; check in HUMAN-ANSWER * LAST CHANGE : Monday, January 12, 2004 8:08 PM, Marcel Hendrix; bug in dealing fixed, added SAVE/LOAD * LAST CHANGE : Tuesday, January 13, 2004 7:39 AM, Marcel Hendrix; bug in dealing fixed again * LAST CHANGE : Tuesday, January 13, 2004 10:45 PM, Marcel Hendrix; non-scrolling, fixed numerous small bugs *) NEEDS -miscutil REVISION -whist "ÄÄÄ Whist card game Version 1.00 ÄÄÄ" PRIVATES DOC (* Additions --------- ANSWER-CARD should use information of all the cards shown up to that point to make a decision. For instance, when the last of a card is played, the computer can choose a relatively low suit or trump to play, saving higher-valued cards for a coming round. It can also play a high-valued suit or trump instead of a lower value when it wants to loose this or future tricks. Strategy -------- To change strategy, it only should be necessary to modify BIDDER, SELECT-BEST-CARD SELECT-WORST-CARD ANSWER-BEST-CARD and ANSWER-WORST-CARD. The simplest strategy is: 1. bid a random, but reasonable, contract (e.g. /players #cards /) 2. come out with one's highest-valued cards as long as this contract is not fulfilled, the lowest valued once it is, 3. play one's highest-valued cards as long as the contract is not fulfilled, the lowest values once it is. Obvious improvements: a) Bidding: Take other contracts into account. One can assume that the sum of contracts at that point is likely to be made, so bid lower than #cards - sum. Contracts that are likely/unlikely to be possible can be spotted by inspecting one's own cards (e.g. having all high trumps and coming out, it is impossible to lose a trick). b) When trying to lose a trick, play the highest-valued card (instead of the lowest) that is lower than the ones at the table already (or the highes non-equal-suit card!). When trying to make a trick, play the highest-valued card, unless it is clear that the trick CAN'T be yours (then play the lowest one). To do this it is necessary to remember all the cards played so far, and by whom, so it is possible to "guess" the probability of cards to be played by the next-ones-in-line. Program Bugs ------------ None. *) ENDDOC -- Tools ------------------------------------------------------------------------------------------------------ :INLINE CEXCH ( addr1 addr2 -- ) OVER C@ OVER C@ SWAP ROT C! SWAP C! ; -- A simple bubble sort. : BUBBLE ( c-addr u -- ) DUP 2 < IF 2DROP EXIT ENDIF LOCALS| #elements 'list | #elements 1 DO 'list #elements I - BOUNDS DO I C@ I 1+ C@ 2DUP > IF I C! I 1+ C! ELSE 2DROP ENDIF LOOP LOOP ; -- Data ------------------------------------------------------------------------------------------------------- 6 =: /maxplayers PRIVATE \ Actually it's 8 players, but we'd need to decks :-) 3 =: /minplayers PRIVATE \ I don't know why, it's in the rules 8 =: /cards PRIVATE \ rule .. 0 VALUE #player PRIVATE \ The player that is currently leading 0 VALUE /players PRIVATE \ r/o The number of players we actually have. 0 VALUE #deal PRIVATE \ The current deal number ( 0 .. /deals ) 0 VALUE /deals PRIVATE \ r/o How many times we deal ( depends on /players ) 0 VALUE #evals PRIVATE \ The size of []evals, how many cards are down in this deal already 0 VALUE #bids PRIVATE \ how many bids have been done already 0 VALUE trumps PRIVATE \ the suit being trumps -- Size of data maintained for each player. =CELL ( score) /cards 1+ + ( count + cards) 1+ ( bid) 1+ ( tricks) 1+ =: /info ( 10?) PRIVATE CREATE []deals PRIVATE /maxplayers 3 * #12 + ALLOT -- r/o stores # of cards in each deal CREATE []deck PRIVATE /maxplayers /cards * ALLOT -- r/o the cards in the deck, copy to "data" CREATE []evals PRIVATE /maxplayers ALLOT -- the cards down in the current deal CREATE data PRIVATE /maxplayers /info * ALLOT -- data for all players FALSE VALUE verbose? -- Turn on for more output FALSE VALUE human? -- let a human serve as player #1 -- Save/Load -------------------------------------------------------------------------------------------------- 0 VALUE handle PRIVATE : $>file ( addr u -- ) handle WRITE-FILE ?FILE ;P : w>file ( addr -- ) 1 CELLS $>file ;P : file>$ ( addr u -- ) handle READ-FILE ?FILE DROP ;P : file>w ( addr -- ) 1 CELLS file>$ ;P -- Use with RESTART-WHIST : $SAVE-GAME ( c-addr u -- ) R/W BIN CREATE-FILE SWAP TO handle IF CR ." couldn't save this whist game." EXIT ENDIF 'OF #player w>file 'OF /players w>file 'OF #deal w>file 'OF /deals w>file 'OF #evals w>file 'OF #bids w>file 'OF trumps w>file 'OF verbose? w>file 'OF human? w>file []deals /maxplayers 3 * #12 + $>file []deck /maxplayers /cards * $>file []evals /maxplayers $>file data /maxplayers /info * $>file handle CLOSE-FILE ?FILE ;P : $LOAD-GAME ( c-addr u -- ) R/O BIN OPEN-FILE SWAP TO handle IF CR ." no saved game (whist.dat) found." EXIT ENDIF 'OF #player file>w 'OF /players file>w 'OF #deal file>w 'OF /deals file>w 'OF #evals file>w 'OF #bids file>w 'OF trumps file>w 'OF verbose? file>w 'OF human? file>w []deals /maxplayers 3 * #12 + file>$ []deck /maxplayers /cards * file>$ []evals /maxplayers file>$ data /maxplayers /info * file>$ handle CLOSE-FILE ?FILE ;P : SAVE-GAME ( -- ) S" whist.dat" $SAVE-GAME ; : LOAD-GAME ( -- ) S" whist.dat" $LOAD-GAME ; -- Some macro's ----------------------------------------------------------------------------------------------- :INLINE []score ( player -- addr ) /info * data + ; PRIVATE -- number of points scored :INLINE []hands ( player -- addr ) []score CELL+ ; PRIVATE -- cards a player holds + count :INLINE []hands+ ( player -- addr ) []score CELL+ 1+ ; PRIVATE -- cards a player holds :INLINE []bid ( player -- addr ) []hands+ /cards + ; PRIVATE -- what player bid :INLINE []tricks ( player -- addr ) []bid 1+ ; PRIVATE -- the number of tricks acquired :INLINE []10? ( player -- addr ) []tricks 1+ ; PRIVATE -- 10 consecutive tricks earn 30 points extra :INLINE @cards ( ix -- cards ) []hands C@ ; PRIVATE -- # cards a player has :INLINE =player ( ix -- p ) #player + /players MOD ; PRIVATE -- makes player the reference point :INLINE >suit ( u -- s ) 5 RSHIFT ; PRIVATE -- isolate a card's suit :INLINE suit> ( s -- u ) 5 LSHIFT ; PRIVATE -- move a suit into position for a card :INLINE >val ( u -- s ) $0F AND ; PRIVATE -- isolate a card's value -- Initialization --------------------------------------------------------------------------------------------- -- Prepare "data" for first use : INIT-DATA ( -- ) data /maxplayers /info * ERASE /maxplayers 0 DO #255 I []bid C! LOOP ;P -- Prepare the deck of cards for first use, but don't shuffle or deal. : INIT-DECK ( -- ) []deck /maxplayers /cards * ERASE []deck 4 0 DO /players /cards * 4 / #15 SWAP - #15 SWAP DO J suit> I OR OVER C! 1+ LOOP LOOP DROP ;P -- Work out how many times to deal and how many cards per deal. : INIT-DEALS ( -- ) []deals /players 0 DO 1 OVER C! CHAR+ LOOP 8 2 DO I OVER C! CHAR+ LOOP /players 0 DO 8 OVER C! CHAR+ LOOP 2 7 DO I OVER C! CHAR+ -1 +LOOP /players 0 DO 1 OVER C! CHAR+ LOOP DROP ;P -- Remove card ix from a []hand and return it. : REMOVE-CARD ( c-addr ix -- removed_card ) OVER 1+ LOCALS| 'str ix 'cnt | 'str ix + 'str 'cnt C@ 1- + DUP >S CEXCH -1 'cnt C+! S> C@ ;P -- Status ----------------------------------------------------------------------------------------------------- : .FACE ( ix -- ) CASE #11 OF ." J " ENDOF #12 OF ." Q " ENDOF #13 OF ." K " ENDOF #14 OF ." A " ENDOF ." ? " ENDCASE ;P 1 [IF] : .SUIT ( color -- ) DUP 4 < IF 3 + EMIT ELSE ." ?" ENDIF ;P [ELSE] : .SUIT ( color -- ) CASE 0 OF ." h" ENDOF ( hearts) 1 OF ." d" ENDOF ( diamonds) 2 OF ." c" ENDOF ( clubs) 3 OF ." s" ENDOF ( spades) ." ?" ENDCASE ;P [THEN] : .CARD ( index[3..14] -- ) DUP >suit .SUIT >val DUP #11 < IF DUP DEC. #10 < IF SPACE ENDIF ELSE .FACE ENDIF ;P : .TRUMP ( -- ) trumps $FF = IF ." -" ELSE trumps .SUIT ENDIF ;P : .BID ( ix -- ) []bid C@ DUP #255 = IF DROP ." ? " ELSE 2 .R SPACE ENDIF ;P : STATUS(i) ( ix -- ) CR 3 SPACES DUP 1+ 0DEC.R ." : " DUP 0<> human? AND IF 0 >S ELSE DUP []hands COUNT 2DUP BUBBLE >S S BOUNDS ?DO I C@ .CARD LOOP ENDIF /cards S> - 0 ?DO ." --- " LOOP SPACE DUP .BID 5 SPACES DUP []tricks C@ 0DEC.R 3 SPACES DUP []score @ 4 .R 6 SPACES ( ix) []10? C@ DEC. ;P : .EVALS ( -- ) 0 5 /players + AT-XY EOL ." Cards down: " #evals 0 ?DO ." player" I =player 1+ 0 .R ." > " []evals I + C@ .CARD LOOP ;P : .BIDS ( -- ) 0 6 /players + AT-XY EOL ." Bids down: " #bids 0 ?DO ." player" I =player 1+ 0 .R ." > " I =player .BID SPACE LOOP ;P : .STATUS ( -- ) HOME >INVERSE< ." player deal cards to play trumps verbose human " >INVERSE< CR 2 SPACES #player 1+ 0DEC.R ." /" /players 0DEC.R 6 SPACES #deal 1+ 0DEC.R ." /" /deals 0DEC.R #10 SPACES #deal []deals + C@ 0DEC.R #13 SPACES .TRUMP 8 SPACES verbose? IF ." ON" ELSE ." OFF" ENDIF 7 SPACES human? IF ." ON" ELSE ." OFF" ENDIF CR >INVERSE< ." player cards bids tricks score 10games? " >INVERSE< /players 0 DO I STATUS(i) LOOP CR >INVERSE< ." " >INVERSE< human? IF .EVALS .BIDS ENDIF ;P -- Help ------------------------------------------------------------------------------------------------------- : HHELP CR CR ." Type HELP-PLAYERS HELP-CARDS HELP-DEAL " CR ." HELP-BID HELP-PLAY or HELP-SCORE for more info." ;P WARNING @ WARNING OFF : HELP CR ." Romanian Whist" CR ." --------------" CR ." This game is similar to the English or American game Oh Hell! It is currently popular" CR ." in Romania, and there it is called Whist. This description was first contributed by" CR ." Werner Hintze, and Dan Vasilesu, Paul Cretu and Toma Alexandru supplied additions and" CR ." corrections." HHELP ; WARNING ! : HELP-PLAYERS CR ." The Players" CR ." -----------" CR ." This is a game for 3 to 6 players. Each player plays alone." HHELP ; : HELP-CARDS CR ." The Cards" CR ." ---------" CR ." From a standard pack use 8 cards for every player (24 for 3 players, 32 for 4 players" CR ." and so on). The cards rank as usual: A, K, Q, J, 10, 9, [8, 7...] They have no value," CR ." because it is a game for tricks only." HHELP ; : HELP-DEAL CR ." The Deal" CR ." --------" CR ." The first dealer is chosen at random. Then the turn to deal rotates clockwise after" CR ." each hand." CR CR ." The number of cards dealt to each player varies during the game. For the first few" CR ." deals each player gets only one card. This continues for as many deals as there are" CR ." players." CR CR ." After this the number of cards dealt to each player increases by one with every deal" CR ." until eventually all the cards are dealt, that is 8 cards each. Then as many deals" CR ." are played with 8 cards each as there are players." CR CR ." Then the number of cards dealt decreases again until every player gets only one card." CR ." Once more there are as many deals with one card each as there are players." CR CR ." Example: With 4 players the whole game would consist of 24 deals, and the number " CR ." of cards dealt each time would be as follows:" CR ." 1, 1, 1, 1, 2, 3, 4, 5, 6, 7, 8, 8, 8, 8, 7, 6, 5, 4, 3, 2, 1, 1, 1, 1. " CR CR ." After the cards are dealt, the next card is put face up; the suit of this card is" CR ." trump. In the games with 8 cards there is no card left to turn, and these games are" CR ." played without trumps." HHELP ; : HELP-BID CR ." The Bidding" CR ." -----------" CR ." Every player in order, beginning with the player to dealer's left, says how many" CR ." tricks he thinks he will get. The sum of all tricks bid must not be the same as the" CR ." number of cards dealt to each player. (Example: game with four cards, three players:" CR .~ The first player says "2", the next "1". The third player mustn't say "1", because~ CR ." that would make the sum of the tricks 4. He MUST say 0, 2, 3 or 4)." CR CR ." The rule that the bids must not add up to the number of cards dealt ensures that " CR ." not everyone will succeed in their bid, but puts the dealer at a disadvantage, " CR ." especially when only one card is dealt. It is for this reason that everyone must" CR ." take a turn at dealing one-card hands at the beginning and end of the sequence of" CR ." hands." HHELP ; : HELP-PLAY CR ." The Play" CR ." --------" CR ." The player to dealer's left plays the first card. The other players must play a " CR ." card of the same suit if possible. Any player who has no card of the suit led must" CR ." play a trump if they can. A player who has no cards of the suit led and no trumps" CR ." can discard any card. The trick is won by whoever played the highest trump, or if" CR ." no trump was played, by whoever played the highest card of the suit led. The winner" CR ." of the trick leads to the next." CR CR ." The objective is to win exactly the number of tricks you said you would win." HHELP ; : HELP-SCORE CR ." The scoring" CR ." -----------" CR ." The hand ends when all cards are played." CR CR ." * The players who made their contract (exactly) get 5 points plus the number" CR ." of tricks they made." CR ." * If you take fewer tricks than you bid you lose one point for each undertrick." CR ." * If you take more tricks than you bid you lose one point for each overtrick." CR CR ." Examples: Suppose you bid 3 tricks. If you take exactly 3 you will win 8" CR ." points (5+3). If you take only two tricks you lose 1 point; the same if" CR ." you take 4 tricks. If you take 1 or 5 tricks (two different from your bid)" CR ." you will lose 2 points; if you take no tricks or 6 tricks you will lose 3." HHELP ; -- Compare cards ---------------------------------------------------------------------------------------------- -- 1 is better than 2 when: -- suit1 == suit2 AND value1 > value2 OR -- suit1 == trumps AND suit2 <> trumps : BETTER? ( card1 card2 -- bool ) DUP >suit LOCAL suit2 >val LOCAL value2 DUP >suit LOCAL suit1 >val LOCAL value1 suit1 suit2 = value1 value2 > AND suit1 trumps = suit2 trumps <> AND OR ;P -- 1 is worse than 2 when 2 is better than 1 : WORSE? ( card1 card2 -- bool ) SWAP BETTER? ;P -- 1 is higher than 2 when: -- suit1 <> trumps AND suit2 <> trumps AND value1 > value2 OR -- suit1 == trumps AND suit2 <> trumps OR -- suit1 == trumps AND suit2 == trumps AND value1 > value2 : HIGHER? ( card1 card2 -- bool ) DUP >suit LOCAL suit2 >val LOCAL value2 DUP >suit LOCAL suit1 >val LOCAL value1 suit1 trumps <> suit2 trumps <> AND value1 value2 > AND suit1 trumps = suit2 trumps <> AND OR suit1 trumps = suit2 trumps = AND value1 value2 > AND OR ;P -- 1 is lower than 2 when 2 is higher than 1 : LOWER? ( card1 card2 -- bool ) SWAP HIGHER? ;P -- Intelligence: Select ======================================================================================= : SELECT-BEST-CARD ( ix -- card ) DUP @cards 0 0 LOCALS| winner best #cards ix | ix []hands+ C@ TO best #cards 1 ?DO ix []hands+ I + C@ DUP best HIGHER? IF TO best I TO winner ELSE DROP ENDIF LOOP ix []hands winner REMOVE-CARD ;P : SELECT-WORST-CARD ( ix -- card ) DUP @cards 0 0 LOCALS| winner worst #cards ix | ix []hands+ C@ TO worst #cards 1 ?DO ix []hands+ I + C@ DUP worst LOWER? IF TO worst I TO winner ELSE DROP ENDIF LOOP ix []hands winner REMOVE-CARD ;P : AUTO-SELECT ( ix -- card ) verbose? IF CR ." Player #" DUP 1+ DEC. ENDIF DUP []tricks C@ OVER []bid C@ >= IF verbose? IF ." leads worst: " ENDIF SELECT-WORST-CARD ELSE verbose? IF ." leads best: " ENDIF SELECT-BEST-CARD ENDIF verbose? IF DUP .CARD ENDIF ;P : HUMAN-SELECT ( ix -- card ) LOCAL ix .STATUS BEGIN CR ." Lead> " EOS PAD 8 ACCEPT PAD SWAP >FLOAT DROP F>S DUP 0< ABORT" tired" DUP ix []hands C@ U>= WHILE DROP REPEAT ix []hands SWAP REMOVE-CARD ;P : SELECT-CARD ( ix -- card ) DUP 0= human? AND IF HUMAN-SELECT EXIT ENDIF AUTO-SELECT ;P -- Intelligence: Answer ======================================================================================= -- The "best card" is a card2 in your hand where -- suit2 == suit1 AND value2 is maximum ( when our maximum > all cards already there ) -- suit2 == suit1 AND value2 is minimum ( when our maximum < all cards already there ) -- suit2 == trumps AND value2 is maximum ( must lay down trump if one is available, we can make it ) -- suit2 == trumps AND value2 is minimum ( must lay down trump if one is available, we can't make it ) -- suit2 DC, lowest value -- In this case we must check ALL cards put down at this point. : GET-BEST-SUIT ( -- card ) []evals C@ DUP >suit OVER >val LOCALS| val suit card | #evals 0 ?DO []evals I + C@ DUP >suit suit = IF DUP >val val > IF TO card ELSE DROP ENDIF ELSE DROP ENDIF LOOP card ;P : GET-BEST-TRUMP #-254 #-254 LOCALS| card val | #evals 0 ?DO []evals I + C@ DUP >suit trumps = IF DUP >val val > IF DUP TO card >val TO val ELSE DROP ENDIF ELSE DROP ENDIF LOOP card ;P : ANSWER-BEST-CARD ( ix -- card2 ) DUP @cards 0 0 0 0 []evals C@ >suit LOCALS| suit1 windex bindex worst best #cards ix | -1 TO windex #255 TO worst -1 TO bindex GET-BEST-SUIT >val TO best #cards 0 ?DO ix []hands+ I + C@ DUP DUP >suit suit1 = SWAP >val worst < AND IF DUP >val TO worst I TO windex ENDIF DUP >suit suit1 = OVER >val best >val > AND IF >val TO best I TO bindex ELSE DROP ENDIF LOOP bindex -1 <> IF ix []hands bindex REMOVE-CARD EXIT ENDIF windex -1 <> IF ix []hands windex REMOVE-CARD EXIT ENDIF -1 TO windex #255 TO worst -1 TO bindex GET-BEST-TRUMP >val TO best #cards 0 ?DO ix []hands+ I + C@ DUP DUP >suit trumps = SWAP >val worst < AND IF DUP >val TO worst I TO windex ENDIF DUP >suit trumps = OVER >val best > AND IF >val TO best I TO bindex ELSE DROP ENDIF LOOP bindex -1 <> IF ix []hands bindex REMOVE-CARD EXIT ENDIF windex -1 <> IF ix []hands windex REMOVE-CARD EXIT ENDIF -1 TO windex #255 TO worst #cards 0 ?DO ix []hands+ I + C@ DUP >val worst < IF >val TO worst I TO windex ELSE DROP ENDIF LOOP ix []hands windex REMOVE-CARD ;P -- The "worst card" is a card2 in your hand where -- suit2 == suit1 AND value2 is minimum ( because we can't deny having the suit ) -- suit2 == trumps AND value2 is maximum ( must acknowledge having trumps, higher is better! ) -- else return the highest possible value -- ( not implemented ) suit2 == suitX AND val2-valX < 0 and minimal, where X is GET-BEST-SUIT -- In this case we only need to know the suit of the card the current player put down, the others don't matter. : ANSWER-WORST-CARD ( ix -- card ) DUP @cards 0 0 0 []evals C@ >suit LOCALS| suit1 index worst best #cards ix | -1 TO index #255 TO worst #cards 0 ?DO ix []hands+ I + C@ DUP DUP >suit suit1 = SWAP >val worst < AND IF >val TO worst I TO index ELSE DROP ENDIF LOOP index -1 <> IF ix []hands index REMOVE-CARD EXIT ENDIF -1 TO index #-255 TO best #cards 0 ?DO ix []hands+ I + C@ DUP DUP >suit trumps = SWAP >val best > AND IF >val TO best I TO index ELSE DROP ENDIF LOOP index -1 <> IF ix []hands index REMOVE-CARD EXIT ENDIF -1 TO index #-255 TO best #cards 0 ?DO ix []hands+ I + C@ DUP >val best > IF >val TO best I TO index ELSE DROP ENDIF LOOP ix []hands index REMOVE-CARD ;P : AUTO-ANSWER ( ix -- card ) verbose? IF CR ." Player #" DUP 1+ DEC. ENDIF DUP []tricks C@ OVER []bid C@ >= IF verbose? IF ." plays worst: " ENDIF ANSWER-WORST-CARD ELSE verbose? IF ." plays best: " ENDIF ANSWER-BEST-CARD ENDIF verbose? IF DUP .CARD ENDIF ;P : HUMAN-ANSWER ( ix -- card ) []evals C@ >suit 0 LOCALS| suit/trump color ix | 0 ix []hands COUNT BOUNDS ?DO I C@ >suit DUP trumps = SWAP color = OR OR LOOP TO suit/trump .STATUS BEGIN BEGIN CR ." Card> " EOS PAD 8 ACCEPT PAD SWAP >FLOAT DROP F>S DUP 0< ABORT" tired" DUP ix []hands C@ U>= WHILE DROP REPEAT suit/trump IF DUP ix []hands+ + C@ >suit DUP trumps = SWAP color = OR 0= ELSE FALSE ENDIF WHILE DROP ." <- you DO have a suit/trump!" REPEAT ix []hands SWAP REMOVE-CARD ;P : ANSWER-CARD ( ix -- card ) DUP 0= human? AND IF HUMAN-ANSWER EXIT ENDIF AUTO-ANSWER ;P -- Intelligence: Bid ========================================================================================== -- Note that for the 8-card tricks there is no trump and all cards are in the game. -- This means that much smarter bidding is possible. : AUTO-BID ( ix -- card ) @cards 1+ /players / 3 CHOOSE 1- + ABS ;P : HUMAN-BID ( ix -- card ) LOCAL ix .STATUS BEGIN CR ." Bid> " EOS PAD 8 ACCEPT PAD SWAP >FLOAT DROP F>S DUP 0< ABORT" tired" DUP ix []hands C@ U> WHILE DROP REPEAT ;P : BIDDER ( ix -- choice ) DUP 0= human? AND IF HUMAN-BID EXIT ENDIF AUTO-BID ;P -- Mechanical tasks ------------------------------------------------------------------------------------------- : SHUFFLE-CARDS ( -- ) /players /cards * LOCAL /deck /deck 0 ?DO I []deck + /deck CHOOSE []deck + CEXCH LOOP ;P : DEAL-CARDS ( -- ) #deal []deals + C@ LOCAL #cards /players 0 DO I #cards * []deck + I []hands+ #cards MOVE #cards I []hands C! LOOP #cards 8 = IF $FF ELSE /players #cards * []deck + C@ >suit ENDIF TO trumps /players 0 DO I []hands COUNT BUBBLE LOOP ;P : BID ( -- ) #deal []deals + C@ 0 LOCALS| sum #cards | CLEAR #bids /players 0 DO #255 I []bid C! I []tricks C0! LOOP /players 0 DO I =player BIDDER 1 +TO #bids I /players 1- = IF DUP sum + #cards = IF verbose? IF 0 #12 /players 2* + AT-XY EOL ." Error: The bid " DUP DEC. ." of player #" I =player 1+ DEC. ." made the sum of bids (" sum 0DEC.R ." ) equal to #cards (" #cards 0DEC.R ." )." #1000 MS ENDIF 1- DUP 0< IF 2+ ENDIF ENDIF ENDIF DUP I =player []bid C! +TO sum LOOP ;P : SCORE ( -- ) /players 0 DO I []bid C@ I []tricks C@ 2DUP = IF DROP 5 + 1 I []10? C+! ELSE I []10? C0! - ABS NEGATE ENDIF I []score +! I []10? C@ #10 = IF #30 I []score +! I []10? C0! 0 #12 /players 2* + AT-XY EOL ." Message: player #" I 1+ DEC. ." obtains 30 extra points" #1000 MS ENDIF LOOP ;P : WON? ( -- score ix ) 0 #-10000000 LOCALS| most index | /players 0 DO I []score @ DUP most > IF TO most I TO index ELSE DROP ENDIF LOOP most index ;P : EVAL-CARDS ( -- ix ) []evals C@ 0 LOCALS| winner best | /players 1 DO []evals I + C@ DUP best BETTER? IF TO best I TO winner ELSE DROP ENDIF LOOP winner =player 1 OVER []tricks C+! ;P : DO-ONE-CARD ( -- ) CLEAR #evals verbose? IF .STATUS CR EOL CR EOL ENDIF #player SELECT-CARD []evals C! 1 TO #evals /players 1 DO I =player ANSWER-CARD []evals I + C! 1 +TO #evals LOOP EVAL-CARDS ( -- winner ) human? IF .STATUS 0 8 /players 2* + AT-XY EOL ." .. therefore player #" DUP 1+ DEC. ." wins this trick." ENDIF ( -- winner ) TO #player CLEAR #evals human? IF 0 #10 /players 2* + AT-XY EOL ." [press SPACE to continue] " EKEY DROP ENDIF ;P : PLAY-ROUND ( -- ) BID #deal []deals + C@ 0 ?DO DO-ONE-CARD LOOP SCORE verbose? IF .STATUS ENDIF ;P -- Restart works after all variables have been restored. : RESTART-WHIST ( -- ) #player LOCAL oldplayer /deals #deal DO SHUFFLE-CARDS I TO #deal DEAL-CARDS #player TO oldplayer PLAY-ROUND verbose? IF 0 #10 /players 2* + AT-XY EOL ." [press ESC to stop] " EKEY ESC = ?LEAVE ENDIF oldplayer 1+ /players MOD TO #player LOOP CR EOL ." Player #" WON? 1+ DEC. ." wins with " DEC. ." points." ; : WHIST ( +u -- ) DUP /minplayers U< ABORT" more players needed" DUP /maxplayers U> ABORT" too many players" TO /players /players CHOOSE TO #player INIT-DECK /players 3 * #12 + TO /deals CLEAR #deal INIT-DEALS INIT-DATA RESTART-WHIST ; :ABOUT HELP CR CR ." Try: <+u> WHIST -- +u == number of players." CR ." HELP -- more information" CR ." TO verbose? -- turn on/off debug messages (" verbose? IF ." ON)" ELSE ." OFF)" ENDIF CR ." TO human? -- Player #1 is human (" human? IF ." ON)" ELSE ." OFF)" ENDIF CR .~ SAVE-GAME -- save game in "whist.dat"~ CR .~ LOAD-GAME -- load game from "whist.dat"~ CR ." RESTART-WHIST -- restarts a loaded game" ; .ABOUT -whist CR DEPRIVE (* End of Source *)