Compucolor.org – Virtual Media

Listing of file='BCKGMN.FOR;08' on disk='vmedia/backgammon-sideB-sector.ccvf'

	INTEGER A1(26),B(10),B0(4),B1(26),DIE(4),H(5),T(4)
	INTEGER SEC
	REAL M(9)
	REAL T1,T2,T3,T4,T5
	REAL V,V1,V2,V3,V4
	BYTE CI
	BYTE COMP,PLAYER
	BYTE FROMTO(13,3),PCS(18),SCREEN(16),SETUP(8)
	BYTE ANS,CHRN,CHRY,F,I,J,J1,K,K1,L,P,X,Y
	BYTE F2,F4,O1
	BYTE BADCNT,MOVCNT
	BYTE DUM,DUM1,DUM2,DUM3,DUM4,SUB
	COMMON /TEMP/T1,T2,T3,T4,T5
	COMMON /MORE/V,V1,V2,V3,V4
	DATA CHRN,CHRY/'N','Y'/
	DATA FROMTO/
     *	 29,19,'F','R','O','M',' ',' ',19,'T','O',18,X'EF',
     *	 19,31,'F','R','O','M',' ',' ',15,'T','O',18,X'EF',
     *	 19,'F','R','O','M',' ',' ',31,'T','O',15,18,X'EF'/
	DATA PCS/17,'P','I','E','C','E','S',18,10,26,26,26,26,
     *	 ' ',' ',26,26,X'EF'/
	DATA SCREEN/'L','O','A','D',' ',
     *	 'B','C','K','G','M','N','.','D','I','S',0/
	DATA SETUP/6,2,29,15,12,27,24,X'EF'/
	DATA SEC/X'81B9'/

	CALL SETVEC
	K = PEEK(SEC)
	A = PEEK(SEC+1)
	A = RND(-A)
	DO 50 I= 1,K
50	A= (PEEK(SEC)*RND(1.0)+1.0)
240	CALL OSTR(SETUP)
	CALL FCS(SCREEN)
	DO 410 I=1,26
	B1(I)= 0
410	A1(I)= 0
	B1(24) = 2
	B1(19) = -5
	B1(17) = -3
	B1(13) = 5
	B1(12) = -5
	B1(8)  = 3
	B1(6)  = 5
	B1(1)  = -2
	COMP   = 15
	PLAYER = 15
	MOVCNT = 0
	BADCNT = 0
	CALL BOARD(A1,B1)
	V1=4.0
	V4=3.0
510	CALL ROLL(F,DIE)
	IF(DIE(1).EQ.DIE(2)) GOTO 510
520	IF(DIE(1).LT.DIE(2)) GOTO 540
	CALL CLEAR
	CALL PRINT('COMPUTER GOES FIRST@')
	CALL WAIT
	GOTO 2340

540	CALL CLEAR
	CALL PRINT('YOU GO FIRST@')
	CALL WAIT

550	CALL BOARD(A1,B1)
570	CALL ROLL(F,DIE)
580	DO 590 I=1,F
590	H(I)= 0
	O1=0
	P= 0
	DO 615 Y=14,18
	CALL CURSOR(0,Y)
	CALL PRINT('           @')
615	CONTINUE
620	DO 2020 L=1,F
	CALL BOARD(A1,B1)
	P= P+1
	GOTO 640
630	CALL BADMOV(BADCNT)
640	CALL COMMNT
	IF(B1(26).EQ.0)GOTO 930
C
C		PLAYER IS ON BAR
C
650	DO 690 J=1,F
	IF(DIE(J).GT.6)GOTO 690
	SUB = 25-DIE(J)
	IF(B1(SUB).GT.-2)GOTO 720
690	CONTINUE
	CALL CLEAR
700	CALL PRINT('THAT''S IT FOR YOUR TURN - TOUGH@')
	CALL WAIT
	GOTO 2300

720	CALL CURSOR(3,13+P)
	CALL PRINT('         @')
	CALL CURSOR(2,13)
	CALL OSTR(FROMTO(1,3))
	CALL CURSOR(3,13+P)
	CALL PRINT('BAR@')
