home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Share Gallery 1
/
share_gal_1.zip
/
share_gal_1
/
GA
/
GA052.ZIP
/
LABELLE1.BAS
< prev
next >
Wrap
BASIC Source File
|
1988-07-20
|
11KB
|
281 lines
'La Belle Lucie by George Leotti, July 1988
DECLARE SUB DisplayCards ()
DECLARE SUB Shuffle ()
DECLARE SUB ClrLine (row%, x%)
DECLARE SUB Convert (r%, s%, r1%, s1%)
DECLARE SUB FindCard (r%, x%, w%, flag%)
DECLARE SUB LabHelp ()
DEFINT A-Z
COMMON SHARED r$, s$, cards, m$
DIM SHARED deck(52), pile(24), colr(3)
colr(0) = 4: colr(1) = 4: r$ = "A23456789TJQK": s$ = "HDCS"
xcolor = SCREEN(1, 1, 1): CALL LabHelp
Newgame:
COLOR 15, 2: CLS : cards = 52: deal = 2 'initialize vars for new game
FOR i = 1 TO 52: deck(i) = i: NEXT: FOR i = 1 TO 24: pile(i) = 0: NEXT
LOCATE 2, 7, 0: PRINT "La Belle Lucie": LOCATE 2, 59: PRINT "Deal Cards"
LOCATE 3, 60: PRINT deal: LOCATE 3, 68: PRINT cards
CALL Shuffle: CALL DisplayCards 'shuffle cards and deal them
Mainloop:
COLOR 15, 2: IF cards = 0 THEN GOTO Endhand 'a winner
LOCATE 24, 26: PRINT "(Q)uit (H)elp (S)huffle"; : GOSUB Decide 'get move
CALL Convert(rank, suit, rank1, suit1)
IF rank < 1 OR (LEN(m$) > 3 AND rank1 < 1) THEN x = 1: GOSUB Badmove
Movecard:
CALL FindCard(rank, x, w, 0)
IF w = 0 THEN x = 2: GOSUB Badmove 'card not on top of pile
Okay:
IF rank1 > 0 THEN
flag = 1: CALL FindCard(rank1, x1, w1, flag)
IF flag THEN x = flag: GOSUB Badmove
'okay to move card within tableau
pile(w1) = pile(w1) + 1: pile(w) = pile(w) - 1 'adjust piles
IF x > x1 THEN 'move card down in deck
FOR i = x TO x1 + 2 STEP -1
SWAP deck(i - 1), deck(i)
NEXT
ELSE 'move card up in deck
FOR i = x TO x1 - 1
SWAP deck(i + 1), deck(i)
NEXT
END IF
ELSE 'move card from tableau to foundation
IF rank - suit * 13 > 1 THEN 'move non-aces
FOR i = 20 TO 23
IF rank - pile(i) = 1 AND suit = pile(i) \ 13 THEN pile(i) = rank: EXIT FOR
NEXT
IF rank <> pile(i) THEN x = 6: GOSUB Badmove 'card can't go on foundation.
ELSE 'move aces
FOR i = 20 TO 23
IF pile(i) = 0 THEN pile(i) = rank: EXIT FOR
NEXT
END IF
pile(w) = pile(w) - 1: cards = cards - 1: deck(x) = 0
FOR j = x TO cards 'fix hole in deck
SWAP deck(j), deck(j + 1)
NEXT
'display foundation pile i
col = 28 + 6 * (i - 20): r = rank - suit * 13: COLOR colr(suit), 7
LOCATE 1, col: PRINT MID$(r$, r, 1); " "
LOCATE 2, col: PRINT CHR$(3 + suit); " "
LOCATE 3, col: PRINT " "; CHR$(3 + suit)
LOCATE 4, col: PRINT " "; MID$(r$, r, 1)
IF r = 13 THEN COLOR , 2: LOCATE 3, 9 + 2 * (i - 20): PRINT CHR$(3 + suit)
END IF
IF pile(w) = 0 THEN 'fix hole in tableau
FOR i = w TO 18
SWAP pile(i), pile(i + 1)
NEXT
END IF
COLOR 15, 2: LOCATE 3, 68: PRINT cards
IF MID$(m$, 3, 1) = "-" AND rank - suit * 13 < 13 THEN 'do range if not king
rank = rank + 1: GOTO Movecard 'do next card in range.
END IF
Entry: CALL DisplayCards: GOTO Mainloop
Reshuffle: 'check for reshuffle & legal draw on last reshuffle
IF deal = 0 THEN x = 7: GOSUB Badmove
CALL Shuffle: deal = deal - 1: LOCATE 3, 60: PRINT deal
CALL DisplayCards: IF deal THEN GOTO Mainloop 'not last shuffle
Reloop: 'get move on last shuffle
COLOR 15, 2: LOCATE 24, 26: PRINT "(Q)uit (H)elp (N)one ";
GOSUB Decide 'get move
IF LEN(m$) = 3 THEN m$ = LEFT$(m$, 2)
CALL Convert(rank, suit, rank1, suit1)
x = 0: IF rank < 1 OR (LEN(m$) > 3 AND rank1 < 1) THEN x = 1: GOSUB Badmove
FOR i = 1 TO cards 'get postion of card rank in tableau/pile
IF deck(i) = rank THEN x = i: w = x \ 3 + 1 + (x / 3 = x \ 3): EXIT FOR
NEXT: IF x = 0 THEN x = 2: GOSUB Badmove
GOTO Okay 'ok to move card
Endhand:
CALL ClrLine(6, 19) 'clear lower screen
IF cards = 0 THEN 'game won, flash suit symbols.
won = won + 1: LOCATE 3, 9
FOR i = 20 TO 23
T = pile(i) \ 13 - 1: COLOR 16 + colr(T), 2: PRINT CHR$(3 + T); " ";
NEXT: COLOR 15
ELSE
lost = lost + 1
END IF
LOCATE 7, 26: PRINT "You've won"; won; "game"; STRING$(ABS(won > 1 OR won = 0), 115);
PRINT " and lost"; lost; "game"; STRING$(ABS(lost > 1 OR lost = 0), 115); "."
LOCATE 9, 30: PRINT "Do you wish to play another?"
DO: m$ = UCASE$(INKEY$): LOOP WHILE INSTR(" YN", m$) < 2
IF m$ = "Y" THEN GOTO Newgame
Endgame:
COLOR xcolor MOD 16, xcolor \ 16: CLS : LOCATE , , 1: END
Decide: 'get moves and other input
CALL ClrLine(22, 1)
IF SCREEN(24, 41) = 78 THEN
COLOR 0, 2: PRINT "Enter a card to draw or move";
ELSE
PRINT "What is your move";
END IF
INPUT m$: m$ = UCASE$(m$): CALL ClrLine(22, 1): COLOR 15, 2
SELECT CASE m$
CASE "Q"
PRINT "Quit (G)ame or (H)and or (O)ops?"
DO: m$ = UCASE$(INKEY$): LOOP WHILE INSTR(" GHO", m$) < 2
IF m$ = "G" THEN RETURN Endgame
IF m$ = "H" THEN RETURN Endhand
GOTO Decide
CASE "N"
RETURN Mainloop
CASE "H"
SCREEN , , , 1: DO: LOOP WHILE INKEY$ = "": SCREEN , , , 0
COLOR 15, 2: GOTO Decide
CASE "S"
IF SCREEN(24, 41) = 78 THEN GOTO Decide
RETURN Reshuffle
CASE ELSE
IF LEN(m$) < 2 THEN x = 1: GOSUB Badmove
RETURN
END SELECT
Badmove: 'display errors
SELECT CASE x
CASE 1
e$ = "I don't understand your input.": rank = 0: rank1 = 0
CASE 2
e$ = MID$(r$, rank - suit * 13, 1) + CHR$(3 + suit) + " Is not available!"
CASE 3
e$ = "Kings can't be moved within the tableau!"
CASE 4
e$ = "Move any available ace to fondation."
CASE 5
e$ = MID$(r$, rank - suit * 13, 1) + CHR$(3 + suit) + " can NOT be moved to " + MID$(r$, rank1 - suit1 * 13, 1) + CHR$(3 + suit1) + "!"
CASE 6
e$ = MID$(r$, rank - suit * 13, 1) + CHR$(3 + suit) + " can not be moved to fondation!"
CASE 7
e$ = "No shuffles left!"
END SELECT
IF MID$(m$, 3, 1) = "-" AND SCREEN(24, 41) <> 78 THEN 'skip razz if end of range
x = INSTR(r$, LEFT$(m$, 1))
IF x - ABS(x > 13) * 13 <> rank - suit * 13 AND LEN(m$) = 3 THEN RETURN Entry
END IF
CALL ClrLine(22, 1): PRINT e$: SOUND 47, 5: 'print error then razz'em &
ti! = TIMER + 2: DO WHILE TIMER < ti!: LOOP 'wait around 2 seconds
IF SCREEN(24, 41) = 78 THEN RETURN Reloop
RETURN Mainloop
SUB ClrLine (row, x) 'erase x lines starting at row
LOCATE row, 1 'this sub saves around 5000 bytes over VIEW PRINT x to y: CLS!!
DO
PRINT STRING$(80, 32); : x = x - 1
LOOP WHILE x
LOCATE row, 7
END SUB
SUB Convert (r, s, r1, s1)
'convert move notation m$ to deck notation DECK(1-52), r is from r1 is to
r = INSTR(r$, LEFT$(m$, 1)): IF r = 0 THEN EXIT SUB 'get rank of from card
s = INSTR(s$, MID$(m$, 2, 1)) - 1 'get suit of from card
IF LEN(m$) > 3 THEN 'get rank & suit of to card
r1 = INSTR(r$, MID$(m$, 3, 1)): IF r1 = 0 THEN EXIT SUB
s1 = INSTR(s$, MID$(m$, 4, 1)) - 1
ELSE 'no to card.
s1 = 0: r1 = 0
END IF
r = s * 13 + r: r1 = s1 * 13 + r1 'value of card, 1-52
END SUB
SUB DisplayCards 'display tableau
CALL ClrLine(6, 14): i = 1: x = pile(1): c = 1: row = 6: col = 10
DO WHILE x
FOR j = 0 TO x - 1: d = deck(c + j) 'get card number
suit = d \ 13 + (d \ 13 = d / 13) 'cange it to suit
m$ = MID$(r$, d - suit * 13, 1) '& rank
COLOR colr(suit), 7
LOCATE row, col + j: PRINT m$ 'display suit/rank (upper left corner)
LOCATE row + 1, col + j: PRINT CHR$(3 + suit) 'of each card in pile
NEXT: x$ = STRING$(3 + x, 32)
LOCATE row, col + j: PRINT " " 'display rest of pile.
LOCATE row + 1, col + j: PRINT " "
LOCATE row + 2, col: PRINT x$; CHR$(3 + suit)
LOCATE row + 3, col: PRINT x$; m$
i = i + 1: col = col + 5 + x: c = c + j: x = pile(i)
IF col + x + 4 > 75 THEN col = 10: row = row + 5
LOOP
END SUB
SUB FindCard (r, x, w, flag)
SHARED rank, suit, rank1, suit1
x = 0: w = 0
FOR i = 1 TO 18 'check top card for a match with r (rank or rank1)
x = x + pile(i)
IF deck(x) = r THEN w = i: EXIT FOR
NEXT
IF flag = 0 THEN EXIT SUB 'exits when r=rank
IF w = 0 THEN rank = rank1: suit = suit1: flag = 2: EXIT SUB
IF rank - suit * 13 = 13 THEN flag = 3: EXIT SUB
IF rank - suit * 13 = 1 THEN flag = 4: EXIT SUB
IF rank1 - rank <> 1 THEN flag = 5: EXIT SUB
flag = 0
END SUB
SUB LabHelp
'put help screen on SCREEN 1
WIDTH 80, 25: SCREEN 0, , 1, 0: COLOR 15, 1: CLS
PRINT " The object of La Belle Lucie is to move all cards from the tableau to the"
PRINT "foundation in ascending order, Ace through King according to suit."
PRINT : PRINT " Initially 18 piles are dealt to the tableau. 17 piles of three cards each,"
PRINT "and 1 pile with 1 card. Cards my be moved within the tableau in descending"
PRINT "order, according to suit. You may move only the TOP (right-most) card in any"
PRINT "pile to the foundation, or to another top card in the tableau. Kings can only"
PRINT "be moved to their respective foundation piles."
PRINT : PRINT " Moves are entered as simple abbreviations of the card to be moved. For"
PRINT "example: '7S8S' means move 7 of Spade to 8 of Spade. 'AC' means move Ace of Club";
PRINT "to a foundation pile. If you have a run of cards, say 2 through 6 of Hearts that";
PRINT "can be moved to a foundation pile, you may enter it as '2H-'."
PRINT
PRINT " You are allowed two reshuffles after the first deal. On your final shuffle"
PRINT "you may move any one card from anywhere in a tableau pile to the foundation, or"
PRINT "to a top card in the tableau according to the above rules. Enter an 'S' alone"
PRINT "at the prompt to shuffle the cards."
PRINT
PRINT " You may quit a game, or hand, by typing 'Q' at the 'What's your next move'"
PRINT "prompt. Enter 10's as 'T'. Any letters entered may be in UPPER, or lower, case."
PRINT : PRINT , , "<Press any key to resume game>": SCREEN , , 0, 0
'opening screen...
COLOR 15, 2: CLS : LOCATE 19, 29, 0: c = 2
PRINT "Press any key to begin."
COLOR 0: LOCATE 21, 65
PRINT "Programmed by": LOCATE , 65: PRINT "George Leotti"
LOCATE , 65: PRINT "with Microsoft": LOCATE , 65: PRINT "QuickBASIC 4.0";
FOR i = 3 TO 6
LOCATE 11, 30 + i + (i - 3): COLOR 16 + colr(i - 3): PRINT CHR$(i)
LOCATE 13, 37 + i + (i - 3): COLOR 16 + colr((9 - i) - 3): PRINT CHR$(9 - i)
NEXT
DO
LOCATE 12, 33
FOR i = 1 TO 15
COLOR colr(ABS(c \ 2 = c / 2) + 1): IF c = 2 THEN c = 3 ELSE c = 2
PRINT MID$("La Belle Lucie ", i, 1);
NEXT
ti! = TIMER + .2: DO WHILE TIMER < ti!: LOOP
LOOP WHILE INKEY$ = ""
END SUB
SUB Shuffle
CALL ClrLine(22, 1): PRINT "Shuffling cards...": RANDOMIZE TIMER
FOR j = 1 TO 2 + INT(RND * 3 + 1) 'number of times to mix
FOR i = 1 TO cards 'mix'em
SWAP deck(INT(RND * cards + 1)), deck(INT(RND * cards + 1))
NEXT
NEXT
FOR i = 1 TO cards \ 3
pile(i) = 3 '3 cards in each pile
NEXT
pile(i) = cards MOD 3 'last pile gets remainder
pile(i + 1) = 0 'end of piles
END SUB