PATH.FOR

 
 
 
        INTEGER FUNCTION PATH(BEG,END,DIR2,OK,FLAG)
        INCLUDE 'COMMON.EMP/NOLIST'
        DIMENSION OK(5)
 
        DIR=DIR2                !DON'T CHANGE DIR BACK IN CALLING PROG
 
* CHECK FOR ERRORS
        IF(.NOT.PASS) GOTO 2116
        IF((DIR#1).AND.(DIR#-1)) TYPE 2222,BEG,END,DIR
        IF((BEG<1).OR.(BEG>6000)) TYPE 2222,BEG,END,DIR
        IF((END<1).OR.(END>6000)) TYPE 2222,BEG,END,DIR
 2222   FORMAT(' PATH: BEG,END,DIR-',3G)
 
* INITIALIZATION
 2116   BACKUP=1
        BEGDIR=DIR
        MOVNUM=0
        MAXMVE=2*IDIST(BEG,END)+1
        Z6=BEG
        CALL SET(G2,100,0)              !ZERO G2
 
* PICK A MOVE IN THE DIRECTION OF THE DESTINATION
  102   MOVE=MOV(Z6,END)
        Z62=Z6+IARROW(MOVE)
        AB=AMAPP(Z62,0,MAPS)
        DO 100 I=1,3
  100   IF(OK(I)==AB) GOTO 101
        IF(D1(Z62)==OK(1)) GOTO 101
        GOTO 1000                       !RUN UP AGAINST AN OBSTACLE
 
* MOVE IS ACCEPTABLE
  101   MOVNUM=MOVNUM+1
        IF(Z6==BEG) MOVE1=MOVE
        Z6=Z62
        IF(FLAG>=1000) CALL TEST4(Z6,FLAG,DIR,MOVE1,
     &MOVNUM,BEG,END,G2,'MOV')
 
*NOW CHECK TO SEE IF Z6 IS RIGHT NEXT TO END, AND END # OK(N)
        IF(IDIST(Z6,END)#1) GOTO 103            !IF NOT NEXT TO END
        AB=AMAPP(END,0,MAPS)
        DO 104 I=1,3
  104   IF(AB==OK(I)) GOTO 102                  !END IS LEGAL MOVE
        IF(D1(END)==OK(1)) GOTO 102             !DITTO
        GOTO 2000                               !STOP HERE
 
  103   IF(Z6==END) GOTO 2000
        IF(MOVNUM>=MAXMVE) GOTO 3000
        GOTO 102
 
* TRY ANOTHER DIRECTION
 3000   DIR=-DIR
        IF(BEGDIR==DIR) GOTO 4000
        MOVNUM=0
        BACKUP=1
        Z6=BEG
        CALL SET(G2,100,0)              !ZERO G2
        GOTO 102
 
* RETURN, HAVING SUCCEEDED
 2000   PATH=MOVE1
        SUCCESS=SUCCESS+1
        FLAG=1                  !INDICATING SUCCESS
        RETURN
 
* FOLLOW SHORE
 1000   MOV1=ICORR(MOVE-DIR*3)
        Z62=Z6+IARROW(MOV1)
        AB=AMAPP(Z62,0,MAPS)
        DO 1008 I=1,3
 1008   IF(AB==OK(I)) GOTO 1009
        IF(D1(Z62)==OK(1)) GOTO 1009
        GOTO 1010
 1009   MOV1=MOVE
 
 1010   DO 1001 J=MOV1,MOV1+DIR*7,DIR
        MOVE=ICORR(J)
        Z62=Z6+IARROW(MOVE)
        IF(ORDER(Z62)#0.0) GOTO 1001
        AB=AMAPP(Z62,0,MAPS)
        DO 1002 K=1,3
 1002   IF(AB==OK(K)) GOTO 1003
        IF(D1(Z62)==OK(1)) GOTO 1003
        GOTO 1001
 
* MOVE IS ACCEPTABLE
 1003   MOVNUM=MOVNUM+1
        IF(Z6==BEG) MOVE1=MOVE
        Z6=Z62
        IF(FLAG>=1000) CALL TEST4(Z6,FLAG,DIR,MOVE1,
     &MOVNUM,BEG,END,G2,'SHORE')
        IF(IDIST(Z6,END)#1) GOTO 105
        AB=AMAPP(END,0,MAPS)
        DO 106 I=1,3
  106   IF(AB==OK(I)) GOTO 102
        IF(D1(END)==OK(1)) GOTO 102
        GOTO 2000
  105   IF(Z6==END) GOTO 2000
        IF(MOVNUM>=MAXMVE) GOTO 3000
        GOTO 1007
 1001   CONTINUE
 
* RETURN, HAVING FAILED TO FIND A PATH FROM BEG TO END
 4000   PATH=MOV(BEG,END)
        FAILURE=FAILURE+1
        FLAG=0                  !INDICATING FAILURE
        RETURN
 
 1007   MOVE2=MOV(Z6,END)
        Z62=Z6+IARROW(MOVE2)
        AB=AMAPP(Z62,0,MAPS)
        DO 1004 I=1,3
 1004   IF(AB==OK(I)) GOTO 1005
        IF(D1(Z62)==OK(1)) GOTO 1005
        GOTO 1000
 1005   DO 1006 I=1,BACKUP
 1006   IF(Z6==G2(I)) GOTO 1000
        G2(BACKUP)=Z6
        BACKUP=BACKUP+1
        IF(BACKUP>100) GOTO 3000
        GOTO 102
 
        END
 
 
 
 
        SUBROUTINE TEST3
        INCLUDE 'COMMON.EMP/NOLIST'
        DIMENSION OK(5),COMM(20)
        DATA OK/'+','5',' ',' ',-1/
        DATA COMM/'D','E','W','Q','A','Z','X','C','S',
     & 'P','B','F','T','G','V','I','J',-1,-1,-1/
 
!P: REFRESH SCREEN
!B: TYPE BEG
!F: TYPE END
!T: TRACE
!G: GO
!V: RETURN
!I: DIR=-DIR
 
        LINE=KLINE(KI,JECTOR)
        IADJST=LINE+KI-300
        Z6=IADJST+300
        DIR=1
  100   CALL CURSOR(Z6-IADJST,KURSOR)
        CALL ECHOFF
        CALL OUTCHR("7)
        E=GETCHX(E)
        Z7=Z6
        DO 101 I=1,8
  101   IF(E==COMM(I)) Z6=Z6+IARROW(I)
        IF(Z6==Z7) GOTO 102
        GOTO 100
  102   DO 103 I=10,20
        J=I
  103   IF(E==COMM(I)) GOTO 104
        GOTO 100
  104   GOTO (10,11,12,13,14,15,16,17,18,19,20) J-9
   10   CALL SECTOR(0)
        GOTO 100
   11   BEG=Z6
        CALL OUTCHR("102)
        GOTO 100
   12   END=Z6
        CALL OUTCHR("105)
        GOTO 100
   13   FLAG=1000
        CALL PATH(BEG,END,DIR,OK,FLAG)
        GOTO 100
   14   FLAG=1001
        CALL PATH(BEG,END,DIR,OK,FLAG)
        GOTO 100
   15   CALL ECHOON
        RETURN
   16   DIR=-DIR
        GOTO 100
   17   H2=30
        OWN2=A(1,Z6)
        CALL FIND(OWN2,Z6,Z8,H2)
        CODNUM=CODE(Z8-1500)
        CALL CURSOR(50,KURSOR)
        CALL STROUT(' CODE:',0)
        TYPE 147,CODNUM
  147   FORMAT('+ ',I7,1X$)
        GOTO 100
   18   CONTINUE
   19   CONTINUE
   20   CONTINUE
        END
 
 
        SUBROUTINE TEST4(Z6,FLAG,DIR,MOVE1,MOVNUM,BEG,
     & END,G2,FLAG2)
        IMPLICIT INTEGER(A-Z)
        COMMON/KXK/IADJST
        DIMENSION G2(100)
 
        CALL CURSOR(Z6-IADJST,KURSOR)
        IF(FLAG2=='MOV') CALL OUTCHR("107)
        IF(FLAG2=='SHORE') CALL OUTCHR("110)
        IF(FLAG==1001) RETURN
        CALL OUTCHR("7)
        E=GETCHX(E)
        IF(E==' ') RETURN
        IF(E=='G') GOTO 100
        CALL CURSOR(0,KURSOR)
        TYPE 101,Z6,MOVE1,MOVNUM
  101   FORMAT(' Z6:',I4,' MOVE1:',I1,' MOVNUM:',I3)
        CALL CURSOR(100,KURSOR)
        TYPE 103,BEG,END,IADJST,DIR,FLAG
  103   FORMAT(' BEG:'I4' END:'I4' IADJST:'I4' DIR:'I2' FLAG:'I4)
        RETURN
  100   CALL CURSOR(0,KURSOR)
        TYPE 102,G2
  102   FORMAT(1X,16I5)
        RETURN
        END
 
 


.