C       3-DIMENSIONAL NOUGHTS & CROSSES
C       RE-TYPED FROM OLD (1972) VERSION
C       COPYRIGHT (C) 1972, 1995, 2019  DAVID R. BROOKS
C
C       Amended 2019, DRB, to compile with G95 free FORTRAN compiler.
C       Put ...\g95\bin on Path, then >g95 Tridox2.for -fsloppy-char
C
C********************************************************************
C
C       CASE CONVERSION FUNCTION
        INTEGER FUNCTION NUPCASE(DATA)
        INTEGER DATA, UPA, LWRA
        DATA UPA, LWRA / 1HA, 1Ha /
        IF (DATA.GE.LWRA) THEN
          NUPCASE= DATA + UPA - LWRA
        ELSE
          NUPCASE= DATA
        ENDIF
        RETURN
        END
C
C
C********************************************************************
C
C
C       INPUT CHARACTER ANALYSER
        INTEGER FUNCTION ICHARN (POINTR, BUFF, MODE)
        INTEGER POINTR, MODE, BUFF(20), LIST(12)
        DATA LIST / 1H1, 1H2, 1H3, 1H4, 1HA, 1HC, 1HS, 1HV, 
     *  1HX, 1HH, 1HZ, 1H /
C
C       "MODE" CONTROLS ACTION THUS:-
C       1--DECODE NEXT CHAR. DIRECTLY
C       2--SKIP LETTERS & SPACES, THEN AS 1
C       3--DECODE DIGIT ONLY
C
C       ANY ERROR CAUSES RETURN VALUE =11
C
        POINTR= POINTR +1
        GOTO (3,2,3), MODE
C
C       SKIP LETTERS & SPACES
2       IF (BUFF(POINTR).EQ.LIST(12)) GOTO 4
        IF (BUFF(POINTR).GE.LIST(5).AND.BUFF(POINTR).LE.LIST(11))GOTO 4
        GOTO 7
C       ILLEGAL INPUT CHAR.
5       ICHARN= 11
        RETURN
C
C       IGNORE CHARACTER
4       POINTR= POINTR +1
        IF (POINTR.EQ.21) GOTO 5
        GOTO 2
C
C       CHECK SIGNIFICANT CHAR.
7       DO 8 ICHARN= 1,10
        IF(LIST(ICHARN).EQ.BUFF(POINTR)) GOTO 9
8       CONTINUE
C       UNRECOGNIZED CHAR.
        GOTO 5
C
C       CHECK IF DIGIT EXPECTED
9       IF(ICHARN.GT.4.AND.MODE.GT.2) GOTO 5
        RETURN
C
C       ALWAYS SKIP SPACES
3       IF(BUFF(POINTR).NE.LIST(12)) GOTO 7
        POINTR= POINTR+1
        IF(POINTR.EQ.21) GOTO 5
        GOTO 3
        END
C
C
C********************************************************************
C
C
C       USER-INPUT ROUTINE
        INTEGER FUNCTION INPUT(JSW)
        INTEGER GAME(64), BUFFER(20)
        INTEGER ATTACK, IDEV, ODEV, CONCIS, ANSWER
        COMMON GAME, ATTACK, IDEV, ODEV, CONCIS, ANSWER
C
100     WRITE(ODEV,1)
1       FORMAT(17H You [O] [X Y Z]:)
        READ(IDEV,2) BUFFER
2       FORMAT(20A1)
C       CONVERT TO UPPERCASE
        DO 103 JTAG= 1,20
        BUFFER(JTAG)= NUPCASE(BUFFER(JTAG))
103     CONTINUE
        JTAG= 1
        JPOINT= 0
C       ANALYSE INPUT BUFFER
3       J= ICHARN(JPOINT,BUFFER,JTAG)
        GOTO (11,12,13,14,15,16,17,18,181,182,101), J
C
181     STOP
C
182     CALL HELP
        GOTO 100
C
11      JX= 1
        GOTO 20
