I’ve had some success with a Basic 2 C translator in the past. In that project I used hand coded Flex and Bison but came at the project from a rather naive perspective. While the project worked and I produced working code from old Basic programs it bogged down when I tried to convert my parse tree into structured code and do some optimizations on it.
Recently I tripped across the BNFC (BNF Converter) which translates a BNF grammer to a lexical analyzer and parser with code to generate a parse tree. Thus I can now scrap my hobbled together lexor/parser and convert it to a much more uniform version. This should be much easier to keep up-to-date and should facilitate improvements such as structuring.
I need to read their book Implementing Programming Languages first. Well, actually, I just need to understand LBNF (Labelled BNF grammar) and its use in BNFC. On the BNFC website they give an example LBNF grammar for C (which I know quite well — at least compared to Haskell). Hopefully that will detail how to deal with Fortran’s position dependent code. This is going to take a while so stay tuned …
Here’s a snippet of code that I want to translate. This is the GALAXY.FOR file from the DECUS Galaxy project. This game is a multi-player game (somewhat of a rarity at the time) which was played on a mainframe computer (Dec-10) .
This file is actually in Ratfor. Ratfor is pre-processor for Fortran66 (and here) which adds (badly needed) structure to the Fortran source code:
C ASCII "0"
PROGRAM PLAYER
C
C MAY 1980 BILL CAEL AND BILL WOOD RECODED IN RATFOR
C MAY 1980 BILL CAEL AND BILL WOOD ADDED DEFAULT SHIP AND DIRECTION
C MAY 1980 BILL WOOD ADDED ENERGY NETS
C MAY 1980 BILL CAEL AND BILL WOOD RECODED OUTPUT
C MAY 1980 BILL CAEL, BILL WOOD, AND BOB STODOLA
C RECODED COMMAND ARG PROMPTING
C NOV 1980 BILL WOOD CONVERTED TO RUN ON VAX
C
C July/August 1981 Stuart Renes, Western Electric Co.
C Mixed Case messages, added sound effects
C Improved Driver controls
C ^C Intercept AST, Exit handler
C Play periods (including weekend control)
C VT100 advanced video features - renamed GALAXY V1.0
C Lowered Refresh rates in half
C
C Version 1.1 September 8th, 1981
C Added purge of type-ahead when destroyed or at games end.
C
C Version 1.2 September 10th, 1981
C Added silent play option.
C
C Version 1.3 September 17th, 1981
C Added Shared Command Display and control.
C More code cleanup.
C
C Version 1.4 September 23rd, 1981
C Tighten window in which users can beat the "SHARED" feature.
C
C Version 1.5 September 27th, 1981
C Fix bugs that creeped in from V1.4.
C
C Version 1.6 October 2nd, 1981
C Changed Initialization to force active players off.
C Slight esthetic change at close of game period.
C Describe previously un-documented features in HELP file.
C
TEXT COMMON
COMMON/TORPE/TLOCS(8, 10, 2), TDIR(8, 10), IT(8)
COMMON/LEDFOR/ENERGY(8), SHIELD(8), XCORD(8), YCORD(8), TORPS(8),
*HX, HY, HW, CDRAIN, NDRAIN, TDRAIN, SCAN(8), PHA(8), I1, I2, HYPER
*(8), ISENT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XH
*OM(8, 4), YHOM(8, 4), WHOM(8, 4), NHOM(8), TRBEAM(8), SCORE(8), CR
*EW(8), DIR(8), WARP(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), TH
*RU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY
REAL LAUNCH, NDRAIN
INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM
LOGICAL*1THRU, XSHIP, CLOAK, NET
C NOTE: BHOLE AND EMPTY ARE THE CHARACTERS FOR THE BLACK HOLE
C AND EMPTY SPACE AND ARE SET IN MTREKINI.
BYTE UNIV, MESSAG, BHOLE, EMPTY
C END COMMON
common/local/shrflg(8)
common/double/share(8),busy(8)
logical*1 busy
integer share,shrflg,day
character*9 today
character*80 header
character*4 V
data V /'V1.6'/
common/signal/playtm
integer timcnt
data timcnt/4/
logical*1 playtm,wizard,myplay,shpflg,yesshr
LOGICAL*1OK, DONE, YES, WARN, REFRES, REFTOG
LOGICAL QUIKUP,supflg
common done
common/silent/belflg
logical*1 belflg
character*19 paswrd,answer
character*8 timbf
byte pasbuf(19)
data paswrd/'starship enterprise'/
REAL SC(9), R(9)
INTEGER DEFSHP, OLDSHP
REAL DEFDIR, OLDDIR
COMMON/DEFLTS/DEFSHP, DEFDIR, OLDDIR, OLDSHP, DEFSHD
LOGICAL CLEARF, VERBOS
COMMON/MESS/CLEARF, VERBOS
BYTE BLANK(80), ALPHA, MESBUF(60)
REAL D1(4)
BYTE BLUNK(2)
BYTE BLUNK2(2)
BYTE OBUFF( - 9: + 9, - 9: + 9)
BYTE JUNK, NBUFF
COMMON/BNDRY/IXX, IYY, ID, MINID8, JUNK, NBUFF( - 9: + 9, - 9: +
*9)
INTEGER COMMND
common/me/who
INTEGER WHO
EQUIVALENCE(BLUNK(2), NBUFF( - 9, - 9))
EQUIVALENCE(BLUNK2(2), OBUFF( - 9, - 9))
DATA BLANK/80*' '/
DATA BLUNK, BLUNK2/4*' '/
DATA SC/9* - 9999./
DATA R/9* - 9999./
DATA DONE/.FALSE./
DATA OK/.FALSE./
wizard=.false.
DATA DEFDIR/0.0/, DEFSHD/0.0/
C
C QUIKUP IS SET TRUE IF TERMINAL SPEED EXCEEDS A THRESHOLD
C DETERMINED IN GTCHAR.
C IF QUIKUP IS TRUE, A FULL SCREEN UPDATE OCCURS EVERY 1/2 SECOND;
C AT SLOWER SPEEDS, 1/2 THE SCREEN IS UPDATED EVERY SECOND ON THE
C HALF SECOND, THE OTHER 1/2 IS UPDATED EVERY SECOND ON THE SECOND.
C THIS ALLOWS ENJOYABLE GAMES ON TERMINALS AS SLOW AS 1200 BAUD.
C
C GET QUIKUP, INITIALIZE TERMINAL IO
C
C If supflg is .FALSE. then terminal type is NOT supported and we will
C exit and give him an explaination.
C If MYPLAY is .FALSE. then it must be OFFHOURS and we won't let him in!
C
CALL GTCHAR(QUIKUP,supflg)
If (supflg) goto 1000
write(5,1999)
1999 format(' You obviously didn''t read the instructions
1 about terminal setup.')
call exit
1000 call daytim(myplay)
call video('<')
If (myplay) goto 1998
call clear
call outch(0,0)
write(5,1995)
1995 format(' I''m sorry but the Galaxy is CLOSED now.',//,
1' Entrance is allowed only to those who can',/,
1'$demonstrate their worthiness. ')
call inchar(pasbuf,19,.false.,3,nc,ierr)
call clear
call outch(0,0)
if (ierr .ge. 0) goto 1993
If (ierr .eq. -2) then
call video('5')
write(5,1992)
1992 format(' I''m sorry but you are clearly unworthy!',/
1,' Come back during regular hours of play.')
call video('0')
call exit
endif
1993 encode(19,9934,answer)pasbuf
9934 format(19a1)
If (answer .ne. paswrd) goto 1996
wizard=.true.
goto 1998
1996 call video('5')
write(5,1992)
call video('0')
call exit
1998 call clear
call outch(0,0)
call weekday(day)
call date(today)
If (day .eq. 0)header='Welcome to GALAXY '//V//' on Wednesday, '//today
If (day .eq. 1) header='Welcome to GALAXY '//V//' on Thursday, '//today
If (day .eq. 2) header='Welcome to GALAXY '//V//' on Friday, '//today
If (day .eq. 3) header='Welcome to GALAXY '//V//' on Saturday, '//today
If (day .eq. 4) header='Welcome to GALAXY '//V//' on Sunday, '//today
If (day .eq. 5) header='Welcome to GALAXY '//V//' on Monday, '//today
If (day .eq. 6) header='Welcome to GALAXY '//V//' on Tuesday, '//today
If (day .gt. 6) header='Welcome to GALAXY '//V//', '//today
ih=index(header,'-')
WRITE(5, 1001)header(1:ih+6)
1001 format(' ',a)
2000 CONTINUE
WRITE(5, 1011)
1011 FORMAT('0The following Vessels are available:'/)
shpflg=.false.
DO 2030 I = 1, 8
IF (.NOT.(.NOT.XSHIP(I))) GOTO 2050
If (busy(i)) goto 2050
WRITE(5, 1021) I
1021 FORMAT(' Ship ', I1)
shpflg=.true.
2050 CONTINUE
2030 CONTINUE
2040 CONTINUE
if (shpflg) goto 1030
write(5,1032)
1032 format(' I''m sorry but all Ships have launched...',/,
1' It may be possible to share a Command...')
1030 WRITE(5, 1031)
1031 FORMAT(/'$Pick a Ship from our starfleet: ')
CALL GETINT(0, IW, OK, 1, 8, 0)
IF (.NOT.(OK)) GOTO 2070
IF (.NOT.(IW .EQ. 0)) GOTO 2090
OK = .FALSE.
GOTO 2010
2090 CONTINUE
WHO = IW
If (.not.(busy(who))) goto 1039
Write(5,9699)who
9699 format('0Sorry, ship ',i1,' is temporarily disabled!')
goto 1042
1039 IF (.NOT.(XSHIP(WHO))) GOTO 2110
If (share(who).eq.-1.or.share(who).eq.1) then
9918 WRITE(5, 1041)who
1041 FORMAT('0Ship ',i1' already has a full crew. Sorry!')
1042 call wait(60,1,m)
goto 1998
endif
WRITE(5, 1051)who
1051 FORMAT('$Ship ',i1,' already has a Commander.',
1' Do you wish to share this Command? ')
CALL YESNO(0, OK)
If ((ok) .and. (share(who) .eq. 1 .or. share(who) .eq. -1)) goto 9918
If (ok) share(who)=1
2110 CONTINUE
GOTO 2080
2070 CONTINUE
call clear
call outch(0,0)
write(5,4554)
4554 format(' Those who cannot follow instructions
1 cannot become Starfleet Commanders!')
CALL EXIT
2080 CONTINUE
2010 IF (.NOT.(OK)) GOTO 1998
2020 CONTINUE
If (.not.(xship(who))) then
xship(who)=.true.
If (share(who) .eq. 0) then
header='Allow Sharing? '
call respnd(header,yesshr)
If (share(who) .eq. 0 .and. (.not.(yesshr))) share(who)=-1
If (share(who) .eq. 1 .and. (.not.(yesshr))) then
write(5,901)
901 format(' Oops, someone else has slipped into the cockpit!')
endif
else
yesshr=.true.
endif
endif
header='Silent Game? '
call respnd(header,belflg)
call video('h')
REFRES = .TRUE.
REFTOG = .FALSE.
CREW(WHO) = CREW(WHO) + 1
DEFSHP = WHO
CALL STRMOV(BLUNK2, 1, 361, OBUFF, 1)
CALL RBUFF
IF (.NOT.(.NOT.QUIKUP)) GOTO 2130
C START 1 SECOND TIMER IF SLOW UPDATE
CALL MARK(3, 30, 1, IDS)
2130 CONTINUE
C START 1/2 SECOND TIMER
CALL MARK(2, 15, 1, IDS)
2150 CONTINUE
C
C THE FOLLOWING CALL SPAWNS THE MTREKD UNIVERSE MANAGER TASK ON TT0:.
C IF YOU CANNOT DO SOMETHING SIMILAR, YOU MUST START MTREKD YOURSELF
C BEFORE PLAYING EACH GAME.
C
IF (.NOT.(THRU)) GOTO 2180
C THEN MTREKD ISN'T RUNNING
c CALL RUNMTR
C
C PLACE LOCAL SCAN ON TERMINAL
C
2180 CONTINUE
timcnt=timcnt+1
if (timcnt .lt. 4) goto 9078
timcnt=0
call time(timbf)
call tpos(12,70)
encode(8,9009,mesbuf)timbf
9009 format (a8)
call outch(mesbuf,8)
9078 call video('7')
REFTOG = (.NOT.REFTOG) .OR. QUIKUP
IF (.NOT.((XSHIP(WHO) .AND. REFTOG) .OR. REFRES)) GOTO 5555
C DON'T REFRESH IF BLOWN UP!
CALL STRMOV(BLUNK, 1, 361, NBUFF, 1)
ID = SCAN(WHO)
MINID8 = MIN(ID, 8)
IXX = XCORD(WHO)
IYY = YCORD(WHO)
IXLOW = MAX(2, IXX - ID)
IXHI = MIN(99, IXX + ID)
IYLOW = MAX(2, IYY - ID)
IYHI = MIN(99, IYY + MINID8)
DO 2220 IX1 = IXLOW, IXHI
IX = IX1 - IXX
DO 2240 IY1 = IYLOW, IYHI
IY = IY1 - IYY
ALPHA = UNIV(IX1, IY1)
IF (.NOT.((ALPHA .GE. 48+1) .AND. (ALPHA .LE. 48+8) .AND.
*(CLOAK(ALPHA-48)))) GOTO 2260
NBUFF(IX, IY) = EMPTY
GOTO 2270
2260 CONTINUE
IF (.NOT.(ALPHA .LT. 0)) GOTO 2280
NBUFF(IX, IY) = '%'
GOTO 2290
2280 CONTINUE
NBUFF(IX, IY) = ALPHA
2290 CONTINUE
2270 CONTINUE
2240 CONTINUE
2250 CONTINUE
2220 CONTINUE
2230 CONTINUE
IF (.NOT.(IXX-ID .LE. 1)) GOTO 2300
CALL BNDRY(1, 1, MAX(1, IYY - ID), MIN(100, IYY + MINID8))
GOTO 2310
2300 CONTINUE
IF (.NOT.(IXX+ID .GE. 100)) GOTO 2320
CALL BNDRY(100, 100, MAX(1, IYY - ID), MIN(100, IYY + MINI
*D8))
2320 CONTINUE
2310 CONTINUE
IF (.NOT.(IYY-ID .LE. 1)) GOTO 2340
CALL BNDRY(MAX(1, IXX - ID), MIN(99, IXX + ID), 1, 1)
GOTO 2350
2340 CONTINUE
IF (.NOT.(IYY+ID .GE. 100)) GOTO 2360
CALL BNDRY(MAX(1, IXX - ID), MIN(99, IXX + ID), 100, 100)
2360 CONTINUE
2350 CONTINUE
IF (.NOT.(NBUFF(-ID, -ID) .EQ. EMPTY)) GOTO 2380
NBUFF( - ID, - ID) = '.'
2380 CONTINUE
IF (.NOT.(NBUFF(-ID, MINID8) .EQ. EMPTY)) GOTO 2400
NBUFF( - ID, MINID8) = '.'
2400 CONTINUE
IF (.NOT.(NBUFF(ID, MINID8) .EQ. EMPTY)) GOTO 2420
NBUFF(ID, MINID8) = '.'
2420 CONTINUE
IF (.NOT.(NBUFF(ID, -ID) .EQ. EMPTY)) GOTO 2440
NBUFF(ID, - ID) = '.'
2440 CONTINUE
DO 2460 IY = - 9, + 8
ICURSX = - 999
DO 2480 IX = - 9, + 9
IF (.NOT.(NBUFF(IX, IY) .NE. OBUFF(IX, IY))) GOTO 2500
IF (.NOT.(ICURSX .GE. IX-2)) GOTO 2520
DO 2540 III = ICURSX + 1, IX
CALL OUTCH(' ', 1)
CALL OUTCH(NBUFF(III, IY), 1)
2540 CONTINUE
2550 CONTINUE
GOTO 2530
2520 CONTINUE
CALL TPOS(9 - IY, 2*IX + 43)
CALL OUTCH(NBUFF(IX, IY), 1)
2530 CONTINUE
ICURSX = IX
OBUFF(IX, IY) = NBUFF(IX, IY)
2500 CONTINUE
2480 CONTINUE
2490 CONTINUE
2460 CONTINUE
2470 CONTINUE
CALL OUTCH(0, - 1)
5555 call video('0')
C
C THE FOLLOWING WAIT CONTROLS THE UPDATE RATE, WHICH IS NORMALLY
C SET TO A HALF SECOND (30 CLOCK TICKS).
C
2200 CONTINUE
IF (.NOT.(COMMND .NE. ' ' .AND. XSHIP(WHO))) GOTO 2560
IF (.NOT.(REFTOG)) GOTO 2580
CALL WAITFR(2, IDS)
IF (.NOT.(QUIKUP)) GOTO 2600
C RESTART 1/2 SECOND TIMER
CALL MARK(2, 15, 1, IDS)
2600 CONTINUE
GOTO 2590
2580 CONTINUE
CALL WAITFR(3, IDS)
C RESTART 1 SECOND TIMER
CALL MARK(3, 30, 1, IDS)
C RESTART 1/2 SECOND TIMER
CALL MARK(2, 15, 1, IDS)
2590 CONTINUE
2560 CONTINUE
Do 7666 ibb=1,8
If (share(ibb) .ne. -1) then
If (shrflg(ibb) .ne. share(ibb)) then
if (share(ibb) .eq. 1) then
if (ibb .eq. who) then
call video('1')
else
call video('7')
endif
call buffil((ibb+1),63,'Shr''d',5)
If (ibb .eq. who) then
call video('0')
endif
endif
if (share(ibb) .eq. 0) then
call buffil((ibb+1),63,' ',5)
endif
shrflg(ibb)=share(ibb)
endif
endif
7666 continue
If (playtm) goto 2998
If (wizard) goto 2998
crew(who)=crew(who)-1
if (.not.(crew(who) .le. 400)) goto 9979
xship(who)=.false.
goto 9969
9979 xship(who)=.true.
9969 call outch(0,0)
call purge
call beeper(7)
call tpos(23,20)
call video('1')
call outstr(.false.,'The GALAXY is now closed. Thanks for playing
1!',.false.)
call video('0')
call outch(0,0)
If (share(who) .eq. 1) share(who)=0
If (.not.(yesshr)) share(who)=0
call exit
2998 NC = 1
COMMND = '0 '
IF (.NOT.(XSHIP(WHO))) GOTO 2620
CALL TREAD(COMMND, NC)
C
C CHECK FOR NO INPUT
C
2620 CONTINUE
IF (.NOT.(COMMND .EQ. '0 ')) GOTO 2640
C
C LONG RANGE SCAN COMMAND
C
GOTO 2650
2640 CONTINUE
IF (.NOT.(COMMND .EQ. 'L ')) GOTO 2660
CALL GETINT('Target Ship? ', II, OK, 1, 8, DEFSHP)
IF (.NOT.(OK)) GOTO 2680
DEFSHP = II
IX = XCORD(II)/10.
IY = YCORD(II)/10.
CALL TPOS(18, 75)
ENCODE(5, 1071, MESBUF) IX, IY
1071 FORMAT(I2, ',', I2)
CALL OUTCH(MESBUF, 5)
XX = XCORD(WHO)
YY = YCORD(WHO)
X1 = XCORD(II)
IF (.NOT.(X1 .LT. 51.)) GOTO 2700
X2 = X1 + 100.
GOTO 2710
2700 CONTINUE
X2 = X1 - 100.
2710 CONTINUE
Y1 = YCORD(II)
IF (.NOT.(Y1 .LT. 51.)) GOTO 2720
Y2 = Y1 + 100.
GOTO 2730
2720 CONTINUE
Y2 = Y1 - 100.
2730 CONTINUE
D1(1) = ((XX - X1)**2 + (YY - Y1)**2)**.5
D1(2) = ((XX - X1)**2 + (YY - Y2)**2)**.5
D1(3) = ((XX - X2)**2 + (YY - Y1)**2)**.5
D1(4) = ((XX - X2)**2 + (YY - Y2)**2)**.5
IIT = 1
DO 2740 J = 2, 4
IF (.NOT.(D1(J) .LT. D1(IIT))) GOTO 2760
IIT = J
2760 CONTINUE
2740 CONTINUE
2750 CONTINUE
D = D1(IIT)
IF (.NOT.(IIT .EQ. 1)) GOTO 2780
YD = Y1
XD = X1
GOTO 2790
2780 CONTINUE
IF (.NOT.(IIT .EQ. 2)) GOTO 2800
YD = Y2
XD = X1
GOTO 2810
2800 CONTINUE
IF (.NOT.(IIT .EQ. 3)) GOTO 2820
YD = Y1
XD = X2
GOTO 2830
2820 CONTINUE
YD = Y2
XD = X2
2830 CONTINUE
2810 CONTINUE
2790 CONTINUE
EDIS = D
EDIR = ATAN3((YD - YY), (XD - XX))*57.29577951
IF (.NOT.(EDIR .LT. 0.)) GOTO 2840
EDIR = EDIR + 360.
2840 CONTINUE
IF (.NOT.(EDIR .GT. 90.)) GOTO 2860
EDIR = (450. - EDIR)/30.
GOTO 2870
2860 CONTINUE
EDIR = (90. - EDIR)/30.
2870 CONTINUE
DEFDIR = EDIR
CALL TPOS(17, 75)
ENCODE(5, 1081, MESBUF) EDIS
1081 FORMAT(F5.2)
CALL OUTCH(MESBUF, 5)
CALL TPOS(16, 75)
ENCODE(5, 1091, MESBUF) EDIR
1091 FORMAT(F5.2)
CALL OUTCH(MESBUF, 5)
CALL TPOS(15, 79)
ENCODE(1, 1101, MESBUF) DEFSHP
1101 FORMAT(I1)
CALL OUTCH(MESBUF, 1)
CALL OUTCH(0, - 1)
2680 CONTINUE
PROGRAM PLAYER
C
C MAY 1980 BILL CAEL AND BILL WOOD RECODED IN RATFOR
C MAY 1980 BILL CAEL AND BILL WOOD ADDED DEFAULT SHIP AND DIRECTION
C MAY 1980 BILL WOOD ADDED ENERGY NETS
C MAY 1980 BILL CAEL AND BILL WOOD RECODED OUTPUT
C MAY 1980 BILL CAEL, BILL WOOD, AND BOB STODOLA
C RECODED COMMAND ARG PROMPTING
C NOV 1980 BILL WOOD CONVERTED TO RUN ON VAX
C
C July/August 1981 Stuart Renes, Western Electric Co.
C Mixed Case messages, added sound effects
C Improved Driver controls
C ^C Intercept AST, Exit handler
C Play periods (including weekend control)
C VT100 advanced video features - renamed GALAXY V1.0
C Lowered Refresh rates in half
C
C Version 1.1 September 8th, 1981
C Added purge of type-ahead when destroyed or at games end.
C
C Version 1.2 September 10th, 1981
C Added silent play option.
C
C Version 1.3 September 17th, 1981
C Added Shared Command Display and control.
C More code cleanup.
C
C Version 1.4 September 23rd, 1981
C Tighten window in which users can beat the "SHARED" feature.
C
C Version 1.5 September 27th, 1981
C Fix bugs that creeped in from V1.4.
C
C Version 1.6 October 2nd, 1981
C Changed Initialization to force active players off.
C Slight esthetic change at close of game period.
C Describe previously un-documented features in HELP file.
C
TEXT COMMON
COMMON/TORPE/TLOCS(8, 10, 2), TDIR(8, 10), IT(8)
COMMON/LEDFOR/ENERGY(8), SHIELD(8), XCORD(8), YCORD(8), TORPS(8),
*HX, HY, HW, CDRAIN, NDRAIN, TDRAIN, SCAN(8), PHA(8), I1, I2, HYPER
*(8), ISENT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XH
*OM(8, 4), YHOM(8, 4), WHOM(8, 4), NHOM(8), TRBEAM(8), SCORE(8), CR
*EW(8), DIR(8), WARP(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), TH
*RU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY
REAL LAUNCH, NDRAIN
INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM
LOGICAL*1THRU, XSHIP, CLOAK, NET
C NOTE: BHOLE AND EMPTY ARE THE CHARACTERS FOR THE BLACK HOLE
C AND EMPTY SPACE AND ARE SET IN MTREKINI.
BYTE UNIV, MESSAG, BHOLE, EMPTY
C END COMMON
common/local/shrflg(8)
common/double/share(8),busy(8)
logical*1 busy
integer share,shrflg,day
character*9 today
character*80 header
character*4 V
data V /'V1.6'/
common/signal/playtm
integer timcnt
data timcnt/4/
logical*1 playtm,wizard,myplay,shpflg,yesshr
LOGICAL*1OK, DONE, YES, WARN, REFRES, REFTOG
LOGICAL QUIKUP,supflg
common done
common/silent/belflg
logical*1 belflg
character*19 paswrd,answer
character*8 timbf
byte pasbuf(19)
data paswrd/'starship enterprise'/
REAL SC(9), R(9)
INTEGER DEFSHP, OLDSHP
REAL DEFDIR, OLDDIR
COMMON/DEFLTS/DEFSHP, DEFDIR, OLDDIR, OLDSHP, DEFSHD
LOGICAL CLEARF, VERBOS
COMMON/MESS/CLEARF, VERBOS
BYTE BLANK(80), ALPHA, MESBUF(60)
REAL D1(4)
BYTE BLUNK(2)
BYTE BLUNK2(2)
BYTE OBUFF( - 9: + 9, - 9: + 9)
BYTE JUNK, NBUFF
COMMON/BNDRY/IXX, IYY, ID, MINID8, JUNK, NBUFF( - 9: + 9, - 9: +
*9)
INTEGER COMMND
common/me/who
INTEGER WHO
EQUIVALENCE(BLUNK(2), NBUFF( - 9, - 9))
EQUIVALENCE(BLUNK2(2), OBUFF( - 9, - 9))
DATA BLANK/80*' '/
DATA BLUNK, BLUNK2/4*' '/
DATA SC/9* - 9999./
DATA R/9* - 9999./
DATA DONE/.FALSE./
DATA OK/.FALSE./
wizard=.false.
DATA DEFDIR/0.0/, DEFSHD/0.0/
C
C QUIKUP IS SET TRUE IF TERMINAL SPEED EXCEEDS A THRESHOLD
C DETERMINED IN GTCHAR.
C IF QUIKUP IS TRUE, A FULL SCREEN UPDATE OCCURS EVERY 1/2 SECOND;
C AT SLOWER SPEEDS, 1/2 THE SCREEN IS UPDATED EVERY SECOND ON THE
C HALF SECOND, THE OTHER 1/2 IS UPDATED EVERY SECOND ON THE SECOND.
C THIS ALLOWS ENJOYABLE GAMES ON TERMINALS AS SLOW AS 1200 BAUD.
C
C GET QUIKUP, INITIALIZE TERMINAL IO
C
C If supflg is .FALSE. then terminal type is NOT supported and we will
C exit and give him an explaination.
C If MYPLAY is .FALSE. then it must be OFFHOURS and we won't let him in!
C
CALL GTCHAR(QUIKUP,supflg)
If (supflg) goto 1000
write(5,1999)
1999 format(' You obviously didn''t read the instructions
1 about terminal setup.')
call exit
1000 call daytim(myplay)
call video('<')
If (myplay) goto 1998
call clear
call outch(0,0)
write(5,1995)
1995 format(' I''m sorry but the Galaxy is CLOSED now.',//,
1' Entrance is allowed only to those who can',/,
1'$demonstrate their worthiness. ')
call inchar(pasbuf,19,.false.,3,nc,ierr)
call clear
call outch(0,0)
if (ierr .ge. 0) goto 1993
If (ierr .eq. -2) then
call video('5')
write(5,1992)
1992 format(' I''m sorry but you are clearly unworthy!',/
1,' Come back during regular hours of play.')
call video('0')
call exit
endif
1993 encode(19,9934,answer)pasbuf
9934 format(19a1)
If (answer .ne. paswrd) goto 1996
wizard=.true.
goto 1998
1996 call video('5')
write(5,1992)
call video('0')
call exit
1998 call clear
call outch(0,0)
call weekday(day)
call date(today)
If (day .eq. 0)header='Welcome to GALAXY '//V//' on Wednesday, '//today
If (day .eq. 1) header='Welcome to GALAXY '//V//' on Thursday, '//today
If (day .eq. 2) header='Welcome to GALAXY '//V//' on Friday, '//today
If (day .eq. 3) header='Welcome to GALAXY '//V//' on Saturday, '//today
If (day .eq. 4) header='Welcome to GALAXY '//V//' on Sunday, '//today
If (day .eq. 5) header='Welcome to GALAXY '//V//' on Monday, '//today
If (day .eq. 6) header='Welcome to GALAXY '//V//' on Tuesday, '//today
If (day .gt. 6) header='Welcome to GALAXY '//V//', '//today
ih=index(header,'-')
WRITE(5, 1001)header(1:ih+6)
1001 format(' ',a)
2000 CONTINUE
WRITE(5, 1011)
1011 FORMAT('0The following Vessels are available:'/)
shpflg=.false.
DO 2030 I = 1, 8
IF (.NOT.(.NOT.XSHIP(I))) GOTO 2050
If (busy(i)) goto 2050
WRITE(5, 1021) I
1021 FORMAT(' Ship ', I1)
shpflg=.true.
2050 CONTINUE
2030 CONTINUE
2040 CONTINUE
if (shpflg) goto 1030
write(5,1032)
1032 format(' I''m sorry but all Ships have launched...',/,
1' It may be possible to share a Command...')
1030 WRITE(5, 1031)
1031 FORMAT(/'$Pick a Ship from our starfleet: ')
CALL GETINT(0, IW, OK, 1, 8, 0)
IF (.NOT.(OK)) GOTO 2070
IF (.NOT.(IW .EQ. 0)) GOTO 2090
OK = .FALSE.
GOTO 2010
2090 CONTINUE
WHO = IW
If (.not.(busy(who))) goto 1039
Write(5,9699)who
9699 format('0Sorry, ship ',i1,' is temporarily disabled!')
goto 1042
1039 IF (.NOT.(XSHIP(WHO))) GOTO 2110
If (share(who).eq.-1.or.share(who).eq.1) then
9918 WRITE(5, 1041)who
1041 FORMAT('0Ship ',i1' already has a full crew. Sorry!')
1042 call wait(60,1,m)
goto 1998
endif
WRITE(5, 1051)who
1051 FORMAT('$Ship ',i1,' already has a Commander.',
1' Do you wish to share this Command? ')
CALL YESNO(0, OK)
If ((ok) .and. (share(who) .eq. 1 .or. share(who) .eq. -1)) goto 9918
If (ok) share(who)=1
2110 CONTINUE
GOTO 2080
2070 CONTINUE
call clear
call outch(0,0)
write(5,4554)
4554 format(' Those who cannot follow instructions
1 cannot become Starfleet Commanders!')
CALL EXIT
2080 CONTINUE
2010 IF (.NOT.(OK)) GOTO 1998
2020 CONTINUE
If (.not.(xship(who))) then
xship(who)=.true.
If (share(who) .eq. 0) then
header='Allow Sharing? '
call respnd(header,yesshr)
If (share(who) .eq. 0 .and. (.not.(yesshr))) share(who)=-1
If (share(who) .eq. 1 .and. (.not.(yesshr))) then
write(5,901)
901 format(' Oops, someone else has slipped into the cockpit!')
endif
else
yesshr=.true.
endif
endif
header='Silent Game? '
call respnd(header,belflg)
call video('h')
REFRES = .TRUE.
REFTOG = .FALSE.
CREW(WHO) = CREW(WHO) + 1
DEFSHP = WHO
CALL STRMOV(BLUNK2, 1, 361, OBUFF, 1)
CALL RBUFF
IF (.NOT.(.NOT.QUIKUP)) GOTO 2130
C START 1 SECOND TIMER IF SLOW UPDATE
CALL MARK(3, 30, 1, IDS)
2130 CONTINUE
C START 1/2 SECOND TIMER
CALL MARK(2, 15, 1, IDS)
2150 CONTINUE
C
C THE FOLLOWING CALL SPAWNS THE MTREKD UNIVERSE MANAGER TASK ON TT0:.
C IF YOU CANNOT DO SOMETHING SIMILAR, YOU MUST START MTREKD YOURSELF
C BEFORE PLAYING EACH GAME.
C
IF (.NOT.(THRU)) GOTO 2180
C THEN MTREKD ISN'T RUNNING
c CALL RUNMTR
C
C PLACE LOCAL SCAN ON TERMINAL
C
2180 CONTINUE
timcnt=timcnt+1
if (timcnt .lt. 4) goto 9078
timcnt=0
call time(timbf)
call tpos(12,70)
encode(8,9009,mesbuf)timbf
9009 format (a8)
call outch(mesbuf,8)
9078 call video('7')
REFTOG = (.NOT.REFTOG) .OR. QUIKUP
IF (.NOT.((XSHIP(WHO) .AND. REFTOG) .OR. REFRES)) GOTO 5555
C DON'T REFRESH IF BLOWN UP!
CALL STRMOV(BLUNK, 1, 361, NBUFF, 1)
ID = SCAN(WHO)
MINID8 = MIN(ID, 8)
IXX = XCORD(WHO)
IYY = YCORD(WHO)
IXLOW = MAX(2, IXX - ID)
IXHI = MIN(99, IXX + ID)
IYLOW = MAX(2, IYY - ID)
IYHI = MIN(99, IYY + MINID8)
DO 2220 IX1 = IXLOW, IXHI
IX = IX1 - IXX
DO 2240 IY1 = IYLOW, IYHI
IY = IY1 - IYY
ALPHA = UNIV(IX1, IY1)
IF (.NOT.((ALPHA .GE. 48+1) .AND. (ALPHA .LE. 48+8) .AND.
*(CLOAK(ALPHA-48)))) GOTO 2260
NBUFF(IX, IY) = EMPTY
GOTO 2270
2260 CONTINUE
IF (.NOT.(ALPHA .LT. 0)) GOTO 2280
NBUFF(IX, IY) = '%'
GOTO 2290
2280 CONTINUE
NBUFF(IX, IY) = ALPHA
2290 CONTINUE
2270 CONTINUE
2240 CONTINUE
2250 CONTINUE
2220 CONTINUE
2230 CONTINUE
IF (.NOT.(IXX-ID .LE. 1)) GOTO 2300
CALL BNDRY(1, 1, MAX(1, IYY - ID), MIN(100, IYY + MINID8))
GOTO 2310
2300 CONTINUE
IF (.NOT.(IXX+ID .GE. 100)) GOTO 2320
CALL BNDRY(100, 100, MAX(1, IYY - ID), MIN(100, IYY + MINI
*D8))
2320 CONTINUE
2310 CONTINUE
IF (.NOT.(IYY-ID .LE. 1)) GOTO 2340
CALL BNDRY(MAX(1, IXX - ID), MIN(99, IXX + ID), 1, 1)
GOTO 2350
2340 CONTINUE
IF (.NOT.(IYY+ID .GE. 100)) GOTO 2360
CALL BNDRY(MAX(1, IXX - ID), MIN(99, IXX + ID), 100, 100)
2360 CONTINUE
2350 CONTINUE
IF (.NOT.(NBUFF(-ID, -ID) .EQ. EMPTY)) GOTO 2380
NBUFF( - ID, - ID) = '.'
2380 CONTINUE
IF (.NOT.(NBUFF(-ID, MINID8) .EQ. EMPTY)) GOTO 2400
NBUFF( - ID, MINID8) = '.'
2400 CONTINUE
IF (.NOT.(NBUFF(ID, MINID8) .EQ. EMPTY)) GOTO 2420
NBUFF(ID, MINID8) = '.'
2420 CONTINUE
IF (.NOT.(NBUFF(ID, -ID) .EQ. EMPTY)) GOTO 2440
NBUFF(ID, - ID) = '.'
2440 CONTINUE
DO 2460 IY = - 9, + 8
ICURSX = - 999
DO 2480 IX = - 9, + 9
IF (.NOT.(NBUFF(IX, IY) .NE. OBUFF(IX, IY))) GOTO 2500
IF (.NOT.(ICURSX .GE. IX-2)) GOTO 2520
DO 2540 III = ICURSX + 1, IX
CALL OUTCH(' ', 1)
CALL OUTCH(NBUFF(III, IY), 1)
2540 CONTINUE
2550 CONTINUE
GOTO 2530
2520 CONTINUE
CALL TPOS(9 - IY, 2*IX + 43)
CALL OUTCH(NBUFF(IX, IY), 1)
2530 CONTINUE
ICURSX = IX
OBUFF(IX, IY) = NBUFF(IX, IY)
2500 CONTINUE
2480 CONTINUE
2490 CONTINUE
2460 CONTINUE
2470 CONTINUE
CALL OUTCH(0, - 1)
5555 call video('0')
C
C THE FOLLOWING WAIT CONTROLS THE UPDATE RATE, WHICH IS NORMALLY
C SET TO A HALF SECOND (30 CLOCK TICKS).
C
2200 CONTINUE
IF (.NOT.(COMMND .NE. ' ' .AND. XSHIP(WHO))) GOTO 2560
IF (.NOT.(REFTOG)) GOTO 2580
CALL WAITFR(2, IDS)
IF (.NOT.(QUIKUP)) GOTO 2600
C RESTART 1/2 SECOND TIMER
CALL MARK(2, 15, 1, IDS)
2600 CONTINUE
GOTO 2590
2580 CONTINUE
CALL WAITFR(3, IDS)
C RESTART 1 SECOND TIMER
CALL MARK(3, 30, 1, IDS)
C RESTART 1/2 SECOND TIMER
CALL MARK(2, 15, 1, IDS)
2590 CONTINUE
2560 CONTINUE
Do 7666 ibb=1,8
If (share(ibb) .ne. -1) then
If (shrflg(ibb) .ne. share(ibb)) then
if (share(ibb) .eq. 1) then
if (ibb .eq. who) then
call video('1')
else
call video('7')
endif
call buffil((ibb+1),63,'Shr''d',5)
If (ibb .eq. who) then
call video('0')
endif
endif
if (share(ibb) .eq. 0) then
call buffil((ibb+1),63,' ',5)
endif
shrflg(ibb)=share(ibb)
endif
endif
7666 continue
If (playtm) goto 2998
If (wizard) goto 2998
crew(who)=crew(who)-1
if (.not.(crew(who) .le. 400)) goto 9979
xship(who)=.false.
goto 9969
9979 xship(who)=.true.
9969 call outch(0,0)
call purge
call beeper(7)
call tpos(23,20)
call video('1')
call outstr(.false.,'The GALAXY is now closed. Thanks for playing
1!',.false.)
call video('0')
call outch(0,0)
If (share(who) .eq. 1) share(who)=0
If (.not.(yesshr)) share(who)=0
call exit
2998 NC = 1
COMMND = '0 '
IF (.NOT.(XSHIP(WHO))) GOTO 2620
CALL TREAD(COMMND, NC)
C
C CHECK FOR NO INPUT
C
2620 CONTINUE
IF (.NOT.(COMMND .EQ. '0 ')) GOTO 2640
C
C LONG RANGE SCAN COMMAND
C
GOTO 2650
2640 CONTINUE
IF (.NOT.(COMMND .EQ. 'L ')) GOTO 2660
CALL GETINT('Target Ship? ', II, OK, 1, 8, DEFSHP)
IF (.NOT.(OK)) GOTO 2680
DEFSHP = II
IX = XCORD(II)/10.
IY = YCORD(II)/10.
CALL TPOS(18, 75)
ENCODE(5, 1071, MESBUF) IX, IY
1071 FORMAT(I2, ',', I2)
CALL OUTCH(MESBUF, 5)
XX = XCORD(WHO)
YY = YCORD(WHO)
X1 = XCORD(II)
IF (.NOT.(X1 .LT. 51.)) GOTO 2700
X2 = X1 + 100.
GOTO 2710
2700 CONTINUE
X2 = X1 - 100.
2710 CONTINUE
Y1 = YCORD(II)
IF (.NOT.(Y1 .LT. 51.)) GOTO 2720
Y2 = Y1 + 100.
GOTO 2730
2720 CONTINUE
Y2 = Y1 - 100.
2730 CONTINUE
D1(1) = ((XX - X1)**2 + (YY - Y1)**2)**.5
D1(2) = ((XX - X1)**2 + (YY - Y2)**2)**.5
D1(3) = ((XX - X2)**2 + (YY - Y1)**2)**.5
D1(4) = ((XX - X2)**2 + (YY - Y2)**2)**.5
IIT = 1
DO 2740 J = 2, 4
IF (.NOT.(D1(J) .LT. D1(IIT))) GOTO 2760
IIT = J
2760 CONTINUE
2740 CONTINUE
2750 CONTINUE
D = D1(IIT)
IF (.NOT.(IIT .EQ. 1)) GOTO 2780
YD = Y1
XD = X1
GOTO 2790
2780 CONTINUE
IF (.NOT.(IIT .EQ. 2)) GOTO 2800
YD = Y2
XD = X1
GOTO 2810
2800 CONTINUE
IF (.NOT.(IIT .EQ. 3)) GOTO 2820
YD = Y1
XD = X2
GOTO 2830
2820 CONTINUE
YD = Y2
XD = X2
2830 CONTINUE
2810 CONTINUE
2790 CONTINUE
EDIS = D
EDIR = ATAN3((YD - YY), (XD - XX))*57.29577951
IF (.NOT.(EDIR .LT. 0.)) GOTO 2840
EDIR = EDIR + 360.
2840 CONTINUE
IF (.NOT.(EDIR .GT. 90.)) GOTO 2860
EDIR = (450. - EDIR)/30.
GOTO 2870
2860 CONTINUE
EDIR = (90. - EDIR)/30.
2870 CONTINUE
DEFDIR = EDIR
CALL TPOS(17, 75)
ENCODE(5, 1081, MESBUF) EDIS
1081 FORMAT(F5.2)
CALL OUTCH(MESBUF, 5)
CALL TPOS(16, 75)
ENCODE(5, 1091, MESBUF) EDIR
1091 FORMAT(F5.2)
CALL OUTCH(MESBUF, 5)
CALL TPOS(15, 79)
ENCODE(1, 1101, MESBUF) DEFSHP
1101 FORMAT(I1)
CALL OUTCH(MESBUF, 1)
CALL OUTCH(0, - 1)
2680 CONTINUE
Fortran 2 C Translator