730	CALL CURSOR(8,13+P)
	CALL RDNUM(J)
	CALL CURSOR(2,13)
	CALL OSTR(FROMTO(1,1))
	CALL CLEAR

790	IF(J.LT.1)GOTO 870
	IF(J.GT.24)GOTO 870
	IF(B1(J).LE.-2)GOTO 1400
	DO 860 I=1,F
	IF(DIE(I).EQ.25-J)GOTO 890
860	CONTINUE
870	CALL PRINT('YOU CAN''T DO THAT@')
	GOTO 630

890	B1(26)= B1(26)-1
	T(I)=26
	DIE(I)= DIE(I)*100
	GOTO 1580
C
C		NORMAL PLAYER MOVE
C
930	CALL CURSOR(2,13+P)
	CALL PRINT('         @')
	CALL CURSOR(2,13)
	CALL OSTR(FROMTO(1,2))
	CALL CURSOR(3,13+P)
	CALL RDNUM(I)
	CALL CURSOR(2,13)
	CALL OSTR(FROMTO(1,3))
	CALL CURSOR(8,13+P)
	CALL RDNUM(J)
	CALL CURSOR(2,13)
	CALL OSTR(FROMTO(1,1))
	CALL CLEAR

1000	IF(I.EQ.0)GOTO 1050
	IF(I.GT.24)GOTO 1390
	IF(J.GT.24)GOTO 1390
	IF(J.EQ.0)GOTO 1660
	GOTO 1410

1050	IF(J.EQ.0)GOTO 7380
1070	DO 1140 K=1,24
	IF(B1(K).LT.1)GOTO 1140
	DO 1140 K1=1,F
	IF(DIE(K1).GT.99)GOTO 1140
	T1= DIE(K1)
	TEMP = K-T1
	IF(TEMP.LT.1.0)GOTO 1140
	SUB = K-T1
	IF(B1(SUB).GT.-2)GOTO 1360
1140	CONTINUE
1170	DO 1190 K=7,26
	IF(B1(K).GT.0)GOTO 1340
1190	CONTINUE
1210	DO 1320 K1=1,F
	IF(DIE(K1).GT.99)GOTO 1320
1240	DO 1270 DUM=1,6
	K = 7-DUM
	IF(K.LT.DIE(K1))GOTO 1270
	IF(B1(K).GT.0)GOTO 1360
1270	CONTINUE
1280	DO 1320 DUM=1,6
	K = 7-DUM
	IF(B1(K).LT.1)GOTO 1320
	T1= K
	GOTO 1360
1320	CONTINUE

1340	L= F
	GOTO 2030

1360	DUM = K-T1
	CALL PRINT('YOU CAN MOVE FROM @')
	CALL WRNUM(K)
	CALL PRINT(' TO @')
	CALL WRNUM(DUM)
	GOTO 630

1380	CALL PRINT('NOT QUITE YET@')
	GOTO 630
1390	CALL PRINT('TRY AGAIN@')
	GOTO 630
1400	CALL PRINT('I AM ALREADY AT @')
	CALL WRNUM(J)
	GOTO 630

1410	IF(B1(I).LE.0)GOTO 1710
	IF(B1(J).LE.-2)GOTO 1400

1480	DO 1530 K=1,F
	IF((I-J).NE.DIE(K))GOTO 1530
	DIE(K)= DIE(K)*100
	T(K)= I
	GOTO 1570
1530	CONTINUE
	CALL PRINT('CREATIVE, BUT WRONG@')
	GOTO 630

1570	CALL CLEAR
	B1(I)= B1(I)-1
1580	IF(B1(J).NE.-1)GOTO 1640
	B1(25)= B1(25)-1
	O1= O1+1
	H(O1)= J
	B1(J)= 0
1640	B1(J)= B1(J)+1
	GOTO 2020

1660	DO 1690 K=7,26
	IF(B1(K).GT.0)GOTO 1380
1690	CONTINUE
	IF(B1(I).GT.0)GOTO 1740
1710	CALL PRINT('YOU HAVE NO PIECES ON @')
	CALL WRNUM(I)
	GOTO 630

1740	DO 1760 K=1,F
	IF(DIE(K).EQ.I)GOTO 1860