C
12      JX= 2
        GOTO 20
C
13      JX= 3
        GOTO 20
C
14      JX= 4
        GOTO 20
C
15      INPUT= -1
        RETURN
C
16      CONCIS= 1
        GOTO 21
C
18      CONCIS= 0
21      JTAG= 2
        GOTO 3
C
17      IF(JSW.EQ.0) GOTO 101
        INPUT= 0
        RETURN
C
101     WRITE(ODEV,102)
102     FORMAT(24H Try again! (H for help))
        GOTO 100
C
20      JY= ICHARN(JPOINT,BUFFER,3)
        JZ= ICHARN(JPOINT,BUFFER,3)
        INPUT= 16*JY + 4*JZ + JX - 20
C
        IF(GAME(INPUT).NE.0) GOTO 101
        RETURN
        END
C
C
C********************************************************************
C
C
C       BASIC HELP SCREEN - SHOWN AT START, AND FOR "H" INPUT
        SUBROUTINE HELP
        INTEGER GAME(64)
        INTEGER ATTACK, IDEV, ODEV
        COMMON GAME, ATTACK, IDEV, ODEV
C
        WRITE(ODEV,1)
        RETURN
C
1       FORMAT(16H Allowed inputs:,
     *  /47H X Y Z   - The X Y Z are integers in range 1..4,
     *  / 1H ,
     *  /41H A       - Abort this game: start another,
     *  /47H C       - Set "concise" mode (map-display off),
     *  /28H H       - Display this help,
     *  /43H S       - Program to play (1st. move only),
     *  /46H V       - Set "verbose" mode (map display on),
     *  /23H X       - Exit program,/)
        END
C
C
C********************************************************************
C
C
C       RANDOM NUMBER GENERATOR. RETURNS 0 <= JRAND < IX
        INTEGER FUNCTION JRAND(IX)
		INTEGER*4 JS
        JS = RAND(0)*IX
		JRAND = JS
        RETURN
        END
C
C
C********************************************************************
C
C
C       TACTICAL SITUATION ANALYSER.  RETURNS VALUE OF SQUARE TO FILL
C       IF -VE, FILL IT & WIN
C       IF ZERO, GAME OVER
C       IF +VE, FILL IT & PLAY ON.
C
        INTEGER FUNCTION JTACAN(JDUM)
C       TACAN TAKES NO PARAMETERS: JDUM IS JUST TO SATISFY FORTRAN
C
        INTEGER GAME(64),LINE(4,76),SCORE(64),LIST(20),ATTACK,ODEV
        COMMON / TABLE / LINE
        COMMON GAME,ATTACK,IDEV,ODEV
        DATA INTAK, INLIST / 10, 1/
C
C       BASIC ANALYSIS PHASE, SETTING UP REGISTERS
501     IF(INTAK.EQ.0) GOTO 500
        ATTACK= INTAK
        INTAK= 0
C
500     DO 1 K1= 1, 64
1       SCORE(K1)= 0
        IMWIN= 0
        IMLOSE= 0
        LFORK= 0
        LEAD= 0
C
C       SCAN ALL LINES
        DO 2 K1= 1,76
        MFLAG= 0
C
C       INSPECT STATE OF LINE
        DO 3 K2= 1,4
        INDEX= LINE(K2,K1) +1
        IF(GAME(INDEX).NE.0) GOTO 4
        LEAD= INDEX
        GOTO 3
C
4       IF (MFLAG.NE.GAME(INDEX)) GOTO 6
        LCTR= LCTR +1
        GOTO 3
C
6       IF (MFLAG.NE.0) GOTO 2
C       IF MFLAG NON-ZERO, LINE IS MIXED, HENCE NON-SIGNIFICANT
C
        LCTR= 1
        MFLAG= GAME(INDEX)
C       1ST NON-EMPTY SQUARE ON LINE
C
3       CONTINUE
C       NOW DETERMINE SIGNIFICANCE OF LINE
C
        IF (MFLAG.EQ.0) GOTO 2
