battleship.compact.bas

100 REM COPYRIGHT (C) 1987-2023 SEAN WOHLGEMUTH
210 RANDOMIZE
220 DIM SS(1,4,4)
230 CALL STP
250 CALL RBO
260 CALL RAU
270 CALL DPL(SS(,,))
280 CALL DCO(0,SS(,,))
290 CALL PGA(SS(,,))
300 GOTO 250
310 END
330 SUB STP
410 CALL CHAR(96,"3C4299A5A599423C",97,"0000000000000000",104,"3C7EFFFFFFFF7E3C",112,"3C4299A5A599423C")
420 CALL CHAR(120,"004FC949494949EF",128,"3C7EFFFFFFFF7E3C",136,"3C7EFFFFFFFF7E3C")
500 CALL COLOR(9,2,8,10,11,8,11,2,15,12,2,1,13,16,8,14,9,8)
570 SUBEND
590 SUB DPL(SS(,,))
610 A$="N"
620 CALL MAD(A$)
630 IF A$="Y" THEN CALL DAU(SS(,,)) ELSE CALL DMA(SS(,,))
650 R=3::C=23
670 FOR I=0 TO 5-1
680 CALL GSL(SL,(I))
690 FOR J=0 TO SL-1
700 RO=INT(SS(0,I,J)/16) :: CO=SS(0,I,J)-INT(SS(0,I,J)/16)*16
710 CALL HCHAR(R+RO-1,C+CO-1,112,1)
720 NEXT J
730 NEXT I
740 CALL RHO
750 R=14::C=23
760 CALL MCL
770 CALL TXT("PLAYER'S",(R),(C))
780 CALL TXT("SHIPS",(R+1),(C))
790 CALL TXT("DEPLOYED.",(R+2),(C))
800 CALL TXT("COMPUTER",(R+4),(C))
810 CALL TXT("DEPLOYING",(R+5),(C))
820 CALL TXT("SHIPS...",(R+6),(C))
830 SUBEND
850 SUB DAU(SS(,,))
860 R=14::C=23
870 CALL TXT("AUTO",(R+6),(C))
880 CALL TXT("DEPLOYING",(R+7),(C))
890 CALL TXT("SHIPS...",(R+8),(C))
900 CALL DCO(1,SS(,,))
920 FOR I=0 TO 5-1
930 CALL GSL(SL,(I))
940 FOR J=0 TO SL-1
950 SS(0,I,J)=SS(1,I,J)
960 NEXT J
970 NEXT I
980 SUBEND
1000 SUB DMA(SS(,,))
1010 CALL MCL
1020 DIM S(4) :: FOR I = 0 TO 4 :: S(I)=0 :: NEXT I
1040 FOR CS=0 TO 5-1
1060 CALL MDE((CS))
1070 CALL ISH(S(),(CS))
1080 P=0
1090 E=0
1100 CALL CVI(E,(P),(CS),S(),SS(,,))
1110 IF E=1 THEN 1060
1120 CALL GSL(SL,(CS))
1130 FOR I=0 TO SL-1
1140 SS(0,CS,I)=S(I)
1150 NEXT I
1160 CALL RSI((CS),S())
1170 NEXT CS
1180 SUBEND
1200 SUB DCO(VI,SS(,,))
1210 DIM S(4) :: FOR I = 0 TO 4 :: S(I)=0 :: NEXT I
1230 R=5::C=3
1250 FOR CS=0 TO 5-1
1270 CALL GSL(SL,(CS))
1280 HZ=INT(RND*2)
1290 SB=INT(RND*(10-SL))+1
1300 ST=INT(RND*10)+1
1310 FOR I=0 TO SL-1
1320 IF HZ=1 THEN S(I)=16*ST+SB+I ELSE S(I)=16*(SB+I)+ST
1330 NEXT I
1340 P=1
1350 E=0
1360 CALL COV(E,(P),(CS),S(),SS(,,))
1370 IF E=1 THEN 1270
1380 FOR I=0 TO SL-1
1390 SS(1,CS,I)=S(I)
1400 NEXT I
1420 IF VI=1 THEN CALL RSI((CS),S())
1430 NEXT CS
1440 SUBEND
1460 SUB PGA(SS(,,))
1470 AUTOPLAY=0
1480 CALL MCL
1490 CALL MTA
1500 DIM SH(1,9,9)
1510 FOR I=0 TO 9 :: FOR J=0 TO 9 :: SH(0,I,J)=0 :: SH(1,I,J)=0 :: NEXT J :: NEXT I
1520 DIM HL(1,4)
1540 FOR I=0 TO 5-1
1550 CALL GSL(SL,(I))
1560 HL(0,I)=SL :: HL(1,I)=SL
1570 NEXT I
1580 DIM SM(1)
1590 SM(0)=5 :: SM(1)=5
1600 DIM Q(11) :: FOR I=0 TO 10 :: Q(I)=-1 :: NEXT I :: QL=0
1610 W=-1
1620 IF AUTOPLAY=1 THEN P=1 ELSE P=0
1640 IF P=0 THEN CALL PTU(R,C,SH(,,))
1650 IF P=1 THEN CALL CTU(R,C,Q(),QL,SH(,,))
1660 SH(P,R-1,C-1)=1
1670 CALL PSH(W,(R),(C),(P),HL(,),SM(),SS(,,),Q(),QL)
1680 IF W=0 OR W=1 THEN 1720
1690 IF AUTOPLAY=0 THEN P=1-P
1700 GOTO 1640
1720 P$="N"
1730 CALL MGO(P$,(W))
1740 IF P$="Y" THEN 1770
1750 CALL CLEAR
1760 END
1770 SUBEND
1790 SUB PTU(R,C,SH(,,))
1810 CALL ITA(R$,C)
1820 R=ASC(R$)-64
1830 CALL CVO(E,(R),(C),0,SH(,,))
1840 IF E=1 THEN 1810
1850 SUBEND
1870 SUB CTU(R,C,Q(),QL,SH(,,))
1880 CALL GAI(R,C,Q(),QL,SH(,,))
1890 MR=14::MC=23
1900 T$=CHR$(64+R)&STR$(C)
1910 CALL HCHAR(MR+8,MC,32,10)
1920 CALL TXT(T$,(MR+8),(MC))
1930 SUBEND
1950 SUB PSH(W,R,C,P,HL(,),SM(),SS(,,),Q(),QL)
1960 W=-1 :: H=0 :: S=0
1970 L=16*R+C
1980 CALL CHI(H,S,(L),(1-P),SS(,,))
1990 IF P=1 AND H=1 THEN Q(QL)=L :: QL=QL+1 
2000 CALL RSO((P),(H),(R),(C))
2010 IF H=0 THEN 2130
2020 HL(1-P,S)=HL(1-P,S)-1
2030 IF HL(1-P,S)>0 THEN 2130
2040 SM(1-P)=SM(1-P)-1
2050 CALL RSU((1-P),(S),SS(,,))
2060 IF SM(1-P)=0 THEN W=P
2070 IF P=0 THEN 2130
2080 CALL GSL(SL,(S))
2090 FOR I=0 TO SL-1
2100 SU=SS(0,S,I)
2110 CALL QDE(Q(),QL,(SU),E)
2120 NEXT I
2130 SUBEND
2150 SUB GAI(R,C,Q(),QL,SH(,,))
2170 IF QL<=OL THEN O=0
2180 IF QL=0 THEN GOSUB 2300
2190 IF QL=0 THEN GOTO 2250
2200 IF O=0 THEN GOSUB 2340
2210 O=O+1
2220 R=INT(Q(0)/16) :: C=Q(0)-INT(Q(0)/16)*16
2230 R=R+O*RD :: C=C+O*CD
2250 CALL CVO(E,(R),(C),1,SH(,,))
2260 IF E=1 THEN O=0 :: GOTO 2170
2270 OL=QL
2280 GOTO 2410
2300 R=INT(RND*10)+1 :: C=INT(RND*10)+1
2310 RD=0 :: CD=0 :: RV=0 :: O=0
2320 RETURN
2340 IF RV=1 THEN T=RD :: RD=CD :: CD=T :: RV=0 :: RETURN
2350 IF RD<>0 THEN RD=RD*-1:: RV=1 :: RETURN
2360 IF CD<>0 THEN CD=CD*-1:: RV=1 :: RETURN
2370 DR=INT(RND*4)
2380 IF DR=0 OR DR=2 THEN CD=DR-1 ELSE RD=DR-2
2390 RV=0
2400 RETURN
2410 SUBEND
2430 SUB TXT(T$,R,C)
2440 TL=LEN(T$)
2450 FOR I=0 TO TL-1
2460 C$=SEG$(T$,I+1,1)
2470 CALL HCHAR(R,C+I,ASC(C$))
2480 NEXT I
2490 SUBEND
2510 SUB RBO
2520 CALL CLEAR
2530 CALL SCREEN(4)
2540 DISPLAY AT(1,9):"BATTLESHIP"
2550 R=5::C=3
2570 FOR I=0 TO 18
2580 CALL HCHAR(R+I,C,97,19)
2590 NEXT I
2600 R=5::C=3
2630 FOR I=0 TO 8
2640 CALL HCHAR(R-2,I*2+C,49+I,1)
2650 NEXT I
2660 CALL HCHAR(R-2,C+18,120,1)
2680 FOR I=1 TO 10
2690 CALL HCHAR(R-2+I*2,C-2,64+I,1)
2700 NEXT I
2710 CALL RHO
2720 SUBEND
2740 SUB RHO
2750 R=5::C=3
2770 FOR I=0 TO 18 STEP 2
2780 FOR J=0 TO 18 STEP 2
2790 CALL HCHAR(R+I,C+J,96,1)
2800 NEXT J
2810 NEXT I
2820 SUBEND
2840 SUB RAU
2850 R=3::C=23
2870 FOR I=0 TO 9
2880 CALL HCHAR(R+I,C,96,10)
2890 NEXT I
2900 SUBEND
2920 SUB RSI(CS,S())
2930 CALL GSL(SL,(CS))
2950 R=5::C=3
2960 FOR I=0 TO SL-1
2970 RO=INT(S(I)/16) :: CO=S(I)-INT(S(I)/16)*16
2980 CALL HCHAR(R+(RO-1)*2,C+(CO-1)*2,112,1)
2990 NEXT I
3000 SUBEND
3020 SUB RSO(P,H,SR,SC)
3030 R=14::C=23
3040 IF P=0 THEN R=R+4 ELSE R=R+9
3050 IF H=0 THEN T$="MISS" :: N=-3 ELSE T$="HIT" :: N=-8
3060 CALL HCHAR(R,C,32,10)
3070 CALL TXT((T$),(R),(C))
3080 IF H=1 THEN CV=104 ELSE CV=128
3090 IF P=1 THEN R=3::C=23 ELSE R=5::C=3
3100 TR=SR-1 :: TC=SC-1
3110 IF P=0 THEN TR=TR*2 :: TC=TC*2
3120 CALL HCHAR(R+TR,C+TC,CV,1)
3130 CALL SOUND(500,N,2) :: CALL SOUND(1,110,30)
3140 SUBEND
3160 SUB RSU(P,S,SS(,,))
3170 CALL GSL(SL,(S))
3180 IF P=0 THEN R=3::C=23 ELSE R=5::C=3
3200 FOR I=0 TO SL-1
3210 L=SS(P,S,I)
3220 TR=INT(L/16)-1 :: TC=L-INT(L/16)*16-1
3230 IF P=1 THEN TR=TR*2 :: TC=TC*2
3240 CALL HCHAR(R+TR,C+TC,136,1)
3250 NEXT I
3260 CALL GSN(S$,(S))
3270 R=14::C=23
3280 IF P=1 THEN R=R+4 ELSE R=R+9
3290 CALL HCHAR(R,C,32,10)
3300 CALL TXT("DESTROYED",(R),(C))
3310 CALL HCHAR(R,C,32,10)
3320 CALL TXT((S$),(R),(C))
3330 CALL SOUND(1000,-6,2) :: CALL SOUND(1,110,30)
3340 SUBEND
3360 SUB MCL
3370 R=14::C=23
3380 FOR I=0 TO 9 :: CALL HCHAR(R+I,C,32,10) :: NEXT I
3390 SUBEND
3410 SUB MAD(A$)
3420 R=14::C=23
3430 CALL MCL
3440 CALL TXT("AUTO",(R),(C))
3450 CALL TXT("DEPLOY",(R+1),(C))
3460 CALL TXT("YOUR",(R+2),(C))
3470 CALL TXT("SHIPS?",(R+3),(C))
3480 CALL TXT("[Y/N]:",(R+4),(C))
3490 CALL SOUND(200,1398,0)
3500 A$=""
3510 CALL HCHAR(R+4,C+6,30)
3530 CALL KEY(0,K,S)
3540 IF S=0 OR S=-1 THEN 3530
3550 IF K<>78 AND K<>89 THEN 3530
3560 CALL HCHAR(R+4,C+6,K)
3570 A$=CHR$(K)
3580 SUBEND
3600 SUB MDE(CS)
3610 R=14::C=23
3620 CALL TXT("INPUT THE",(R),(C))
3630 CALL TXT("LOCATIONS",(R+1),(C))
3640 CALL TXT("FOR YOUR",(R+2),(C))
3650 CALL TXT("          ",(R+3),(C))
3660 CALL GSN(S$,(CS))
3670 CALL TXT((S$),(R+3),(C))
3680 CALL TXT("[IE. C3]:",(R+4),(C))
3690 CALL GSL(SL,(CS))
3700 FOR I=1 TO 5
3710 IF I>SL THEN T$="        " ELSE T$="POS"&STR$(I)&":    "
3720 CALL TXT((T$),(R+4+I),(C))
3730 NEXT I
3740 SUBEND
3760 SUB MTA
3770 R=14::C=23
3780 CALL TXT("PLAYER",(R),(C))
3790 CALL TXT("TARGET",(R+1),(C))
3800 CALL TXT("[IE. C3]",(R+2),(C))
3810 CALL TXT("COMPUTER",(R+6),(C))
3820 CALL TXT("TARGET",(R+7),(C))
3830 SUBEND
3850 SUB MGO(P$,W)
3860 R=14::C=23
3870 CALL MCL
3880 CALL TXT("GAME OVER",(R),(C))
3890 CALL TXT("WINNER:",(R+1),(C))
3900 IF W=0 THEN T$="PLAYER" ELSE T$="COMPUTER"
3910 CALL TXT(T$,(R+2),(C))
3920 CALL TXT("PLAY", (R+4),(C))
3930 CALL TXT("AGAIN?",(R+5),(C))
3940 CALL TXT("[Y/N]:",(R+6),(C))
3950 CALL SOUND(200,1398,0)
3960 P$=""
3970 CALL HCHAR(R+6,C+6,30)
3990 CALL KEY(0,K,S)
4000 IF S=0 OR S=-1 THEN 3990
4010 IF K<>78 AND K<>89 THEN 3990
4020 CALL HCHAR(R+6,C+6,K)
4030 P$=CHR$(K)
4040 SUBEND
4060 SUB IPO(R,C,IR$,IC)
4080 CALL SOUND(200,1398,0)
4090 O=0
4100 IR$=""
4110 CALL HCHAR(R,C+O,30)
4120 CALL KEY(0,K,S)
4130 IF S=0 OR S=-1 OR K<65 OR K>74 THEN 4090
4140 CALL HCHAR (R,C+O,K)
4150 IR$=CHR$(K)
4170 O=1
4180 IC=0
4190 CALL HCHAR(R,C+O,30)
4200 CALL KEY(0,K,S)
4210 IF (S=0 OR S=-1) OR (K<>8 AND (K<49 OR K>57)) THEN 4170
4220 IF K=8 THEN CALL HCHAR(R,C+O,32) :: GOTO 4090
4230 CALL HCHAR (R,C+O,K)
4240 IC=K-48
4260 O=2
4270 CALL HCHAR(R,C+O,30)
4280 CALL KEY(0,K,S)
4290 IF (S=0 OR S=-1) OR (K<>13 AND K<>8 AND K<>48) THEN 4260
4300 CALL HCHAR(R,C+O,32)
4310 IF K=8 THEN 4170
4320 IF K=13 THEN 4430
4330 IF IC>1 THEN 4260
4340 CALL HCHAR(R,C+O,K)
4360 O=3
4370 CALL HCHAR(R,C+O,30)
4380 CALL KEY(0,K,S)
4390 IF (S=0 OR S=-1) OR (K<>13 AND K<>8) THEN 4360
4400 CALL HCHAR(R,C+O,32)
4410 IF K=8 THEN 4260
4420 IC=10
4430 SUBEND
4450 SUB ISH(S(),CS)
4460 CALL GSL(SL,(CS))
4470 R=14::C=23
4480 FOR I=0 TO SL-1
4490 IR$="" :: IC=0
4500 CALL IPO((R+5+I),(C+5),IR$,IC)
4510 S(I)=16*(ASC(IR$)-64)+IC
4520 NEXT I
4530 SUBEND
4550 SUB ITA(AR$,AC)
4560 R=14::C=23
4570 CALL HCHAR(R+3,C,32,10)
4580 CALL IPO((R+3),(C),AR$,AC)
4590 SUBEND
4610 SUB CVI(E,P,CS,S(),SS(,,))
4620 E=0
4630 HZ=0
4640 CALL GSL(SL,(CS))
4650 CALL CHS(E,(CS),S())
4660 IF E=1 THEN 4760
4670 CALL CHO(HZ,(CS),S())
4680 DIM SQ(4) :: FOR I=0 TO 4 :: SQ(I)=0 :: NEXT I
4690 FOR I=0 TO SL-1
4700 R=INT(S(I)/16) :: C=S(I)-INT(S(I)/16)*16
4710 IF HZ=1 THEN SQ(I)=C ELSE SQ(I)=R
4720 NEXT I
4730 CALL CSE(E,(CS),SQ())
4740 IF E=1 THEN 4760
4750 CALL COV(E,(P),(CS),S(),SS(,,))
4760 SUBEND
4780 SUB CVO(E,R,C,P,SH(,,))
4790 E=0
4800 IF R<1 OR R>10 OR C<1 OR C>10 THEN E=1 :: GOTO 4820
4810 IF SH(P,R-1,C-1)<>0 THEN E=1
4820 SUBEND
4840 SUB CHI(H,S,L,P,SS(,,))
4850 H=0
4870 FOR I=0 TO 5-1
4880 CALL GSL(SL,(I))
4890 FOR J=0 TO SL-1
4900 IF SS(P,I,J)=L THEN H=1 :: S=I :: GOTO 4930
4910 NEXT J
4920 NEXT I
4930 SUBEND
4950 SUB CHO(HZ,CS,S())
4960 HZ=0
4970 CALL GSL(SL,(CS))
4980 FOR I=1 TO SL-1
4990 PV=INT(S(I-1)/16) :: CU=INT(S(I)/16)
5000 IF PV<>CU THEN 5030
5010 NEXT I
5020 HZ=1
5030 SUBEND
5050 SUB CHS(E,CS,S())
5060 E=0
5070 CALL GSL(SL,(CS))
5080 FOR I=1 TO SL-1
5090 R=INT(S(I)/16) :: C=S(I)-INT(S(I)/16)*16
5100 PR=INT(S(I-1)/16) ::PC=S(I-1)-INT(S(I-1)/16)*16
5110 IF (R<>PR) AND (C<>PC) THEN E=1 :: GOTO 5130
5120 NEXT I
5130 SUBEND
5150 SUB CSE(E,CS,SQ())
5160 E=0
5170 CALL GSL(SL,(CS))
5180 ML=SQ(0)
5190 FOR I=1 TO SL-1
5200 ML=MIN(ML,SQ(I))
5210 NEXT I
5220 ES=ML
5230 FOR I=1 TO SL-1
5240 ES=ES+ML+I
5250 NEXT I
5260 AS=SQ(0)
5270 FOR I=1 TO SL-1
5280 AS=AS+SQ(I)
5290 NEXT I
5300 IF ES<>AS THEN E=1
5310 SUBEND
5330 SUB COV(E,P,CS,S(),SS(,,))
5340 E=0
5350 CALL GSL(CL,(CS))
5360 FOR I=0 TO CS-1
5370 CALL GSL(SL,(I))
5380 FOR J=0 TO SL-1
5390 SD=SS(P,I,J)
5400 FOR K=0 TO CL-1
5410 L=S(K)
5420 IF L=SD THEN E=1 :: GOTO 5460
5430 NEXT K
5440 NEXT J
5450 NEXT I
5460 SUBEND
5480 SUB QDE(Q(),QL,V,E)
5490 DI=-1 :: E=-1
5500 FOR I=0 TO QL
5510 IF V=Q(I) THEN DI=I :: GOTO 5550
5520 NEXT I
5530 GOTO 5590
5550 FOR I=DI TO QL-1
5560 Q(I)=Q(I+1)
5570 NEXT I
5580 QL=QL-1 :: E=0
5590 SUBEND
5930 SUB GSL(SL,X)
5940 SA(0)=5 :: SA(1)=4 :: SA(2)=3 :: SA(3)=3 :: SA(4)=2 
5950 SL=SA(X)
5960 SUBEND
5980 SUB GSN(S$,X)
5990 N$(0)="CARRIER" :: N$(1)="BATTLESHIP" :: N$(2)="CRUISER" :: N$(3)="SUBMARINE" :: N$(4)="DESTROYER"
6000 S$=N$(X)
6010 SUBEND