1760	CONTINUE
1770	DUM = I+1
	DO 1790 K=DUM,6
	IF(B1(K).GT.0)GOTO 1840
1790	CONTINUE
1800	DO 1830 K=1,F
	IF(DIE(K).GT.99)GOTO 1830
	IF(DIE(K).GT.I)GOTO 1860
1830	CONTINUE
1840	CALL PRINT('COUNT AGAIN@')
	GOTO 630

1860 	B1(I)= B1(I)-1
	PLAYER = PLAYER-1
	CALL CURSOR(12,13)
	CALL OSTR(PCS(1))
	CALL WRNUM(PLAYER)
	DO 1890 K1=1,6
	IF(B1(K1).GT.0)GOTO 1950
1890	CONTINUE
1920	CALL BOARD(A1,B1)
	CALL CLEAR
1930	CALL PRINT('DARN IT, YOU WIN@')
1931	CALL WAIT
	CALL WAIT
1940	GOTO 7410

1950	T(K)= I
1960	DIE(K)= DIE(K)*100
1970	GOTO 2020

2020	CONTINUE

2030	CALL BOARD(A1,B1)
2040	CALL CLEAR
	CALL PRINT('OK (Y/N) ? @')
2050	ANS = CI(3)
	CALL CLEAR
	IF(ANS.NE.X'FF')GOTO 2060
	CALL PRINT('ARE YOU FINISHED YET ? @')
	GOTO 2050
2060	IF(ANS.EQ.CHRY)GOTO 2300
	IF(ANS.EQ.13) GOTO 2300
	IF(ANS.NE.CHRN)GOTO 2040
2100	DO 2200 I=1,F
	IF(DIE(I).LT.100)GOTO 2130
	DIE(I)= DIE(I)/100
2130	K= DIE(I)
	K1= T(I)
	B1(K1)= B1(K1)+1
	IF(K1-K.LT.1)GOTO 2195
	IF(K1.NE.26) GOTO 2190
	K1= 25
2190	SUB = K1-K
	B1(SUB)= B1(SUB)-1
	GOTO 2200
2195	PLAYER = PLAYER+1
	CALL CURSOR(12,13)
	CALL OSTR(PCS(1))
	CALL WRNUM(PLAYER)
2200	CONTINUE
2210	IF(O1.EQ.0)GOTO 2260
2220	DO 2250 I=1,O1
	SUB = H(I)
	B1(SUB)= -1
2250	B1(25)= B1(25)+1
2260	CALL BOARD(A1,B1)
2275	CALL CLEAR
2280	CALL PRINT('RE-ENTER MOVES@')
	BADCNT = 0
	GOTO 580
C
C		COMPUTER'S MOVE
C
2300	BADCNT = 0
	CALL CLEAR
	W = RND(1.0)
	IF(W.LT.0.85) GOTO 2340
	DUM = PLAYER-COMP+3
	IF(DUM.LT.1) DUM = 1
	IF(DUM.GT.5) DUM = 5
	GOTO (2305,2310,2315,2320,2325),DUM
2305	CALL PRINT('PHOOEY ON YOU@')
	GOTO 2335
2310	CALL PRINT('NOT MUCH OF A LEAD@')
	GOTO 2335
2315	DO 2316 DUM=1,24
	DUM1 = 25-DUM
	IF(B1(DUM1).GT.0) GOTO 2317
2316	CONTINUE
2317	DO 2318 DUM2=1,24
	IF(B1(DUM2).LT.0) GOTO 2319
2318	CONTINUE
2319	IF(DUM-DUM2)2320,2330,2310

2320	CALL PRINT('I HAVE THE EDGE@')
	GOTO 2335
2325	CALL PRINT('GOODIE - I''M WINNING@')
	GOTO 2335
2330	CALL PRINT('I''LL THRASH THE PANTS OFF YOU@')

2335	CALL WAIT
2340	CALL ROLL(F,DIE)
	M(9)= -9999999.
	CALL CLEAR
2345	CALL PRINT('   *** QUIET - I''M THINKING ***@')
2350	DO 2360 IT=1,F
2360	H(IT)= 0
	T1 = F