C       IGNORE TOTALLY EMPTY LINES
C
        IF(LCTR.NE.4) GOTO 10
C       IF LCTR=4, LINE IS COMPLETE: GAME IS LOST
        WRITE(ODEV,12)
12      FORMAT(/8H You win)
        GOTO 13
C
C       LINE INCOMPLETE, CHECK FOR IMMINENT COMPLETION
10      IF(LCTR.NE.3) GOTO 15
C       COMPLETION IMMINENT, TEST IF WINNING OR LOSING
        IF(MFLAG.LT.0) GOTO 17
C       IMMINENT WIN: LOG IT & CONTINUE SCAN
        IMWIN= LEAD
        GOTO 2
C
C       IMMINENT LOSE: CHECK FOR FORK-TACTIC
17      IF(IMLOSE.NE.0) GOTO 19
C       UNIQUE LOSE-CRITICAL SQUARE
20      IMLOSE= LEAD
        GOTO 2
C
C       A PREVIOUS LOSE-CRITICAL SQUARE WAS FOUND
C       WAS IT THIS SAME SQUARE (IN ANOTHER LINE)?
19      IF(IMLOSE.EQ.LEAD) GOTO 2
C
C       NO, A FORK-TACTIC HAS BEEN SET UP
        LFORK= 1
        GOTO 2
C
C       LINE HAS NO IMMEDIATE SIGNIFICANCE: SCORE IT UP
15      IF(MFLAG.GE.0) GOTO 23
C       SELECT WINNING OR LOSING WEIGHTING FACTOR
        INCR= 12
        GOTO 24
23      INCR= ATTACK
C
C       DETERMINE SCORE-INCREMENT FOR LINE
24      INCR= INCR * LCTR * LCTR
C       NOW INCREASE THE EMPTY SQUARES' SCORES
C
        DO 25 K2= 1,4
        INDEX= LINE(K2,K1) +1
        IF(GAME(INDEX).NE.0) GOTO 25
        SCORE(INDEX)= SCORE(INDEX) + INCR
25      CONTINUE
C
2       CONTINUE
C
C       ANALYSIS COMPLETE: NOW DETERMINE ACTION
C       CHECK FOR IMMINENT WIN
        IF(IMWIN.EQ.0) GOTO 28
        WRITE(ODEV,29)
29      FORMAT(/6H I win)
        GOTO 131
C
C       NO IMMINENT WIN: CHECK FOR FORK-TACTIC
28      IF(LFORK.EQ.0) GOTO 31
C       FORK-TACTIC APPLIED: CONCEDE DEFEAT
        WRITE(ODEV,32)
32      FORMAT(/17H I concede defeat)
        GOTO 13
C
C       NO FORK: CHECK FOR UNIQUE IMMINENT-LOSE SQUARE
31      IF(IMLOSE.EQ.0) GOTO 34
C       FILL UNIQUE IMMINENT-LOSE SQUARE AT ONCE
        JTACAN= IMLOSE
        RETURN
C
C       INDETERMINATE GAME-STATE: CHECK THAT FURTHER PLAY IS POSSIBLE
34      IF(LEAD.NE.0) GOTO 35
        WRITE(ODEV,37)
37      FORMAT(/22H A draw: no cells left)
        GOTO 13
C
C       DETERMINE OPTIMUM MOVE
35      JCAND= 1
        K1= 0
C
C       SORT FREE SQUARES IN ORDER OF TACTICAL IMPORTANCE
        DO 38 K2= 1,64
        IF(SCORE(K2)-JCAND) 38,39,40
C
C       NEW OPTIMUM: RESET LIST
40      JCAND= SCORE(K2)
        K1= 0
C
C       EQUAL-BEST: ADD TO LIST
39      K1= K1 +1
        IF(K1.GT.20) GOTO 38
C       IGNORE NEW VALUE IF LIST IS FULL
        LIST(K1)= K2
