home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload
/
ShartewareOverload.cdr
/
games
/
basic-1.zip
/
SOLITAIR.BAS
< prev
next >
Wrap
BASIC Source File
|
1987-10-30
|
13KB
|
315 lines
10 REM $LINESIZE:132
20 REM ----------------------------------------------------------------------
30 REM
40 REM The Game of Klondyke Solitar
50 REM By: Jeff Littlefield
60 REM For: the IBM PC and the Color Graphics Card
70 REM
80 REM FOR PUBLIC USE MAY NOT BE SOLD
90 REM ALL RIGHTS RESERVED
100 REM
110 REM Modified by Ken Handzik 11/27/83 to display card suits
120 REM Revised by Jeff Littlefield 2/2/84 to give better instructions
130 REM ---------------------------------------------------------------------
140 DEFINT A-Z
150 FALSE=0:TRUE = NOT FALSE : ABORT = FALSE : WON = FALSE : PARDON$="Pardon me while I shuffle the deck."
160 DIM DECK$(52), STACK$(7,21),CARD$(52),TOP$(4),STACKPTR(7),VISIPTR(7),XYARR$(82)
170 NOT.READ=TRUE
180 SCREEN 0,1,0,0:KEY OFF:COLOR 7,1,1:CLS
190 PRINT "Would You Like Instructions? ";
200 A$=INKEY$:IF A$="" THEN 200 ELSE IF A$="y" OR A$="Y" THEN CLS:INSTRUC=TRUE:GOSUB 880
210 KEY OFF : ON KEY(1) GOSUB 1110
220 RANDOMIZE(VAL(MID$(TIME$,7,2))+(VAL(MID$(TIME$,4,2))*60))
230 COLOR 7,1,1:CLS:PRINT PARDON$
240 IF NOT INSTRUC THEN GOSUB 880 ELSE INSTRUC = FALSE
250 GOSUB 350 'SHUFFLE THE DECK
260 CLS
270 GOSUB 640 'PRINT OUT THE PLAYING TABLE
280 WON = FALSE
290 GOTO 1130
300 IF FLAG=1 THEN GOSUB 2590 ELSE GOSUB 2230
310 IF ABORT THEN ABORT = FALSE : GOTO 290
320 FLAG=0:GOSUB 2480 'ASK IF THEY WANT TO PLAY AGAIN
330 IF ABORT THEN ABORT = FALSE : GOTO 290
340 IF FLAG=1 AND WON THEN 230 ELSE IF FLAG=1 THEN CLS:PRINT PARDON$:GOTO 250 ELSE COLOR 7,0,0:CLS:SYSTEM
350 Z = 2
360 FOR I=1 TO 52
370 IF (I MOD 13) - 1 = 0 THEN RESTORE:Z = Z + 1
380 READ ZZ$
390 CARD$(I) = ZZ$+CHR$(Z)
400 NEXT I
410 FOR I= 52 TO 1 STEP -1
420 X=INT(RND(1)*I)+1 'PICK NUMBER FROM 1 TO I
430 DECK$(I)=CARD$(X) 'PICK THAT CARD OUT OF THE PILE
440 CARD$(X)=CARD$(I) 'MOVE LAST CARD TO WHERE PREVIOUS ONE WAS
450 NEXT I
460 X=1 'DECK COUNTER
470 FOR I=1 TO 7 'NUMBER OF STACKS
480 FOR J=1 TO I 'NUMBER OF CARDS IN THAT STACK
490 STACK$(I,J)=DECK$(X) 'ASSIGN CARDS TO STACK
500 X=X+1
510 NEXT J
520 STACKPTR(I)=I 'SET STACKPTR(I) TO LAST CARD IN EACH STACK
530 VISIPTR(I)=I 'SAME WITH VISIPTR(I)
540 NEXT I
550 DECKPTR=31:ENDDECK=52:DECK$(28)=" ":NC=24
560 DATA" A"," 2"," 3"," 4"," 5"," 6"," 7"," 8"," 9","10"," J"," Q"," K"
570 FOR I=1 TO 7
580 STACK$(I,0)=" "
590 NEXT I
600 FOR I=1 TO 4
610 TOP$(I)=" "
620 NEXT I
630 RETURN
640 COLOR 3,1 :LOCATE 1,4:PRINT"TOP:":LOCATE 1,65:PRINT "Time: "
650 LOCATE 3,1:PRINT"STACKS:"
660 FOR I=7 TO 1 STEP -1
670 LOCATE 3,(45-(5*I))
680 PRINT I;
690 NEXT I
700 COLOR 7,1
710 FOR I=1 TO 7
720 FOR J=I TO 7
730 LOCATE (I+3),(45-(J*5))
740 IF VISIPTR(J)=I THEN C$=STACK$(J,I):GOSUB 2840:PRINT STACK$(J,I);:COLOR 7,1 ELSE FOR X=1 TO 3:PRINT CHR$(254);:NEXT X
750 NEXT J
760 NEXT I
770 COLOR 3,1
780 LOCATE 10 ,53:PRINT"PILE:";
790 COLOR 7,1
800 LOCATE 10,59:C$=DECK$(DECKPTR):GOSUB 2840:PRINT DECK$(DECKPTR);:COLOR 3,1:LOCATE 10,65:PRINT"Count: ";:COLOR 7:PRINT NC;:COLOR 3
810 LOCATE 11,64:PRINT"Card #: ";:COLOR 7:PRINT DECKPTR-28;" ";
820 COLOR 3:LOCATE 12,50:PRINT"COMMAND: __ ";
830 COLOR 2
840 LOCATE 24,26:PRINT"Press F1 For Instructions";
850 COLOR 7
860 LOCATE 12,59
870 RETURN
880 SCREEN 0,1,1,0
890 CLS:KKKS$=" K L O N D Y K E S O L I T A I R E "
900 LOCATE ,11:COLOR 10:PRINT"The Game Of ";:COLOR 12,7:PRINT"";:COLOR 5:PRINT KKKS$;:COLOR 0,7:PRINT"":COLOR 10,1
910 LOCATE 3,1:PRINT"R U L E S :":COLOR 7:LOCATE 4,3:PRINT"1. Cards are played alternating colors on the stack; by suit on the Top."
920 LOCATE 5,3:PRINT "2. Stacks are played in descending order; Top is in ascending order."
930 LOCATE 6,3:PRINT "3. Only Kings can be moved to an empty stack; only Aces can be":LOCATE 7,6:PRINT "moved to an empty Top."
940 LOCATE 8,3:PRINT "4. The Game can be claimed Victory when all cards are uncovered and":LOCATE 9,6:PRINT "no cards are in the pile."
950 LOCATE 10,3:PRINT"5. Commands are 1 - 2 characters. Illegal moves sound the BUZZER."
960 LOCATE 11,3:PRINT"6. When you Quit two short beeps warn you of this."
970 LOCATE 13,1:COLOR 10:PRINT"C O M M A N D S :":COLOR 7
980 LOCATE 15,10:PRINT"C Claim Victory"
990 LOCATE 16,10:PRINT"N Show the Next Card on the Pile"
1000 LOCATE 17,10:PRINT"P# Card on Pile to Stack No. #"
1010 LOCATE 18,10:PRINT"PT Card on Pile to Top"
1020 LOCATE 19,10:PRINT"## Visible Cards on Stack #1 to Stack #2"
1030 LOCATE 20,10:PRINT"#T Bottom Card on Stack #1 to the Top"
1040 LOCATE 21,10:PRINT"Q Quit This Game (and Try Again or Exit)"
1050 LOCATE 22,10:PRINT"F1 For This Screen"
1060 COLOR 12:LOCATE 23,10:PRINT"Esc Abort Quit and Return to Present Game
1070 COLOR 13:LOCATE 25,28:PRINT"Press Any Key To Continue";:COLOR 7
1080 IF INSTRUC THEN 1110
1090 SCREEN 0,1,0,0
1100 KEY (1) ON :RETURN
1110 KEY (1) OFF : LOCATE ,,0: SCREEN 0,1,0,1
1120 A$=INKEY$:IF A$="" THEN 1120 ELSE 1090
1130 FLAG=0:GOSUB 1800:IF FLAG=1 THEN 300
1140 LOCATE 12,59:PRINT"__ ";:LOCATE 12,59
1150 K$=INKEY$:IF K$="" THEN LOCATE 1,71:PRINT TIME$;:LOCATE 12,59:GOTO 1150 ELSE PRINT K$;
1160 IF K$="N" OR K$="n" THEN 1220
1170 IF K$="P" OR K$="p" THEN 1300
1180 IF K$>="1"AND K$<="7" THEN 1860
1190 IF K$="Q" OR K$="q" THEN FLAG=0:GOTO 300
1200 IF K$="C" OR K$="c" THEN 2610
1210 SOUND 50,5:GOTO 1140
1220 IF DECKPTR+3>ENDDECK THEN DECKPTR=28
1230 X=ENDDECK-28
1240 IF X <=3 THEN DECKPTR=ENDDECK ELSE DECKPTR=DECKPTR+3
1250 LOCATE 10,59
1260 C$=DECK$(DECKPTR):GOSUB 2840:PRINT DECK$(DECKPTR):COLOR 7,1
1270 LOCATE 11,72:PRINT DECKPTR-28;" ";
1280 GOTO 1140
1290 K$=INKEY$:IF K$="" THEN 1290 ELSE PRINT K$;:RETURN
1300 GOSUB 1290
1310 IF(K$="t" OR K$="T") OR (K$>="1" AND K$<="7") THEN 1320 ELSE SOUND 50,5:GOTO 1140
1320 W$=DECK$(DECKPTR)
1330 SUIT$=MID$(W$,3,1):SIZE$=MID$(W$,2,1)
1340 IF K$="T" OR K$="t" THEN GOSUB 1520:GOTO 1420
1350 K=VAL(K$)
1360 W1$=STACK$(K,STACKPTR(K))
1370 SUITST$=MID$(W1$,3,1):SIZEST$=MID$(W1$,2,1)
1380 FLAG=0:GOSUB 1590:IF FLAG=0 THEN SOUND 50,5 :GOTO 1130
1390 STACKPTR(K)=STACKPTR(K)+1
1400 STACK$(K,STACKPTR(K))=W$
1410 LOCATE STACKPTR(K)+3,(45-(K*5)):C$=W$:GOSUB 2840:PRINT W$:COLOR 7,1
1420 DECKPTR=DECKPTR-1:GOSUB 1460
1430 LOCATE 10,59:IF DECKPTR>28 THEN C$=DECK$(DECKPTR):GOSUB 2840:PRINT DECK$(DECKPTR):COLOR 7,1 ELSE PRINT" "
1440 LOCATE 11,72:PRINT DECKPTR-28;" ";
1450 GOTO 1130
1460 IF DECKPTR+1=ENDDECK THEN 1500
1470 FOR I= DECKPTR+2 TO ENDDECK
1480 DECK$(I-1)=DECK$(I)
1490 NEXT I
1500 ENDDECK=ENDDECK-1:NC=NC-1:LOCATE 10,72:PRINT NC;
1510 RETURN
1520 IF SUIT$=CHR$(5) THEN N=1:GOTO 1560
1530 IF SUIT$=CHR$(4) THEN N=2:GOTO 1560
1540 IF SUIT$=CHR$(3) THEN N=3:GOTO 1560
1550 N=4
1560 SIZEST$=MID$(TOP$(N),2,1)
1570 FLAG=0:GOSUB 1710:IF FLAG=0 THEN SOUND 50,5:GOTO 1130
1580 TOP$(N)=W$:LOCATE 1,10+(10*(N-1)):C$=W$:GOSUB 2840:PRINT W$:COLOR 7,1:RETURN
1590 IF(SUIT$=CHR$(3) OR SUIT$=CHR$(4))AND(SUITST$=CHR$(3) OR SUITST$=CHR$(4)) THEN RETURN
1600 IF(SUIT$=CHR$(5) OR SUIT$=CHR$(6))AND(SUITST$=CHR$(5) OR SUITST$=CHR$(6)) THEN RETURN
1610 IF SIZE$>"9" THEN 1650
1620 IF SIZE$="0" AND SIZEST$="J" THEN 1700
1630 IF SIZE$="9" AND SIZEST$="0" THEN 1700
1640 IF SIZE$="A" AND SIZEST$="2" THEN 1700
1650 IF SIZE$="J" AND SIZEST$="Q" THEN 1700
1660 IF SIZE$="Q" AND SIZEST$="K" THEN 1700
1670 IF SIZE$="K" AND SIZEST$=" " THEN 1700
1680 IF SIZEST$<"A" AND (ASC(SIZEST$)-ASC(SIZE$))=1 THEN 1700
1690 RETURN
1700 FLAG=1:RETURN
1710 IF SIZE$="A" AND SIZEST$=" " THEN 1790
1720 IF SIZE$="2" AND SIZEST$="A" THEN 1790
1730 IF SIZE$="0" AND SIZEST$="9" THEN 1790
1740 IF SIZE$="J" AND SIZEST$="0" THEN 1790
1750 IF SIZE$="Q" AND SIZEST$="J" THEN 1790
1760 IF SIZE$="K" AND SIZEST$="Q" THEN 1790
1770 IF SIZE$<"A" AND (ASC(SIZE$)-ASC(SIZEST$))=1 THEN 1790
1780 RETURN
1790 FLAG=1:RETURN
1800 REM CHECK TO SEE IF THE GAME IS OVER
1810 FOR I=1 TO 4
1820 IF MID$(TOP$(I),2,1)<>"K" THEN RETURN
1830 NEXT I
1840 REM GAME OVER AND PLAYER WON
1850 FLAG=1:RETURN
1860 REM STACK TO STACK MOVE OR STACK TO TOP
1870 STKNUM1=VAL(K$)
1880 GOSUB 1290
1890 IF (K$>="1" AND K$<="7") OR (K$="T" OR K$="t") THEN 1910
1900 SOUND 50,5:GOTO 1140
1910 IF K$="t" OR K$="T" THEN W$=STACK$(STKNUM1,STACKPTR(STKNUM1)):GOTO 1930
1920 W$=STACK$(STKNUM1,VISIPTR(STKNUM1))
1930 SUIT$=MID$(W$,3,1)
1940 SIZE$=MID$(W$,2,1)
1950 IF K$="T" OR K$="t" THEN GOSUB 1520:GOTO 2180
1960 STKNUM2=VAL(K$)
1970 W$=STACK$(STKNUM2,STACKPTR(STKNUM2))
1980 SUITST$=MID$(W$,3,1)
1990 SIZEST$=MID$(W$,2,1)
2000 FLAG=0:GOSUB 1590
2010 IF FLAG=0 THEN SOUND 50,5:GOTO 1140
2020 IF VISIPTR(STKNUM1)=0 THEN VISIPTR(STKNUM1)=1
2030 FOR I=VISIPTR(STKNUM1) TO STACKPTR(STKNUM1)
2040 STACKPTR(STKNUM2)=STACKPTR(STKNUM2)+1
2050 LOCATE I+3,45-(STKNUM1*5):PRINT" ";
2060 STACK$(STKNUM2,STACKPTR(STKNUM2))=STACK$(STKNUM1,I)
2070 LOCATE STACKPTR(STKNUM2)+3,45-(STKNUM2*5)
2080 C$ = STACK$(STKNUM2,STACKPTR(STKNUM2)):GOSUB 2840
2090 PRINT STACK$(STKNUM2,STACKPTR(STKNUM2));:COLOR 7,1
2100 NEXT I
2110 IF VISIPTR(STKNUM1)>0 THEN VISIPTR(STKNUM1)=VISIPTR(STKNUM1)-1
2120 STACKPTR(STKNUM1)=VISIPTR(STKNUM1)
2130 IF STACKPTR(STKNUM1)<1 THEN 1130
2140 LOCATE STACKPTR(STKNUM1)+3,45-(STKNUM1*5)
2150 C$ = STACK$(STKNUM1,STACKPTR(STKNUM1)):GOSUB 2840
2160 PRINT STACK$(STKNUM1,STACKPTR(STKNUM1));:COLOR 7,1
2170 GOTO 1130
2180 LOCATE STACKPTR(STKNUM1)+3,45-(STKNUM1*5)
2190 PRINT" ";
2200 IF STACKPTR(STKNUM1)=VISIPTR(STKNUM1) THEN 2110
2210 STACKPTR(STKNUM1)=STACKPTR(STKNUM1)-1
2220 GOTO 1130
2230 REM PRINT OUT THE TABLE
2240 COLOR 2 : SEEN = FALSE
2250 LOCATE 24,24:PRINT"Would you like to see the cards? "; :SOUND 1975,.5:GOSUB 2720 : SOUND 1975,.5
2260 A$=INKEY$:IF A$="" THEN 2260
2270 IF A$=CHR$(27) THEN ABORT=TRUE : LOCATE 24,24:PRINT SPACE$(40);:COLOR 7 : RETURN :ELSE ABORT=FALSE
2280 IF A$<>"y" AND A$<>"Y" AND A$<>"N" AND A$<>"n" THEN SOUND 50,5:GOTO 2260
2290 IF A$="N" OR A$="n" THEN 2460
2300 SEEN = TRUE : LOCATE 24,24:PRINT " ";
2310 FOR I=7 TO 1 STEP -1
2320 X=1
2330 WHILE VISIPTR(I)>X
2340 LOCATE X+3,45-(I*5)
2350 PRINT STACK$(I,X);:X=X+1
2360 WEND
2370 NEXT I
2380 LOCATE 18,50:PRINT"Pile: "
2390 X=0:RR=18
2400 FOR I=29 TO ENDDECK
2410 IF X+56>76 THEN RR=RR+1:X=0
2420 LOCATE RR,X+56
2430 IF DECK$(I)=" "THEN 2460 ELSE PRINT DECK$(I);:X=X+4
2440 NEXT I
2450 COLOR 7
2460 RETURN
2470 COLOR 2
2480 IF SCR.WIDTH=40 THEN SCR.WIDTH =80:LOCATE 24,15:PRINT"Play Again?";:GOTO 2500 ELSE LOCATE 24,24
2490 LOCATE 24,24:PRINT" Do you want to play again? ";
2500 A$=INKEY$:IF A$="" THEN 2500
2510 IF NOT WON THEN COLOR 7
2520 IF A$<>CHR$(27) THEN 2560 ELSE IF NOT SEEN AND NOT WON THEN ABORT=TRUE :LOCATE 24,28:PRINT SPACE$(30);:RETURN
2530 IF WON THEN SOUND 50,5: GOTO 2500
2540 SOUND 50,5:LOCATE 24,17:PRINT"Cheater... Shame Shame! You've already seen the cards!";:DT!=2000:GOSUB 2740
2550 LOCATE 24,17 : PRINT SPACE$(60);:GOTO 2480
2560 IF A$="y" OR A$="Y" THEN FLAG=1: IF WON THEN GOSUB 3030:RETURN ELSE RETURN
2570 IF A$="N" OR A$="n" THEN GOSUB 3030:RETURN
2580 SOUND 50,5:GOTO 2500
2590 GOSUB 2870
2600 RETURN
2610 'CHECK TO SEE IF CLAIMED VICTORY
2620 FLAG=0
2630 IF NC>0 THEN 2680
2640 FOR I=1 TO 7
2650 IF VISIPTR(I)>1 THEN 2680
2660 NEXT I
2670 FLAG=1:GOTO 300
2680 SOUND 50,5:LOCATE 14,50:PRINT"You Have Not Won Yet!!!"
2690 DT! = 2000 : GOSUB 2740
2700 LOCATE 14,50:PRINT SPC(25);
2710 GOTO 1140
2720 'DELAY TIME ROUTINE FOR (DT!) MILLISECONDS
2730 DT!=100
2740 DV!=DT!*18.2/1000
2750 DEF SEG = &H40
2760 WHILE DV!>0
2770 A! = O
2780 FOR ID = O TO 3
2790 A! = A!*256 + PEEK(&H6F-ID)
2800 NEXT ID
2810 IF A! <> AOLD! THEN DV! = DV! - 1 : AOLD! = A!
2820 WEND
2830 DEF SEG : RETURN
2840 C$=MID$(C$,3,1)
2850 IF C$=CHR$(3) OR C$=CHR$(4) THEN COLOR 12,7 ELSE COLOR 0,7
2860 RETURN
2870 REM 'DISPLAY WON SCREEN'
2880 IF NOT.READ THEN FOR I = 1 TO 82 : READ XYARR$(I) : NEXT : NOT.READ=FALSE
2890 SCREEN 1,0 : COLOR 1,0
2900 FOR I = 82 TO 1 STEP -1
2910 FOR J = 1 TO 45
2920 X=RND(1)*320:Y=RND(1)*200:C=C+1:IF C=4 THEN C=1
2930 PSET (X,Y),C
2940 NEXT J
2950 LL = INT(RND(1)*I)+1
2960 XYPOS$=XYARR$(LL)
2970 XYARR$(LL)=XYARR$(I)
2980 Y = VAL(LEFT$(XYPOS$,1))+8
2990 X= VAL(RIGHT$(XYPOS$,2))
3000 LOCATE Y,X:PRINT "*";
3010 NEXT I
3020 SCR.WIDTH=40 : WON = TRUE : RETURN
3030 SCREEN 0,1:WIDTH 80:RETURN
3040 DATA "002","006","009","010","011","014","018","023","027","030"
3050 DATA "031","032","035","039","103","105","108","112","114"
3060 DATA "118","123","127","129","133","135","136","139","204","208"
3070 DATA "212","214","218","223","225","227","229","233","235","236"
3080 DATA "237","239","304","308","312","314","318","323","325","327"
3090 DATA "329","333","335","337","338","339","404","408","412","414"
3100 DATA "418","423","425","427","429","433","435","438","439","504"
3110 DATA "509","510","511","515","516","517","524","526","530","531"
3120 DATA "532","535","539"
DATA "509","510","511","515","516","517","524","526","530","531"
3120 DATA "532","535","539"