2390	F2= 0
2410	F4= 0
2420	IF(B1(25).EQ.0)GOTO 2790
2440	SUB =1+F4
	DUM = DIE(SUB)
	IF(B1(DUM).LT.2)GOTO 2530
2460	IF(F4.EQ.0)GOTO 2480
2470	CALL TEST(J1,K,K1,B1,DIE,H,T)
2480	GOTO 3420

2490	IF(F.EQ.1)GOTO 3550
2500	CALL CLEAR
	MOVCNT = MOVCNT+1
	IF(MOVCNT.GT.3) MOVCNT = 3
	GOTO (2501,2502,2503),MOVCNT
2501	CALL PRINT('I CAN''T MOVE@')
	GOTO 2520
2502	CALL PRINT('OH NO, NOT AGAIN!@')
	GOTO 2520
2503	CALL PRINT('YOU DIRTY RAT@')
2520	CALL WAIT
	GOTO 570

2530	F4= F4+1
	B1(25)= B1(25)+1
	K= DIE(F4)
	B1(K)= B1(K)-1
	IF(B1(K).NE.0)GOTO 2640
	H(F4)= K
	B1(K)= -1
2640	T(F4)= 25
	J1= F4+1
	IF(F4.LT.F)GOTO 2420
	DO 2770 K=1,F
	K1= DIE(K)
	B1(K1)= B1(K1)+1
	IF(H(K).EQ.0)GOTO 2740
	B1(K1)= 1
2740	B1(25)= B1(25)-1
	M(2*K-1)= 25.0
	M(2*K)= DIE(K)
2770	CONTINUE
	GOTO 3550

2790	IF(F4.NE.0)GOTO 2820
	J1= 1
2820	N= 1
2840	DO 2860 K=1,18
	IF(B1(K).LT.0)GOTO 2890
2860	CONTINUE
	GOTO 6840

2890	IF(B1(N).LE.-1)GOTO 2990
2900	N= N+1
2910	IF(N.LE.24)GOTO 2890
2930	J1= J1-1
2940	IF(J1.LT.1)GOTO 3420
	N= T(J1)+1
	CALL TEST(J1,K,K1,B1,DIE,H,T)
	GOTO 2890

2990	K= DIE(J1)
	IF(N+K.GT.24)GOTO 2930
	SUB = N+K
	IF(B1(SUB).GE.2)GOTO 2900
	T(J1)= N
	B1(N)= B1(N)+1
	SUB = N+K
	B1(SUB)= B1(SUB)-1
3060	IF(B1(SUB).NE.0)GOTO 3090
	H(J1)= SUB
	B1(SUB)= -1
3090	J1= J1+1
3100	IF(J1.GT.F)GOTO 3130
	N= T(J1-1)
	GOTO 2840

3130	IF(F2.LT.F)GOTO 3230
	IF(F.EQ.1)GOTO 3230
	IF(F.EQ.3)GOTO 3230
	IF(T(1).EQ.T(2))GOTO 3250
	IF(T(1)+DIE(1).NE.T(2))GOTO 3230
	IF(H(1).NE.0)GOTO 3230
	IF(T(1)+DIE(2).GT.24)GOTO 3230
	SUB = T(1)+DIE(2)
	IF(B1(SUB).GE.2)GOTO 3230
	GOTO 3250

3230	CALL ANALYZ(F,B,B0,B1,DIE,H,M,T)
3250	J1= F
3260	N= T(J1)+1
3270	CALL TEST(J1,K,K1,B1,DIE,H,T)
	GOTO 2890

3420	IF(F2.GE.F)GOTO 3500
3430	IF(DIE(1).EQ.DIE(2))GOTO 3500
3450	F2=2
3460	INTG= DIE(2)
3470	DIE(2)= DIE(1)
3480	DIE(1)= INTG
	GOTO 2410

3500	IF(M(9).GT.-9999999.)GOTO 3550
3520	F= F-1
3530	IF(F.GT.0)GOTO 2390
	GOTO 2500

3550	MOVCNT = 0
	DO 3555 Y=22,25
	CALL CURSOR(2,Y)
	CALL PRINT('           @')
3555	CONTINUE