C
38      CONTINUE
C
C       MAKE RANDOM CHOICE OF OPTIMA, & PLAY ON
        IF(K1.LE.20) GOTO 41
        K1= 20
41      K2= JRAND(K1) +1
        JTACAN= LIST(K2)
        RETURN
C
C       ADAPTIVE STRATEGY PT. 1: GAME WAS LOST, SO PLAY
C       MORE CAUTIOUSLY NEXT TIME
13      IF(ATTACK.GT.1) ATTACK= ATTACK -1
C       EXIT, INDICATING GAME OVER
14      JTACAN= 0
        RETURN
C
C       ADAPTIVE STRATEGY PT. 2: GAME WON, SO PLAY
C       MORE AGGRESSIVELY NEXT TIME
131     IF(ATTACK.LT.60) ATTACK= ATTACK +1
C       RETURN, INDICATING WIN
        JTACAN= -IMWIN
        RETURN
        END
C
C
C********************************************************************
C
C
C       SITUATION-REPORT ROUTINE
        SUBROUTINE SITREP(K1)
        INTEGER GAME(64), ATTACK, ODEV, CONCIS, ANSWER, K1
        INTEGER LINE(25), CHAR(3)
        CHARACTER*2 TAG
        COMMON GAME, ATTACK, IDEV, ODEV, CONCIS, ANSWER
        DATA CHAR / 1Ho, 1H., 1Hx/
        DATA LINE(5), LINE(6), LINE(7), LINE(12), LINE(13), LINE(14),
     1  LINE(19), LINE(20), LINE(21) / 9*1H  /
C
        IDIV(I,J)= I/J
        IREM(I,J)= I - IDIV(I,J) * J
C
C       REPORT OWN MOVE (IF ANY)
        IF(ANSWER.EQ.0) GOTO 2
        INT= ANSWER -1
        JX= IREM(INT,4)+1
        INT= IDIV(INT,4)
        JZ= IREM(INT,4)+1
        JY= IDIV(INT,4)+1
        WRITE(ODEV,3)JX,JY,JZ
3       FORMAT(/17H Me  [X] [X Y Z]: ,3I3)
C
C       IF "VERBOSE", PRINT FULL REPORT ALSO
        IF(CONCIS.NE.0) RETURN
C
2       WRITE(ODEV,5)
5       FORMAT(/13H Situation is/29H Z:    1      2      3      4)
C
        IY= 4
9       IQ= 0
        DO 6 IZ= 0,3
        DO 7 IX= 0,3
        K1= 16*(IY-1) + 4*IZ + IX + 1
        KK= GAME(K1) + 2
        IQ= IQ +1
        LINE(IQ)= CHAR(KK)
        IF(K1.EQ.K1.OR.K1.EQ.ANSWER) LINE(IQ)= NUPCASE(LINE(IQ))
7       CONTINUE
6       IQ= IQ +3
        IF (IY.EQ.4) THEN
          TAG= 'Y:'
        ELSE
          TAG= '  '
        ENDIF
        WRITE(ODEV,8)TAG,IY,LINE
8       FORMAT(1H ,A2,I2,1X,25A1)
        IY= IY -1
        IF(IY.GT.0) GOTO 9
        WRITE(ODEV,10)
10      FORMAT(31H X:   1234   1234   1234   1234/)
        RETURN
        END
C
C
C********************************************************************
C
C
C       TRIDOX: 3-DIMENSIONAL NOUGHTS & CROSSES
C
        INTEGER GAME(64), ANSWER, ATTACK, ODEV, CONCIS
        COMMON GAME, ATTACK, IDEV, ODEV, CONCIS, ANSWER
C
C       STDIN, STDOUT, AS PER PROFORT
        IDEV= 5
        ODEV= 6
        DO 993 K1= 1, 64
993     GAME(K1)= 0
        WRITE(ODEV,999)
999     FORMAT(41H TRIDOX - 3-Dimensional Noughts & Crosses,
     *  /36H Copyright (c) 1995. David R. Brooks,
     *  /17H Sample game-map:,1H )
        ANSWER= 0
        CALL SITREP(0)
        CALL HELP
