(FLECS VERSION 22.37) 12-APR-80 13:46:38 PAGE 00001 ---------------------------------------- C Changed to FLECS 11-Apr-80 M.R.Brown C Changed to RSX 10-Dec-79 M.R.Brown C my comments are Tasteful Dual Case C C BACKGAMMON PLAYING PROGRAM. C HUB GOT THIS. C I THINK HE GOT IT AT PRIME. C C THE :17 WAS CHANGED TO 15. C THE :20 WAS CHANGED TO 16. C THE FUNCTIONS AND(), OR(), LS() AND RS() WERE C RENAMED IAND(), IOR(), ILS() AND IRS(). C Then IRS and ILS were changed to ISHFT C with appropriate signs C THE CALLS TO TIMDAT AND RND IN MAIN (THE SEED C WERE CHANGED TO A CALL TO RNDMZE. C rnd becomes RAN C THE UNIT NUMBERS OF THE I/O STREAMS WERE CHANGED C FROM 1 AND 1 TO 5 AND 6. C and then changed back to 1 C THE CALL TO CMREAD IN MAIN WAS CHANGED TO A CALL C TO YESNO. C this is a simple read now C TNOU WAS CHANGED TO PTTY. C Then PTTY was change to list directed i/o C THE SLEW IN THE FORMAT STATEMENTS WAS MADE A LITTLE C BIT MORE ANSI. C 00001 INTEGER BOARD(26),ROLL(2),MOVE(2,4),BOARD1(26) 00002 INTEGER BOARD2(26),SCORE(6),BOARD3(26),TEST(2) 00003 BYTE IBUF(20) C LOGICAL YESNO 00004 REAL A 00005 T1=SECNDS(0.0) C FLECS cannot have an IF expression continue to next line 00006 IF(T1.GT.46800.0.AND.T1.LT.59400.0) 00007 . WRITE(1,*) 00008 1. 'Time wasted playing computer games can never be recovered!' 00008 ...FIN 00008 IF(T1.LT.43200.0.AND.T1.GT.30600.0) 00009 . WRITE(1,*) 00010 1. 'Time wasted playing computer games can never be recovered!' 00010 ...FIN C Now lets spin up the random number generator so we always get C a reasonable start. 00010 I1=T1/2000 00011 I2=SQRT(T1)/10 00012 DO(I=1,(I1/10)+10)ID=RAN(I1,I2) 00015 9 CALL INIT(BOARD) C CALL RNDMZE 00016 CALL PRINTB(BOARD) C IF(.NOT. YESNO('DO YOU NEED INSTRUCTIONS? ')) GO TO 80 00017 WRITE(1,*) 'DO YOU NEED INSTRUCTIONS? ' 00018 READ(1,99)NCHRS,(IBUF(I),I=1,NCHRS) 00019 99 FORMAT(Q,20A1) 00020 IF(IBUF(1).EQ.'N'.OR.IBUF(1).EQ.'n')GOTO 80 00021 WRITE(1,*) 00022 +' THIS IS THE PLAYING BOARD, IT LOOKS DIFFERENT' 00022 WRITE(1,*) (FLECS VERSION 22.37) 12-APR-80 13:46:38 PAGE 00002 00023 +'FROM THE NORMAL BOARD BECAUSE YOUR OPPONETS SIDE HAS' 00023 WRITE(1,*) 00024 +'BEEN ROTATED AND PLACED TO THE LEFT OF YOUR SIDE. A' 00024 WRITE(1,*) 00025 +'PLUS SIGN REPRESENTS A POINT ON THE BOARD. THERE ARE' 00025 WRITE(1,*) 00026 +'TWO POINTS BY THEMSELVES ON THE LEFT AND RIGHT.' 00026 WRITE(1,*) 00027 +'THESE ARE OCCUPIED BY MEN AFTER THEY HAVE BEEN HIT.' 00027 WRITE(1,*) 00028 +'THE COMPUTER PLAYS RED (SYMBOLIZED AS -R-) AND MOVES' 00028 WRITE(1,*) 00029 +'FROM RIGHT TO LEFT. THE PLAYER USES THE WHITE MEN' 00029 WRITE(1,*) 00030 +'( -W- ) AND MOVES FROM LEFT TO RIGHT.' 00030 WRITE(1,*) 00031 +' THE NUMBERS BELOW THE POINTS ARE USED WHEN' 00031 WRITE(1,*) 00032 +'MOVING YOUR MEN. THE POINTS ARE NUMBERED FROM 1 TO' 00032 WRITE(1,*) 00033 +'26, YOU MUST MENTALLY ADD THE TENS DIGIT, THERE' 00033 WRITE(1,*) 00034 +'WASN T ROOM TO PRINT IT. MOVE ARE MADE BY SPECIFYING' 00034 WRITE(1,*) 00035 +'THE -FROM- POINT AND THE ROLL OF THE DIE. THE' 00035 WRITE(1,*) 00036 +'NUMBERS ARE SEPARATED BY COMMAS. TO MAKE THE -LOVERS' 00036 WRITE(1,*) 00037 +'LEAP- MOVE ON AN OPENING ROLL OF 6 5, YOU WOULD TYPE' 00037 WRITE(1,*) 00038 +'2,6,8,5. THE COMPUTER WOULD THEN MAKE THAT MOVE FOR' 00038 WRITE(1,*) 00039 +'YOU.' C*** DETERMINE WHO GOES FIRST 00039 80 CONTINUE 00040 WRITE(1,*)' ' 00041 CALL GETROL(ROLL,I1,I2) 00042 WRITE(1,89) ROLL(1) 00043 89 FORMAT(1X, 'I ROLLED A', I2) 00044 WRITE(1,88) ROLL(2) 00045 88 FORMAT(1X, 'YOU ROLLED A', I2) 00046 IF(ROLL(1)-ROLL(2)) 81,82,83 C*** PLAYER GOES FIRST 00047 81 CONTINUE 00048 WRITE(1,*)'YOU GO FIRST' 00049 CALL PRINTB(BOARD) 00050 GO TO 55 C*** ROLL AGAIN, DOUBLES 00051 82 CONTINUE 00052 WRITE(1,*)'DOUBLES, ROLL AGAIN.' 00053 GO TO 80 C*** COMPUTER GOES FIRST 00054 83 CONTINUE 00055 WRITE(1,*)'I GO FIRST' 00056 GO TO 4 00057 1 CALL GETROL(ROLL,I1,I2) C*** SWITCHES, I - SWAP ROLLS, J - NOT 2 MOVES, K - DOUBLE ROLL 00058 4 ISW=0 00059 JSW=0 00060 KSW=0 00061 ISCORE=1000 00062 WRITE(1,2) ROLL (FLECS VERSION 22.37) 12-APR-80 13:46:38 PAGE 00003 00063 2 FORMAT(1X, 'I ROLL',2I2,'.') C*** INITIALIZE BASED ON ROLL 00064 3 CONTINUE 00065 MOVE(1,1)=0 00066 MOVE(2,1)=-ROLL(1) 00067 MOVE(1,2)=0 00068 MOVE(2,2)=-ROLL(2) 00069 10 CONTINUE 00070 CALL MAKNXT(BOARD,BOARD1,MOVE(1,1)) 00071 IF(MOVE(1,1).EQ.-1) GO TO 100 00072 20 CONTINUE 00073 CALL MAKNXT(BOARD1,BOARD2,MOVE(1,2)) 00074 IF(MOVE(1,2).EQ.-1) GO TO 30 00075 CALL EVAL(BOARD2,SCORE) 00076 JSW=1 00077 IF(SCORE(6).GT.ISCORE) GO TO 20 00078 ISCORE=SCORE(6) 00079 DO(I=1,26)BOARD3(I)=BOARD2(I) 00082 GO TO 20 C*** SET POINT FOR SECOND ROLL TO BEGINNING 00083 30 CONTINUE 00084 MOVE(1,2)=0 00085 GO TO 10 C*** END OF FINDING MOVES 00086 50 CONTINUE 00087 IF(JSW.NE.0) GO TO 52 C*** CHECK IF THERE IS AT LEAST ONE THING TO DO. 00088 ISCORE=1000 00089 DO 70 J=2,26 00090 MOVE(1,1)=J 00091 MOVE(1,2)=J 00092 I=1 00093 IF(MOVCHK(BOARD,MOVE(1,I)).NE.0) GO TO 71 00094 I=2 00095 IF(MOVCHK(BOARD,MOVE(1,I)).EQ.0) GO TO 70 C*** MAKE THE FIRST ROLL 00096 71 CONTINUE 00097 JSW=1 00098 CALL MAKMOV(BOARD,BOARD2,MOVE(1,I)) 00099 CALL EVAL(BOARD2,SCORE) 00100 IF(SCORE(6).GT.ISCORE) GO TO 70 00101 ISCORE=SCORE(6) 00102 DO(I=1,26)BOARD3(I)=BOARD2(I) 00105 70 CONTINUE 00106 IF(JSW.NE.0) GO TO 52 00107 WRITE(1,*)'I CANNOT MOVE' 00108 GO TO 53 C*** IF DOUBLES, DO MOVE TWICE 00109 52 CONTINUE 00110 DO(I=1,26)BOARD(I)=BOARD3(I) 00113 IF(KSW.NE.0) GO TO 56 00114 KSW=1 00115 IF(ROLL(1).NE.ROLL(2)) GO TO 56 00116 JSW=0 00117 GO TO 3 00118 56 CONTINUE C*** INITIALIZE KSW FOR PLAYER 00119 KSW=0 00120 CALL PRINTB(BOARD) 00121 CALL EVAL(BOARD,SCORE) 00122 IF(SCORE(2).EQ.0) GO TO 54 00123 GO TO 53 (FLECS VERSION 22.37) 12-APR-80 13:46:38 PAGE 00004 C*** END OF GAME, COMPUTER WON 00124 54 WRITE(1,*)'I WIN, THANKS FOR THE GAME' 00125 CALL EXIT 00126 GO TO 9 C*** GET THE PLAYERS MOVE 00127 53 CONTINUE 00128 CALL GETROL(ROLL,I1,I2) 00129 55 CONTINUE 00130 CALL INPMOV(BOARD,ROLL) 00131 CALL PRINTB(BOARD) 00132 CALL EVAL(BOARD,SCORE) 00133 IF(SCORE(1).EQ.0) GO TO 65 00134 GO TO 1 C*** PLAYER WON 00135 65 WRITE(1,*)'YOU WIN, THANKS' 00136 CALL EXIT 00137 GO TO 9 C*** SWAP THE ROLLS 00138 100 CONTINUE 00139 IF(ISW.EQ.1) GO TO 50 00140 MOVE(1,1)=0 00141 MOVE(2,1)=-ROLL(2) 00142 MOVE(1,2)=0 00143 MOVE(2,2)=-ROLL(1) 00144 ISW=1 00145 GO TO 10 00146 END (FLECS VERSION 22.37) ---------------------------------------- 00001 INTEGER FUNCTION MOVCHK(BOARD,MOVE) C C PGM: A ROUTINE TO CHECK A BACKGAMMON MOVE. C C SYS: BGAMON C C ENT: BOARD - A 26 INTEGER ARRAY REPRESENTING THE THE STATE C OF THE PLAYING BOARD. C MOVE - A 2 INTEGER ARRAY REPRESENTING THE MOVE TO BE CHECKED C C RTN: BOARD - N/C C MOVE - N/C C MOVCHK - 0 IF NOT LEGAL, 1 IF LEGAL C C FNC: CHECK FOR A PIECE ON THE FROM POINT, CHECK IF MEN MUST ENTER, C CHECK IF MOVE BEARS OFF MEN AND IF THAT IS LEGAL, CHECK FOR C THE NORMAL MOVES. UP TO FOUR MOVES MAY BE TESTED. C THE PLAYER'S MOVES ARE IN THE POSITIVE DIRECTION, THE C COMPUTER'S ARE IN THE NEGATIVE. C C REV: 1.0 C* 00002 INTEGER IOURS,OFFBRD C INTEGER MOVCHK,BOARD(26),MOVE(2),IBRDF,IBRDT 00003 INTEGER BOARD(26),MOVE(2),IBRDF,IBRDT C*** INITIALIZE USEFUL PARAMETERS. 00004 MOVCHK=0 00005 MOVEP=MOVE(1) 00006 MOVER=MOVE(2) 00007 MOVET=MOVEP+MOVER (FLECS VERSION 22.37) 12-APR-80 13:46:38 PAGE 00005 00008 IBRDF=BOARD(MOVEP) 00009 IBRDT=BOARD(MOVET) C*** IF IOURS=1 - COMPUTERS MEN IOURS=0 - PLAYERS MEN 00010 IOURS=0 00011 IF(MOVE(2).LT.0) IOURS=1 C C*** BRANCH TO TEST CASES BASED ON MOVE POINT SPECIFIED. C*** IF THE MOVE IS TO OFF THE BOARD, A VACANT SQUARE MIGHT BE LEGAL. C*** IN OTHER CASES, A VACANT SQUARE IS ILLEGAL. C*** IF THE MOVE TO POINT IS OCCUPIED BY OPPOSING MEN, MORE THAN C*** ONE MAN MAKES AN ILLEGAL MOVE. C 00012 OFFBRD=26 00013 IF(IOURS.EQ.0) OFFBRD=1 00014 IF(BOARD(OFFBRD).NE.0.AND.MOVEP.NE.OFFBRD) RETURN C*** BRANCH IF BEARING OFF SPECIFIED. 00015 IF(IBRDF.EQ.0) RETURN 00016 IF(ISHFT(IBRDF,-4).NE.IOURS) RETURN 00017 IF(MOVET.GT.25.OR.MOVET.LT.2) GO TO 100 00018 IF(IBRDT.EQ.0) GO TO 10 00019 IF(ISHFT(IBRDT,-4).EQ.IOURS) GOTO 10 00020 IF(IAND(IBRDT,15).LT.2) GOTO 10 00021 RETURN 00022 10 CONTINUE 00023 MOVCHK=1 00024 RETURN C*** CHECK BEARING OFF TYPE MOVES 00025 100 CONTINUE C*** CHECK IF ALL THE MEN ARE IN 00026 DO 105 I=1,19 00027 I1=I 00028 IF(IOURS.NE.0) I1=27-I 00029 IF(BOARD(I1).EQ.0) GOTO 105 00030 IF(ISHFT(BOARD(I1),-4).EQ.IOURS) RETURN 00031 105 CONTINUE C*** IF BEARING OFF EXACTLY, BRANCH TO LEGAL MOVE RETURN. 00032 IF(MOVET.EQ.26.OR.MOVET.EQ.1) GO TO 110 C*** MAKE SURE NO MEN ON HIGHER POINTS 00033 GO TO (120,130),IOURS+1 00034 WRITE(1,*)'IOURS - ILLEGAL VALUE' 00035 RETURN 00036 120 CONTINUE 00037 MOVEP1=MOVEP-1 00038 IF(MOVEP1.LE.20) GO TO 126 00039 DO 125 I=20,MOVEP1 00040 IF(BOARD(I).EQ.0) GO TO 125 00041 IF(ISHFT(BOARD(I),-4).EQ.IOURS) RETURN 00042 125 CONTINUE 00043 126 MOVCHK=1 00044 RETURN 00045 130 CONTINUE 00046 MOVEP1=MOVEP+1 00047 IF(MOVEP1.GE.7) GO TO 136 00048 DO(I=MOVEP1,7) 00049 . IF(ISHFT(BOARD(I),-4).EQ.IOURS) RETURN 00050 ...FIN 00051 136 MOVCHK=1 00052 RETURN 00053 110 CONTINUE 00054 MOVCHK=1 00055 RETURN 00056 END (FLECS VERSION 22.37) 12-APR-80 13:46:38 PAGE 00006 (FLECS VERSION 22.37) ---------------------------------------- 00001 SUBROUTINE NXTMOV(BOARD,MOVE) C C PGM: GIVEN A ROLL OF DICE AND THE LAST POINT, GENERATE THE C NEXT POSSIBLE POINT IN A KNOWN SEQUENCE. C C SYS: BGAMON C C ENT: MOVE - CONTAINS POINT AND ROLL C BOARD - THE PLAYING BOARD IN USE C C RTN: ROLL - N/C C POINT - THE NEXT POINT IN SEQUENCE C BOARD - N/C C C FNC: IF THE POINT IS ALL ZERO, GENERATE THE INITIAL POINT FROM THE C ROLL OF THE DIE. OTHERWISE INCREMENT THE POINT. C WHEN THE POINT REACHES THE END OF THE BOARD, RETURN -1 C AS THE VALUE OF THE POINT. C C REV: 1.0 C* 00002 INTEGER ROLL,POINT,BOARD(26),MOVE(2) C*** TEST FOR INITIALIZATION REQUIREMENT. 00003 POINT=MOVE(1) 00004 ROLL=MOVE(2) 00005 IF(POINT.EQ.0) GO TO 100 C*** FIND THE NEXT POINT 00006 IOURS=0 00007 IF(ROLL.LT.0) IOURS=1 00008 POINT=POINT+1 00009 DO 10 I=POINT,26 00010 IF(BOARD(I).EQ.0) GO TO 10 00011 IF(ISHFT(BOARD(I),-4).NE.IOURS) GO TO 10 00012 POINT=I 00013 GO TO 200 00014 10 CONTINUE 00015 POINT=-1 00016 GO TO 200 C*** INITIALIZE THE POINT 00017 100 CONTINUE 00018 IOURS=0 00019 IF(ROLL.LT.0) IOURS=1 00020 DO 110 I=1,26 00021 IF(BOARD(I).EQ.0) GO TO 110 00022 IF(ISHFT(BOARD(I),-4).NE.IOURS) GOTO 110 00023 POINT=I 00024 GO TO 200 00025 110 CONTINUE 00026 POINT=-1 C*** RESTORE THE MOVE VECTOR 00027 200 CONTINUE 00028 MOVE(1)=POINT 00029 MOVE(2)=ROLL 00030 RETURN 00031 END (FLECS VERSION 22.37) (FLECS VERSION 22.37) 12-APR-80 13:46:38 PAGE 00007 ---------------------------------------- 00001 SUBROUTINE GETROL(ROLL,I1,I2) C C PGM: ROUTINE TO RETURN A RANDOM ROLL OF THE DICE. C C SYS: BGAMON C C ENT: N/A C C RTN: ROLL(2) - THE TWO DICE VALUES. C C FNC: GET THE RANDOM VALUE AND CONVERT TO AND INTEGER IN C THE RANGE 1-6. C C REV: 1.0 C* 00002 INTEGER ROLL(2) 00003 ROLL(1)=INT(6.0*RAN(I1,I2))+1 00004 ROLL(2)=INT(6.0*RAN(I1,I2))+1 00005 RETURN 00006 END (FLECS VERSION 22.37) ---------------------------------------- 00001 SUBROUTINE MAKMOV(OLDBRD,NEWBRD,MOVE) C C PGM: MAKE THE MOVE ON OLD BOARD AND GENERATE NEW BOARD. C C SYS: BGAMON C C ENT: OLDBRD - THE BOARD ON WHICH TO MAKE THE MOVE C NEWBRD - A POINTER TO THE NEW BOARD C MOVE - THE MOVE TO MAKE C C RTN: OLDBRD - N/C C NEWBRD - THE BOARD WITH THE MOVE MADE C MOVE - N/C C C FNC: THE MOVE IS ASSUMED TO BE CORRECT. ROLLS IN THE POSITIVE C DIRECTION A PLAYER MOVES. IN THE NEGATIVE, COMPUTER. C C REV: 1.0 C* 00002 INTEGER OLDBRD(26),NEWBRD(26),MOVE(2) 00003 DO 10 I=1,26 00004 10 NEWBRD(I)=OLDBRD(I) C*** INITIALIZE USEFUL CONSTANTS 00005 MOVEP=MOVE(1) 00006 MOVER=MOVE(2) 00007 MOVET=MOVEP+MOVER 00008 IBRDF=OLDBRD(MOVEP) 00009 IBRDT=OLDBRD(MOVET) 00010 IOURS=ISHFT(IBRDF,-4) C*** MAKE THE MOVE C 00011 IF(MOVET.GT.25.OR.MOVET.LT.2) GO TO 100 00012 IF(ISHFT(IBRDF,-4).EQ.IOURS) GO TO 20 00013 WRITE(1,*)'ERROR, MOVING OPPS MAN' (FLECS VERSION 22.37) 12-APR-80 13:46:38 PAGE 00008 00014 RETURN 00015 20 CONTINUE C*** BRANCH IF HITTING 00016 IF(ISHFT(IBRDT,-4).NE.IOURS.AND.IBRDT.NE.0) GO TO 200 00017 NEWBRD(MOVEP)=NEWBRD(MOVEP)-1 00018 IF(IAND(NEWBRD(MOVEP),15).EQ.0) NEWBRD(MOVEP)=0 C CHECK THE NEXT AREA FOR CORRECT OPERATION 00019 ITEMP=ISHFT(IOURS,4) 00020 NEWBRD(MOVET)=(ITEMP.OR.NEWBRD(MOVET)+1) 00021 RETURN C*** PERFORM THE HIT TYPE MOVE 00022 200 CONTINUE 00023 NEWBRD(MOVEP)=NEWBRD(MOVEP)-1 00024 IF(IAND(NEWBRD(MOVEP),15).EQ.0) NEWBRD(MOVEP)=0 00025 NEWBRD(MOVET)=ISHFT(IOURS,4)+1 00026 OFFBRD=26-IOURS*25 00027 NEWBRD(OFFBRD)=(ISHFT(1-IOURS,4).OR.NEWBRD(OFFBRD)+1) 00028 RETURN 00029 100 CONTINUE C*** BEARING OFF TYPE MOVE 00030 NEWBRD(MOVEP)=NEWBRD(MOVEP)-1 00031 IF(IAND(NEWBRD(MOVEP),15).EQ.0) NEWBRD(MOVEP)=0 00032 RETURN 00033 END (FLECS VERSION 22.37) ---------------------------------------- 00001 SUBROUTINE PRINTB(BOARD) C C PGM: PRINT THE BACKGAMMON BOARD C C SYS: BGAMON C C ENT: BOARD - THE BOARD TO PRINT C C RTN: N/C C C FNC: PRINT THE BOARD IN A CONVIENT FORMAT C C REV: 1.0 C* 00002 INTEGER BOARD(26),PRNTBF(26) 00003 INTEGER ABLANK, AR, AW 00004 DATA ABLANK/' '/, AR/'R'/, AW/'W'/ 00005 DO 10 I=1,15 00006 COUNT=16-I 00007 PFLAG=0 00008 DO 20 J=1,26 00009 PRNTBF(J)=ABLANK 00010 IF(IAND(BOARD(J),15).LT.COUNT) GO TO 20 00011 PRNTBF(J)=AR 00012 IF(ISHFT(BOARD(J),-4).EQ.0) PRNTBF(J)=AW 00013 PFLAG=1 00014 20 CONTINUE C*** PRINT THE BUFFER IF PFLAG=1 00015 IF(PFLAG.EQ.0) GO TO 10 00016 WRITE(1,30) PRNTBF 00017 30 FORMAT(2X,A1,2X,6A2,1X,6A2,2X,6A2,1X,6A2,1X,A1) 00018 10 CONTINUE 00019 WRITE(1,*) (FLECS VERSION 22.37) 12-APR-80 13:46:38 PAGE 00009 00020 $'^ + + + + + + + + + + + + + + + + + + + + + + + + ^' 00020 WRITE(1,*) 00021 $'1 2 3 4 5 6 7 8 9 | 11| 13 | 15| 17| 19 | 21| 23| 25 |' 00021 WRITE(1,*) 00022 $' 10 12 14 16 18 20 22 24 26' 00022 RETURN 00023 END (FLECS VERSION 22.37) ---------------------------------------- 00001 SUBROUTINE INIT(BOARD) C C PGM: INITIALIZE THE PLAYING BOARD. C C SYS: BGAMON C C ENT: BOARD - A BOARD TO INITIALIZE C C RTN: BOARD - THE INITIALIZE BOARD C C FNC: GENERATE THE INITIAL PLAYING FORMAT C C REV: 1.0 C* 00002 INTEGER BOARD(26) 00003 RED=16 00004 WHITE=0 00005 DO 10 I=1,26 00006 10 BOARD(I)=0 C*** PUT THE MEN ON THE BOARD 00007 BOARD(2)=WHITE+2 00008 BOARD(7)=RED+5 00009 BOARD(9)= RED+3 00010 BOARD(13)=WHITE+5 00011 BOARD(14)=RED+5 00012 BOARD(18)=WHITE+3 00013 BOARD(20)=WHITE+5 00014 BOARD(25)=RED+2 00015 RETURN 00016 END (FLECS VERSION 22.37) ---------------------------------------- 00001 SUBROUTINE INPMOV(BOARD,ROLL) C C PGM: INPUT A MOVE FROM THE PLAYER. C C SYS: BGAMON C C ENT: BOARD - THE STATE OF THE BOARD BEFORE MOVING C C ENT: BOARD - THE STATE OF THE BOARD AFTER MOVING C C FNC: GET THE NEXT ROLL FOR THE PLAYER. C INPUT THE MOVE. CHECK FOR LEGALITY AGAINST BOARD. C UPON RETURN THE NEW BOARD IS IN 'BOARD' AND IT WAS A C LEGAL MOVE. THE ROUTINE WILL GIVE ERROR MESSAGES. C (FLECS VERSION 22.37) 12-APR-80 13:46:38 PAGE 00010 C REV: 1.0 C* 00002 INTEGER ROLL(2),MOVE(2,4),BOARD(26),BOARD1(26),BOARD2(26) 00003 INTEGER TEST(2) 00004 MOVSW=0 00005 WRITE(1,3) ROLL 00006 3 FORMAT(1X, 'YOU ROLL',2I2,'.') 00007 WRITE(1,300) 00008 300 FORMAT(' Your move?>',$) 00009 GO TO 4 00010 61 WRITE(1,1) 00011 1 FORMAT(1X, 'Try again>'$) 00012 4 READ(1,2,END=99,ERR=61) MOVE 00013 2 FORMAT(8I6) C*** GET THE PLAYERS MOVE C*** CHECK IF PLAYER MUST ENTER 00014 IF(BOARD(1).EQ.0) GO TO 67 00015 TEST(1)=1 00016 TEST(2)=ROLL(1) 00017 IF(MOVCHK(BOARD,TEST).NE.0) GO TO 67 00018 TEST(2)=ROLL(2) 00019 IF(MOVCHK(BOARD,TEST).NE.0) GO TO 67 00020 WRITE(1,*)'YOU HAVE NO MOVE' 00021 RETURN C*** IF NO SECOND ROLL SPECIFIED, ACCEPT IT C IF NO FIRST ROLL, ACCEPT IT 00022 67 CONTINUE 00023 IF(MOVE(1,1).EQ.0) RETURN 00024 IF(MOVE(1,2).NE.0) GO TO 64 00025 IF(MOVCHK(BOARD,MOVE(1,1)).EQ.0) GO TO 61 00026 CALL MAKMOV(BOARD,BOARD,MOVE(1,1)) 00027 GOTO 68 00028 64 IF(MOVE(2,1).EQ.ROLL(1).AND.MOVE(2,2).EQ.ROLL(2)) GO TO 62 00029 IF(MOVE(2,1).EQ.ROLL(2).AND.MOVE(2,2).EQ.ROLL(1)) GO TO 62 00030 GO TO 61 00031 62 IF(MOVCHK(BOARD,MOVE(1,1)).EQ.0) GO TO 61 00032 CALL MAKMOV(BOARD,BOARD1,MOVE(1,1)) 00033 IF(MOVCHK(BOARD1,MOVE(1,2)).EQ.0) GO TO 61 00034 CALL MAKMOV(BOARD1,BOARD,MOVE(1,2)) 00035 68 IF(ROLL(1).EQ.ROLL(2).AND.MOVSW.EQ.0) GO TO 80 00036 RETURN C*** DOUBLES, GET SECOND MOVE 00037 80 CONTINUE 00038 WRITE(1,*)'INPUT NEXT MOVE' 00039 MOVSW=1 00040 GO TO 4 00041 99 WRITE(1,*)'Nice Playing With You.' 00042 STOP 00043 END (FLECS VERSION 22.37) ---------------------------------------- 00001 SUBROUTINE MAKNXT(BOARD,NEWBRD,MOVE) C C PGM: MAKE THE NEXT MOVE IN SEQUENCE C C SYS: BGAMON C C ENT: C (FLECS VERSION 22.37) 12-APR-80 13:46:38 PAGE 00011 C RTN: C C FNC: IF THE MOVE(1) RETURNED IS -1, NO MORE MOVES C C REV: 1.0 C* 00002 INTEGER BOARD(26),NEWBRD(26),MOVE(2) 00003 10 CALL NXTMOV(BOARD,MOVE) 00004 IF(MOVE(1).EQ.-1) RETURN 00005 IF(MOVCHK(BOARD,MOVE).EQ.0) GO TO 10 00006 CALL MAKMOV(BOARD,NEWBRD,MOVE) 00007 RETURN 00008 END (FLECS VERSION 22.37) ---------------------------------------- 00001 SUBROUTINE EVAL(BOARD,STATUS) C C PGM: EVALUATE THE BOARD POSITION C C SYS: BGAMON C C ENT: BOARD - THE PLAYING BOARD TO BE EVALUATED C STATUS - N/A C C RTN: BOARD - N/C C STATUS - ARRAY CONTAINING THE SCORE C C FNC: C C REV: 1.0 C* 00002 INTEGER BOARD(26),STATUS(6) 00003 DATA LUTR /6/ C*** CALCULATE THE SCORE 00004 DO 5 I=1,6 00005 5 STATUS(I)=0 C*** GENERATE THE PLAYERS COUNT 00006 DO 10 I=1,25 00007 IF(BOARD(I).EQ.0) GO TO 10 00008 IF(ISHFT(BOARD(I),-4).NE.0) GO TO 10 00009 STATUS(1)=STATUS(1)+IAND(BOARD(I),15)*(26-I) 00010 10 CONTINUE C*** GENERATE COMPUTERS SCORE 00011 DO 20 I=2,26 00012 IF(BOARD(I).EQ.0) GO TO 20 00013 IF(ISHFT(BOARD(I),-4).EQ.0) GO TO 20 00014 STATUS(2)=STATUS(2)+IAND(BOARD(I),15)*(I-1) 00015 20 CONTINUE C*** GENERATE THE VUNERABILITY INDEX OF THE PLAYER 00016 DO 30 I=2,25 00017 IBRDP=BOARD(I) 00018 IF(IBRDP.EQ.0) GOTO 30 00019 IF(ISHFT(IBRDP,-4).NE.0) GO TO 30 00020 IF(IAND(IBRDP,15).NE.1) GO TO 30 C*** BLOT FOUND 00021 K=J+12 00022 IF(K.GT.25) K=25 00023 DO 35 J=I,K 00024 IF(ISHFT(BOARD(J),-4).NE.1) GO TO 35 (FLECS VERSION 22.37) 12-APR-80 13:46:38 PAGE 00012 C*** CALCULATE VUNERAILITY, DIRECT SHOTS=2, COMBINATIONS=1 00025 STATUS(3)=STATUS(3)+2-(J-I)/6 00026 35 CONTINUE 00027 30 CONTINUE C*** GENERATE THE VUNERABILITY INDEX OF THE COMPUTER 00028 VUN=0 00029 DO 40 I=1,25 00030 IBRDP=BOARD(I) 00031 IF(IBRDP.EQ.0) GOTO 40 00032 IF(ISHFT(IBRDP,-4).NE.1) GO TO 40 00033 IF(IAND(IBRDP,15).GT.1) GO TO 40 C*** BLOT FOUND 00034 ISW=0 00035 IF(I.GE.20) ISW=1 00036 K=I-12 00037 IF(K.LT.1) K=1 C*** SCAN FOR PLAYERS MEN WITHIN RANGE 00038 VUN=0 00039 DO 45 J=K,I 00040 IF(BOARD(J).EQ.0) GOTO 45 00041 IF(ISHFT(BOARD(J),-4).NE.0) GO TO 45 C*** VUNERABILITY CALCULATED, DIRECT SHOTS=2, INDIRECT SHOTS=1 00042 RANGE=I-J 00043 VUN=VUN+(2-(RANGE-1)/6) 00044 45 CONTINUE C*** LIMIT VUNERABILITY BECAUSE PROBABILITY OF HIT NOT LINEAR 00045 IF(VUN.GT.5) VUN=5 C*** WEIGHT VUNERABILITY BY ADVANCEMENT 00046 ADV=(31-I)/6 C*** WEIGHT VUNERABILITY BY THE NUMBER OF POINTS OCCUPIED IN C OPPONETS HOME COURT 00047 POCC=0 00048 DO 49 K=20,25 00049 IF(BOARD(K).EQ.0) GOTO 49 00050 IF(ISHFT(BOARD(K),-4).NE.0) GO TO 49 00051 IF(IAND(BOARD(K),15).LT.2) GO TO 49 00052 POCC=POCC+1 00053 49 CONTINUE 00054 POCC=POCC/3+1 C*** IF IN OPPONETS HOME COURT AND NOT TOO MANY POINTS C OCCUPIED, WEIGHT VUNERABILITY LESS. 00055 IF(ADV.EQ.1.AND.POCC.LE.2) VUN=VUN/2 00056 NETVUN=VUN*ADV*POCC 00057 STATUS(4)=STATUS(4)+NETVUN 00058 40 CONTINUE C*** GENERATE THE COMPOSITE SCORE OF THE PLAYER 00059 STATUS(5)=STATUS(1)-STATUS(2)+STATUS(3) C*** GENERATE THE COMPOSITE SCORE OF THE COMPUTER 00060 STATUS(6)=STATUS(2)-STATUS(1)+STATUS(4) C C*** MODIFY THE COMPOSITE SCORE FROM POSITIONAL FACTORS C INCREASE 1 POINT FOR EACH MAN OVER 4 ON A POINT C DECREASE BY THE NUMBER OF MADE POINTS C INCREASE THE SCORE FOR EACH MAN LEFT C C*** MODIFY COMPUTERS SCORE 00061 IOURS=1 00062 PCNT=0 00063 MCNT=0 00064 DO 50 I=1,26 C*** SET UP SHORTENED VARIBLES 00065 IBP=BOARD(I) (FLECS VERSION 22.37) 12-APR-80 13:46:38 PAGE 00013 00066 CNT=IAND(IBP,15) 00067 IF(IBP.EQ.0) GO TO 50 00068 IF(ISHFT(IBP,-4).NE.IOURS) GOTO 50 00069 MCNT=MCNT+CNT C*** DISFAVOR COUNTS GREATER THAN 3 00070 IF(CNT.GT.3) STATUS(6)=STATUS(6)+CNT-3 C*** PERFORM THE FOLLOWING TESTS IF POINT IS MADE 00071 IF(CNT.LT.2) GO TO 50 C*** KEEP TRACK OF NUMBER OF POINTS 00072 PCNT=PCNT+1 00073 50 CONTINUE C*** FAVOR MORE POINTS, FEWER MEN C FEWER MEN IS THE OVERRIDING FACTOR 00074 STATUS(6)=STATUS(6)-PCNT+MCNT*3 00075 RETURN 00076 END (FLECS VERSION 22.37) ---------------------------------------- BG,BG=BG