3560	DO 3750 I=1,F
3570	K= I*2-1
	IF(M(K).NE.25.0)GOTO 3620
	CALL CURSOR(3,21+I)
	CALL PRINT('BAR@')
	CALL CURSOR(8,21+I)
	DUM = M(K+1)
	CALL WRNUM(DUM)
3600	B1(25)= B1(25)+1
	GOTO 3700

3620	IF(M(K+1).LT.25.0)GOTO 3670
3630	CALL CURSOR(8,21+I)
	CALL PRINT('OFF@')
	CALL CURSOR(3,21+I)
	K = M(K)
	CALL WRNUM(K)
3650	B1(K)= B1(K)+1
	COMP = COMP-1
	CALL CURSOR(12,21)
	CALL OSTR(PCS(1))
	CALL WRNUM(COMP)
	GOTO 3750

3670	CALL CURSOR(2,21)
	CALL OSTR(FROMTO(1,1))
3671	CALL CURSOR(3,21+I)
	DUM = M(K)
	CALL WRNUM(DUM)
3672	CALL CURSOR(8,21+I)
	DUM = M(K+1)
	CALL WRNUM(DUM)
	K= M(K)
3690	B1(K)= B1(K)+1
3700	K= M(2*I)
3710	B1(K)= B1(K)-1
3720	IF(B1(K).NE.0)GOTO 3750
	B1(26)= B1(26)+1
	B1(K)= -1
3750	CONTINUE
	GOTO 550

6840	DO 6860 K=1,F
6860	B0(K)= 0
6880	DO 7070 K=J1,F
6890	K1= 25-DIE(K)
6900	IF(B1(K1).LT.0)GOTO 7040
6910	DUM = K1-1
	DO 6930 IT=19,DUM
	T1 = IT
6920	IF(B1(IT).LT.0)GOTO 7310
6930	CONTINUE
6940	DUM1 = 25-DIE(K)
	DO 6960 K1=DUM1,24
6950	IF(B1(K1).LT.0)GOTO 7040
6960	CONTINUE

6965	CALL BOARD(A1,B1)
6966	CALL CLEAR
6970	CALL PRINT('I WIN!!!@')
6971	CALL WAIT
6980	CONTINUE
	GOTO 7410

7040	B0(K)= K1
7050	T(K)= 0
7060	B1(K1)= B1(K1)+1
7070	CONTINUE

	DO 7100 K=19,24
	IF(B1(K).LT.0)GOTO 7120
7100	CONTINUE
	GOTO 6965

7120	IF(B1(26).GT.0)GOTO 7250
7130	DO 7150 K=19,24
7140	IF(B1(K).GT.0)GOTO 7250
7150	CONTINUE
7160	DO 7180 K=1,F
	IF(T(K).GT.0)GOTO 7250
7180	CONTINUE
7190	DO 7230 K=1,F
	SUB = B0(K)
	B1(SUB)= B1(SUB)-1
	M(2*K-1)= B0(K)
7230	M(2*K)= 27.0
	GOTO 3550

7250	CONTINUE
7260	IF(T(1).GT.0)GOTO 7300
7270	IF(T(2).GT.0)GOTO 7300
7280	IF(F2.LT.F)GOTO 7300
	GOTO 7310

7300	CALL ANALYZ(F,B,B0,B1,DIE,H,M,T)
7310	CONTINUE
7320	DO 7360 K=J1,F
7330	IF(B0(K).EQ.0)GOTO 7360
	K1= B0(K)
	B1(K1)= B1(K1)-1
7360 	CONTINUE
	GOTO 2890

7380	CONTINUE
7390	CALL CLEAR
	CALL PRINT('I AGREE - YOU ARE IN POOR SHAPE@')
	CALL WAIT

7410	CALL CLEAR
7440	CALL PRINT('PLAY AGAIN (Y/N) ? @')
7450	ANS = CI(0)
	CALL CLEAR
	IF(ANS.EQ.CHRN)GOTO 7500
	IF(ANS.EQ.CHRY)GOTO 240
	GOTO 7440
7500	CALL CO(12)
	CALL CO(27)
	CALL CO(11)
	STOP
	END