C
2       DO 3 K1= 1, 64
3       GAME(K1)= 0
C       SET VERBOSE-MODE INITIALLY
        CONCIS= 0
C
C       INPUT PLAYER'S COMMAND
        K1= INPUT(1)
        IF(K1) 17,4,5
C
C       PROGRAM TO START: RANDOM MOVE
4       ANSWER= JRAND(64) +1
        GAME(ANSWER)= 1
        GOTO 6
C
C       OPPONENT'S MOVE FIRST
5       GAME(K1)= -1
C       RANDOM RESPONSE
        ANSWER= K1 + JRAND(63) + 1
        IF(ANSWER.LE.64) GOTO 7
        ANSWER= ANSWER -64
C
7       GAME(ANSWER)= 1
C
C       MAIN PLAYING CYCLE: REPORT & INPUT
6       CALL SITREP(K1)
12      K1= INPUT(0)
        IF(K1) 17,12,10
C
10      GAME(K1)= -1
C
C       TACTICAL ANALYSIS TO FIND RESPONSE
        ANSWER= JTACAN(1)
        IF(ANSWER) 13,14,7
C
C       GAME WON: PLACE MOVE
13      ANSWER= -ANSWER
        GAME(ANSWER)= 1
C
C       REPORT & END GAME
14      CALL SITREP(0)
17      WRITE(ODEV,16)
16      FORMAT(/10H Game over)
        GOTO 2
        END
C
C
C********************************************************************
C
C
C       SIGNIFICANT-LINES TABLE
C       DATA STMTS. SPLIT UP TO SUIT PROFORT
C
       BLOCK DATA LISTS
       INTEGER LINE(4,76)
       COMMON /TABLE/ LINE
C
       DATA ((LINE(I,J),I=1,4),J=1,32) /   
     *  0, 1, 2, 3,  0, 4, 8,12,  0,16,32,48,  0,20,40,60,
     *  0, 5,10,15,  0,17,34,51,  0,21,42,63,  1, 5, 9,13,  1,17,33,49,
     *  1,21,41,61,  2, 6,10,14,  2,18,34,50,  2,22,42,62,  3, 7,11,15,
     *  3,19,35,51,  3,23,43,63,  3, 6, 9,12,  3,18,33,48,  3,22,41,60,
     *  4, 5, 6, 7,  4,20,36,52,  4,21,38,55,  5,21,37,53,  6,22,38,54,
     *  7,23,39,55,  7,22,37,52,  8, 9,10,11,  8,24,40,56,  8,25,42,59,
     *  9,25,41,57, 10,26,42,58, 11,27,43,59  /
C
       DATA ((LINE(I,J),I=1,4),J=33,63) /
     * 11,26,41,56, 12,13,14,15,
     * 12,28,44,60, 12,24,36,48, 12,29,46,63, 12,25,38,51, 13,29,45,61,
     * 13,25,37,49, 14,30,46,62, 14,26,38,50, 15,31,47,63, 15,27,39,51,
     * 15,30,45,60, 15,26,37,48, 16,17,18,19, 16,20,24,28, 16,21,26,31,
     * 17,21,25,29, 18,22,26,30, 19,23,27,31, 19,22,25,28, 20,21,22,23,
     * 24,25,26,27, 28,29,30,31, 32,33,34,35, 32,36,40,44, 32,37,42,47,
     * 33,37,41,45, 34,38,42,46, 35,39,43,47, 35,38,41,44  / 
C
       DATA  ((LINE(I,J),I=1,4),J=64,76) /
     * 36,37,38,39,
     * 40,41,42,43, 44,45,46,47, 48,49,50,51, 48,52,56,60, 48,53,58,63,
     * 49,53,57,61, 50,54,58,62, 51,55,59,63, 51,54,57,60, 52,53,54,55,
     * 56,57,58,59, 60,61,62,63 /
C
      END

