% VAX-11 Librarian V03-00 ÷@`ɍq  p  yCANMOVE~CLOSEUPCOMLINK DISPLAYERROR FIRSTMOVEGETPIECEHELPINIT"IWAIT&KEYQIOLINKUP0MAIL4MOVE; MOVEPIECE@OUTPUTHPOINTQRECAPWSETUP^STRATEGOdSTRIKEhWELCOME P s%J GORDON CANMOVE >IJ GORDON CLOSEUP BJ GORDON COMLINK DJ GORDON DISPLAYJ GORDON ERROR"J GORDON FIRSTMOVE!J GORDON GETPIECE LJ GORDON HELP}J GORDON INIT J GORDON IWAIT@J GORDON KEYQIOOJ GORDON LINKUPK GORDON MAIL 7K GORDON MOVE"`K G  FɍC STRATEGO oHC Copyright (c) 1984. No copies of this text may be distributed without@C written permission of the author or Hughes SCG/PWB department.C IC Permission is hereby granted to distribute executable images throughoutGC the DECUS community and Hughes Aircraft. Source modules are releasedcGC to DECUS members and Hughes Aircraft employees only. This software is BC subject to change without notice. Neither the author nor HughesBC Aircraft Co. assumes any liabilities for the performance of this C softwareCM%C Author: Gordon Howello@C Hughes Aircraft Space and CommunicationsC PO Box 92919C Bldg S50/X342 'C Los Angeles, CAE$C 213-419-0254C,0C Display --- routine to print out the board.  SUBROUTINE Display# INCLUDE 'stratego.inc/NOLIST'L< INTEGER His_Base_Row , Row, Col, Col_No, Row_No, Index+ INTEGER My_Base_Row, Index_1, Index_2e ɍC STRATEGO GHC Copyright (c) 1984. No copies of this text may be distributed without@C written permission of the author or Hughes SCG/PWB department.CNIC Permission is hereby granted to distribute executable images throughoutGC the DECUS community and Hughes Aircraft. Source modules are released*GC to DECUS members and Hughes Aircraft employees only. This software is BC subject to change without notice. Neither the author nor HughesBC Aircraft Co. assumes any liabilities for the performance of this C softwareCg%C Author: Gordon Howellw@C Hughes Aircraft Space and CommunicationsC PO Box 92919C Bldg S50/X342u'C Los Angeles, CAo$C 213-419-0254Ch,C S_Error --- routine to do error handling( SUBROUTINE S_Error(R,C,text,video)# INCLUDE 'Stratego.INC/NOLIST'N/ INTEGER R,C !screen address to reset tod, INTEGER Mode,video !video attributes ɍC STRATEGO NHC Copyright (c) 1984. No copies of this text may be distributed without@C written permission of the author or Hughes SCG/PWB department.C IC Permission is hereby granted to distribute executable images throughout*GC the DECUS community and Hughes Aircraft. Source modules are releasednGC to DECUS members and Hughes Aircraft employees only. This software isiBC subject to change without notice. Neither the author nor HughesBC Aircraft Co. assumes any liabilities for the performance of this C softwareC %C Author: Gordon Howell @C Hughes Aircraft Space and CommunicationsC PO Box 92919C Bldg S50/X342 'C Los Angeles, CA $C 213-419-0254C JC First_Move --- Subroutine to synchronize players and decide who moves'C first (= person who sets up fastest!)/ SUBROUTINE First_Moves# INCLUDE 'Stratego.INC/NOLIST'E INTEGER*4 Statet CHARACTER*80 Linee Call LIB$SET_CURSOR(1,1), If (First_Turn .EQ. 0) First_Turn = Me% IF (First_Turn .EQ. Me) GOTO 10VEC--Here if second player... wait until first player flags me through ) Call Mail(Me, Move_Second)? Call Wait_For(My_Wait_Flag) !wait for 1st to get to IWAIT  RETURN.C--Come here if no mail, and thus first player10 Continue CALL Mail(Me, Move_First)l RETURN)3000 STOP 'FIRSTMOVE - Event flag error'T ENDewwAL(Error_Row),%VAL(Error_Col),R +%VAL(Mode))CC call SCR$PUT_SCREEN(Line_2,%VAL(Error_Row+1),%VAL(Error_Col),C +%VAL(Mode))i call LIB$SET_CURSOR(R,C)< If (Video .EQ. Default) Call Set_Video(Code(Bell)(:1)) Error_Set = .TRUE. return END %C--Subroutine to clear the error aread SUBROUTINE Clear_Error# INCLUDE 'STRATEGO.INC/NOLIST'P CHARACTER*76 Blank DATA Blank/' '/O3 Call S_Error(Curr_Row,Curr_Col,B @|ՙɍC STRATEGO HC Copyright (c) 1984. No copies of this text may be distributed without@C written permission of the author or Hughes SCG/PWB department.CUIC Permission is hereby granted to distribute executable images throughoutMGC the DECUS community and Hughes Aircraft. Source modules are releasedcGC to DECUS members and Hughes Aircraft employees only. This software ishBC subject to change without notice. Neither the author nor HughesBC Aircraft Co. assumes any liabilities for the performance of this C softwareCe%C Author: Gordon Howell @C Hughes Aircraft Space and CommunicationsC PO Box 92919C Bldg S50/X342A'C Los Angeles, CAn$C 213-419-0254C-@C GetPiece --- routine to prompt the player for a piece to move$ SUBROUTINE GetPiece(Row,Col,*)# INCLUDE 'Stratego.INC/NOLIST't INTEGER Row,Col,R,Cg)C--Check to see if a moveable piece exits   DO 10 C=MinCol,MaxCol  DO 11 R=MinRow,MaxRowG IF (Board(R,C)*Me.LE.Spy.AND.Board(R,C)*Me.GE.Marshal) THENO' If (Canmove(R,C)) GOTO 1u END IF11 CONTINUE 10 CONTINUE0 RETURN 1 !return abnormally if no piece>1 CALL Mail(Me, Pick_Piece) !ask player to select a pieceC--Now get a piece71 Piece = 0r# CALL Point(Row,Col,Piece,*71) 1C---check to see if he wants to strike his colors . IF (Board(Row,Col)*Me .NE. Flag) Goto 508 Msg = 'Do you really wish to strike your colors? ' Call OUTPUT(-41,Msg)< If (Msg(1:1) .NE. 'Y' .AND. Msg(1:1) .NE. 'y') GoTo 20 Surrender = .TRUE. RETURN 1 "C---check that square is not empty>50 IF (Board(Row,Col)*Me .NE. Empty .AND. Board(Row,Col)*Me +.NE. Impasse) GOTO 40? CALL S_Error(Curr_Row,Curr_Col,Message(No_Piece),default)L GOTO 14C--check to see if he pointed to an OK piece to moveA40 IF (Board(Row,Co ɍC STRATEGO LHC Copyright (c) 1984. No copies of this text may be distributed without@C written permission of the author or Hughes SCG/PWB department.C=IC Permission is hereby granted to distribute executable images throughout,GC the DECUS community and Hughes Aircraft. Source modules are released,GC to DECUS members and Hughes Aircraft employees only. This software ishBC subject to change without notice. Neither the author nor HughesBC Aircraft Co. assumes any liabilities for the performance of this C softwareC %C Author: Gordon Howelle@C Hughes Aircraft Space and CommunicationsC PO Box 92919C Bldg S50/X342n'C Los Angeles, CAl$C 213-419-0254Ct SUBROUTINE HELPn# INCLUDE 'STRATEGO.INC/NOLIST'  INTEGER IndexI CHARACTER*80 Line C OPEN(Unit=HlpFil,Name='STRATEGO_HELP:',READONLY,STATUS='OLD')C1 Call LIB$ERASE_PAGE(1,1) Do i = 1,23=% READ(HlpFil,2,END=200) line ,2 FORMAT(A)+ Call LIB$PUT_SCREEN(line,i,1,none). End DoC Call LIB$PUT_SCREEN('Hit any key for more, "Q" to exit HELP',  +24,40,Reverse) InChar = Tinput() 7 If (inchar .eq. 81 .or. inchar .eq. 113) goto 200k goto 1C200 Call LIB$PUT_SCREEN('Hit any key to continue... ',A +24,40,reverse) InChar = Tinput()e Call Display Close (HlpFil) RETURN Entry Quick_HelpD OPEN(Unit=HlpFil,Name='STRATEGO_QUICK:',READONLY,STATUS='OLD') goto 1 END(ww:1) .NE. 'Y' .AND. Msg(1:1) .NE. 'y') GoTo 20 Surrender = .TRUE. RETURN 1 "C---check that square is not empty>50 IF (Board(Row,Col)*Me .NE. Empty .AND. Board(Row,Col)*Me +.NE. Impasse) GOTO 40e? CALL S_Error(Curr_Row,Curr_Col,Message(No_Piece),default)i GOTO 14C--check to see if he pointed to an OK piece to moveA40 IF (Board(Row,Co ɍC STRATEGO HC Copyright (c) 1984. No copies of this text may be distributed without@C written permission of the author or Hughes SCG/PWB department.CFIC Permission is hereby granted to distribute executable images throughout3GC the DECUS community and Hughes Aircraft. Source modules are releasedaGC to DECUS members and Hughes Aircraft employees only. This software isBC subject to change without notice. Neither the author nor HughesBC Aircraft Co. assumes any liabilities for the performance of this C softwareC %C Author: Gordon Howelle@C Hughes Aircraft Space and CommunicationsC PO Box 92919C Bldg S50/X342n'C Los Angeles, CAl$C 213-419-0254Ct;C Init --- subroutine to initialize data for each processC SUBROUTINE Initc# INCLUDE 'Stratego.INC/NOLIST'E INTEGER i,j,Indexh Board(4,2) = Impasse Board(4,3) = Impasse Board(4,6) = Impasse Board(4,7) = Impasse Board(5,2) = Impasse Board(5,3) = Impasse Board(5,6) = Impasse Board(5,7) = Impasse Index = 09 Do i = Marshal,Bomb ! Do j = 1, Piece_Count(i)C Index = Index + 1-' If (Index .GT. Max_Pieces) < + STOP 'Piece distribution exceeds maximum pieces'% Prison(index) = Symbol(i)l End doG1 ContinueT End Do Prisoners = IndexG Turn = 1 !1 code(Graphics_Off) = CHAR(27) // '(' // 'B'0 code(Graphics_On) = CHAR(27) // '(' // '0'+ code(Double) = CHAR(27) // '#' // '6'P= code(Reverse_Screen) = CHAR(27) // '[' //'?'//'5'//'h' 4< code(Normal_Screen) = CHAR(27) // '[' //'?'//'5'//'l' < code(Cursor_Key_on) = CHAR(27) // '[' //'?'//'1'//'h' = code(Cursor_Key_off) = CHAR(27) // '[' //'?'//'1'//'l' +) code(Numeric_Pad) = CHAR(27) // '>' - code(Application_Pad) = CHAR(27) // '='E code(B!* LOGICAL FUNCTION Check_Prison(Piece)# INCLUDE 'Stratego.INC/NOLIST' INTEGER Piece, i Check_Prison = .FALSE. DO i = 1,Prisoners@ If (Prison(i) .EQ. Symbol(Piece)) Check_Prison = .TRUE. End Do RETURN END SUBROUTINE Fix_Prison# INCLUDE 'STRATEGO.INC/NOLIST' INTEGER N, i,j& N = MIN(Max_Prisoners,Prisoners) Do i = 1, N% If (Prison(i) .EQ. ' ') Then% Prisoners = ell) = CHAR(7)' code(Siren) = CHAR(27) // '[145q'G- code(Underscore_on) = CHAR(27) // '[4m'& code(No_Video) = CHAR(27)//'[0m' Curr_row = Row_0 Curr_Col = Col_0 Error_Set = .FALSE. Ptr_Line = 0 N_Lines = 0  Window_Size = 0  Exit_Flag = .FALSE.C Surrender = .FALSE.  SetUp_Mode = .TRUE.rC--Load message arraye. OPEN (Unit=MesFil,Name='STRATEGO_TEXT:',# +READONLY,SHARED,STATUS='OLD')o Do i = 1,Null_Mess #1:ɍC STRATEGO HC Copyright (c) 1984. No copies of this text may be distributed without@C written permission of the author or Hughes SCG/PWB department.CFIC Permission is hereby granted to distribute executable images throughout3GC the DECUS community and Hughes Aircraft. Source modules are releasedaGC to DECUS members and Hughes Aircraft employees only. This software isBC subject to change without notice. Neither the author nor HughesBC Aircraft Co. assumes any lia$bilities for the performance of this C softwareCi%C Author: Gordon Howell @C Hughes Aircraft Space and CommunicationsC PO Box 92919C Bldg S50/X342 'C Los Angeles, CA $C 213-419-0254CoLC IWait --- routine to hibernate player. Tells other process to go for it,%C puts current process in wait state./CI SUBROUTINE IWait(*) # INCLUDE 'Stratego.INC/NOLIST' % INTEGER Mask !event flag% maskI3 INTEGER*4 STATE !status flag set by $READEF=4 INTEGER X,Y !placeholders for current cursor X = Curr_Row Y = Curr_Col Curr_Col = Cursor_Wait_Col Curr_Row = Cursor_Wait_Row? Call Set_EF(His_Wait_Flag) !Signal other process to starteA Call Wait_for(My_Wait_Flag) !Wait until other process clearm Curr_Row = X Curr_Col = Y"C--Check for termination condition# Call READ_EF(Abort_EF, State)r@ If ((Abort_Msk .AND. Sta te) .NE. 0) RETURN 1 !Check abort RETURN END  ww// '(' // '0'+ code(Double) = CHAR(27) // '#' // '6'm= code(Reverse_Screen) = CHAR(27) // '[' //'?'//'5'//'h' < code(Normal_Screen) = CHAR(27) // '[' //'?'//'5'//'l' < code(Cursor_Key_on) = CHAR(27) // '[' //'?'//'1'//'h' = code(Cursor_Key_off) = CHAR(27) // '[' //'?'//'1'//'l' ) code(Numeric_Pad) = CHAR(27) // '>'O- code(Application_Pad) = CHAR(27) // '='( code(B 'XɍC STRATEGO HHC Copyright (c) 1984. No copies of this text may be distributed without@C written permission of the author or Hughes SCG/PWB department.CCIC Permission is hereby granted to distribute executable images throughout GC the DECUS community and Hughes Aircraft. Source modules are released GC to DECUS members and Hughes Aircraft employees only. This software isNBC subject to change without notice. Neither the author nor HughesBC Aircraft Co. assumes any lia(bilities for the performance of this C softwareC%C Author: Gordon Howell @C Hughes Aircraft Space and CommunicationsC PO Box 92919C Bldg S50/X342i'C Los Angeles, CAm$C 213-419-0254Cs=C--KEYQIO A package of subroutines for use in STRATEGO to doN!C----keyboard IO using QIO calls.,C Also includes various condition handlers.EC Also includes event flag services, various ASTs and timer services(Cs C )INCLUDED:AC GetChar -- Integer Function gets the ascii value of a single h7C input character, flag parameter clears error regiono3C Tinput -- The "meat" of GetChar, BYTE functionm1C Enable_Band_AST -- enables all out-of-band ASTsm&C Enable_CTRLC -- enables ^C trapping&C Enable_CTRLY -- enables ^Y trapping/C Keyboard_AST -- handles all out-of-band ASTstC CTRLC_Rout -- handles ^C ASTC CTRLY_Rout -- handles ^Y ASTi%C Enable_Exit -- declare exit handleriC Abort_Rout -- exit ha *ndleri%C Cancel_Exit -- cancels exit handlera3C Cancel_Type_Ahead -- purges the type-ahead buffer =C Cancel_Read(Chan) -- cancels all read requests on a channel BC Wait_for(EF) -- waits for the specified EF/ queues timer request+C Set_EF(EF) -- sets a specified event flag/C Clear_EF(EF) -- clears a specified event flaglDC Read_EF(EF,State) -- reads an event flag cluster and returns state1C Set_Timer(ID,Seconds) -- queues a timer requestS?C Cancel_Timer(ID) -- cancels a timer request (SET_TIM +ER entry) (C Timer_AST -- handles a timer interrupt:C Read_mail_Wait(Chan,Txt) -- sits in read-wait on mailbox9C Read_Mail -- AST routine to handle write-attention maillAC Put_Mail(Chan,Txt) -- writes a message to the specified mailboxtCC Set_Mail_Attention -- places a write attention on process mailboxoCy3C The ^Y handler is not currently used in STRATEGO Cr@C TINPUT --- A function returning the integer value of a singleKC keyboard input character. The routine will wait for a keystroke. CC It assumes $ASSIGN has been made to a device on channel IOChan. C BYTE FUNCTION Tinput# INCLUDE 'STRATEGO.INC/NOLIST'  INCLUDE '($IODEF)' INCLUDE '($SSDEF)'3 INTEGER InFunc, InChar, Inpterm(2), IOSB_addr  INTEGER*2 IOSB(4)o IOSB_addr = %LOC(IOSB(1)) & Inpterm(1) = 0 !no terminators Inpterm(2) = 0: InFunc = IO$_READVBLK + IO$M_NOECHO + IO$M_TRMNOECHO ++ IO$M_NOFILTRE1 status = SYS$QIOW(,%VAL(TermChan), -rmission of the author or Hughes SCG/PWB department.C IC Permission is hereby granted to distribute executable images throughoutiGC the DECUS community and Hughes Aircraft. Source modules are releasedyGC to DECUS members and Hughes Aircraft employees only. This software istBC subject to change without notice. Neither the author nor HughesBC Aircraft Co. assumes any liabilities for the performance of this C softwareCh%C Author: Gordon Howellh@C Hughes A.ircraft Space and CommunicationsC PO Box 92919C Bldg S50/X342 'C Los Angeles, CA $C 213-419-0254Ct;C LinkUp --- Subroutine to synchronize players initially.  SUBROUTINE LinkUp # INCLUDE 'Stratego.INC/NOLIST' INTEGER*4 State, InChare CHARACTER*80 LinedC--See who is firsti If (First_player) Then6 Call OUTPUT(0,'Looking for your opponent...')3 Call Wait_For(Gbl_EF1) !waiting...waiting / Name1 = MyName- Call Set_EF(Gbl_EF)7 Call Wait_For(Gbl_EF1) !wait for other's namee HisName = Name2 Else; Call OUTPUT(0,'Your opponent is waiting for you.')e; Call Set_EF(Gbl_EF1) !tell other process I'm herer6 IF (.NOT. Status) Call LIB$STOP(%VAL(Status))9 Call Wait_For(Gbl_EF) !wait until he gves nameh Name2 = MyNameo HisName = Name1: CAll Set_EF(Gbl_EF1) !tell other process my name5 IF (.NOT.Status) Call LIB$STOP(%VAL(Status))c End IfI CALL Output(0,'Your opponent''s name is: '//HisName) !print messageu RETURN ENDfww the specified EF/ queues timer request+C Set_EF(EF) -- sets a specified event flag/C Clear_EF(EF) -- clears a specified event flaglDC Read_EF(EF,State) -- reads an event flag cluster and returns state1C Set_Timer(ID,Seconds) -- queues a timer requestS?C Cancel_Timer(ID) -- cancels a timer request (SET_TIM 1@ɍC STRATEGO tHC Copyright (c) 1984. No copies of this text may be distributed without@C written permission of the author or Hughes SCG/PWB department.CaIC Permission is hereby granted to distribute executable images throughoutnGC the DECUS community and Hughes Aircraft. Source modules are releasedeGC to DECUS members and Hughes Aircraft employees only. This software isrBC subject to change without notice. Neither the author nor HughesBC Aircraft Co. assumes any lia2bilities for the performance of this C softwareCt%C Author: Gordon Howell @C Hughes Aircraft Space and CommunicationsC PO Box 92919C Bldg S50/X342('C Los Angeles, CAn$C 213-419-0254CBAC MAIL --- routine to send messages to either player; via MailboxoC if neccessary. Ct! SUBROUTINE Mail(who,msg_no)V# INCLUDE 'Stratego.INC/NOLIST'  INTEGER who, Msg_not CHARACTER*80 txt 3 IF (Msg_no) 100,300,200u.C Come here to prompt for mail message or note100 Continue+ If (Who .EQ. Me) THEN !make a note  Txt = '*** Note ***'r Call OUTPUT(12,Txt) ELSE !send a messagee Txt = 'Send> '. Call Output(-6,txt) Txt = '>'//txt # Call PUT_MAIL(HisChan,txt)c End IF GOTO 1000sCr1C Come here to get message from the message array <200 If (Msg_No.GT.Null_Message .OR. Msg_No.LT.1) goto 5000  Msg = Message(Msg_No)oC/C ..or else get message from message buffer msg *300 IF (Who .NE. Him) Call Output(0,Msg)1 IF (WHO .NE. Me) Call PUT_MAIL(HisChan,Msg)n 1000 RETURN,5000 Msg = '****Error reading message file' goto 300 END.wwIST' INTEGER*4 State, InChare CHARACTER*80 LinedC--See who is firsti If (First_player) Then6 Call OUTPUT(0,'Looking for your opponent...')3 Call Wait_For(Gbl_EF1) !waiting...waiting 6tɍC STRATEGO CHC Copyright (c) 1984. No copies of this text may be distributed without@C written permission of the author or Hughes SCG/PWB department.CrIC Permission is hereby granted to distribute executable images throughoutrGC the DECUS community and Hughes Aircraft. Source modules are released)GC to DECUS members and Hughes Aircraft employees only. This software ismBC subject to change without notice. Neither the author nor HughesBC Aircraft Co. assumes any lia6C--Load message array. OPEN (Unit=MesFil,Name='STRATEGO_TEXT:',# +READONLY,SHARED,STATUS='OLD') Do i = 1,Null_Message, Read(MesFil,101,END=999) Message(i)101 FORMAT(A) End Do999 CLOSE(MesFil) RETURN ENDwwķ@CMC ********************** PRELIMINARY VERSION *******************************GC Copyright pending. No copies of this text may be distributed without@C written permission of the author or Hughes SCG/PWB d7bilities for the performance of this C softwareC)%C Author: Gordon Howell,@C Hughes Aircraft Space and CommunicationsC PO Box 92919C Bldg S50/X342h'C Los Angeles, CAe$C 213-419-0254C@C MOVE --- executes a single move, tells other player to move.+C Returns game status (TRUE if game over).sCa SUBROUTINE Move(GameFlag)e# INCLUDE 'Stratego.INC/NOLIST'I LOGICAL GameFlag< INTE8GER Row,Col, Row0,Col0 !new location, old locationG INTEGER MyValue, HisValue !the value of the piece moved and dest. 6 INTEGER Strike !A function returning the result< INTEGER L_Row,L_Col !placeholders for last turn's move SAVE L_Row,L_Col5 CALL IWait(*2000) !Wait for your turn to moverC--Update display with his moveg If (Turn .EQ. 1) ThenT SetUp_Mode = .FALSE.c Call DisplayN ElseE Call Put_Board(Old_Row,Old_Col,defaul 9t) !his piece movedmO Call Put_Board(New_Row,New_Col,Bold+Blink) !highlight his destination L Call Put_Board(l_Row,l_Col,default) !unhighlight his last turn L_Row = New_Row L_Col = New_Col Call Put_Turn End If= If (Piece_Lost .NE. 0) Call Put_Prison(ABS(Piece_Lost))i Piece_Lost = 0C--Execute move L1 CALL GetPiece(Row0,Col0,*1000) !Pick a piece to move (*if cannot move)H CALL MovePiece(Row0,Col0,Row,Col,*1) !p :ick a destination (*abort)C Now update board o3 MyValue = Board(Row0,Col0) !The piece I movedf4 HisValue= Board(Row,Col) !the place I moved to< Board(Row0,Col0)=Empty !the old location is now emptyF Board(Row,Col) = Strike(MyValue,HisValue) !resolve any conflictsI CALL Recap(MyValue,HisValue,Row0,Col0,Row,Col) !inform both players 0 Old_Row = Row0 !set the shared variables Old_Col = Col0 New_Row = Rowo New_Col = Col ; IF (ABS(HisValue) .EQ. Flag) GOTO 900 !check for win. GameOver=.FALSE.I If (First_Turn .NE. Me) Turn = Turn + 1 !SECOND player updates turn( GameFlag = GameOverH- RETURN !normal successful completionE3C Come here if I win the game cause I got his flag.900 GameOver=.TRUE.U- CALL Mail(Me, IWin) !congratulate self / CALL Mail(Him,YouLose) !chastise opponentI Call Set_EF(Abort_EF)S Call Set_EF(His_Wait_Flag) GameFlag = GameOverl RETURN8C <HܛɍC STRATEGO HC Copyright (c) 1984. No copies of this text may be distributed without@C written permission of the author or Hughes SCG/PWB department.CIC Permission is hereby granted to distribute executable images throughout!GC the DECUS community and Hughes Aircraft. Source modules are releasedEGC to DECUS members and Hughes Aircraft employees only. This software isnBC subject to change without notice. Neither the author nor HughesBC Aircraft Co. assumes any lia=bilities for the performance of this C softwareC %C Author: Gordon Howelle@C Hughes Aircraft Space and CommunicationsC PO Box 92919C Bldg S50/X342n'C Los Angeles, CAl$C 213-419-0254CtMC MovePiece --- Get a destination square for a piece moved; make sure its OKg!C Yes, Virginia, there is a GoTo!o2 SUBROUTINE MovePiece (fromR, fromC, R, C, *)# INCLUDE 'Stratego.INC/NOLIST'a7 INTEGER >Row, Col, fromR, fromC, R, C, Step, Piece 7 LOGICAL*2 RowMove,ColMove !used for Scout movesh@1 CALL Mail(Me, Pick_Dest) !tell hime to pick a destination8 RowMove=.FALSE. !initialize some variables to.., ColMove=.FALSE. !..where I want 'em Step=1 Piece = 1o:2 CALL Point(Row, Col, Piece, *71) !Get a destinationOC--Now check to see if the destination is an adjacent space (or legal if Scout); IF ((ABS(Row-fromR) .EQ. 1 .AND. Col .EQ. fromC) . ?OR. B +(ABS(Col-fromC) .EQ. 1 .AND. Row.EQ.fromR)) GOTO 10 !it's OKK IF (Board(fromR,fromC)*Me .EQ. Scout) GOTO 50 !check the Scout's movel5C--here if the destination is geographically illegal w> CALL S_Error(Curr_Col,Curr_Row,message(Non_Adj),default) GOTO 1DC--Now check to see if destination OK (illegal is move to own piece)+10 IF (Board(Row,Col)*Me .GT. Flag .OR. (5 +Board(Row,Col)*Me.LT.Marshal) GOTO 100 !it's OK)@ CALL S_Error(Curr_Col,Curr_Row,Message(Own_Piece),default) GOTO 11C--Come here if a request for a abort is possible! 71 If (Piece .NE. Spy) Goto 2 RETURN 1-C--Come here if it's a scout that's moving...pFC----first check to see if he's trying to move along a row or a column;50 IF ((Row.EQ.fromR).AND.(Col.NE.fromC)) ColMove=.TRUE.H; IF ((Row.NE.fromR).AND.(Col.EQ.fromC)) RowMove=.TRUE.o% IF (ColMove.OR.RowMove) GOTO 60 @ CALL S_Error(Curr_Row,Curr_Col,message(Ill_Scout),default) GOTO 10 AɍC STRATEGO HC Copyright (c) 1984. No copies of this text may be distributed without@C written permission of the author or Hughes SCG/PWB department.CfIC Permission is hereby granted to distribute executable images throughout0GC the DECUS community and Hughes Aircraft. Source modules are released GC to DECUS members and Hughes Aircraft employees only. This software isHBC subject to change without notice. Neither the author nor HughesBC Aircraft Co. assumes any liaBbilities for the performance of this C softwareCa%C Author: Gordon Howell @C Hughes Aircraft Space and CommunicationsC PO Box 92919C Bldg S50/X3420'C Los Angeles, CA-$C 213-419-0254C0EC OutPut --- routine to handle textual output in scrolled regioneCsEC The first parameter controls prompted input. If zero, no input(EC is requested. If non-zero, the absolute value is the length ofN@C C the prompt string. If positive, the input is saved in theEC output buffer rather than the prompt string. If negative, boths#C prompt and response are savedC Co! SUBROUTINE OutPut (key,Txt)a# INCLUDE 'Stratego.INC/NOLIST'! CHARACTER*(*) Txt  CHARACTER*80 Line INTEGER Length, Out_Chars @ INTEGER key !request-for-response flagJ If (Scrolled) Call Scroll_Output(0) !set the scrolling windowM Curr_Line = MO DD(Curr_Line,Max_Lines) + 1 !put pointer at current lineO8 If (Curr_Line .EQ. Max_Lines) Buffer_Full = .TRUE.? Text_Line(Curr_Line) = Txt !update buffer 6 Window_Size = MIN(Window_Size + 1,Scroll_Length), Ptr_Line = Curr_Line - Window_Size + 1: If (Ptr_Line .LE. 0) Ptr_Line = Ptr_Line + Max_lines; call LIB$SET_CURSOR(Start_scroll + Window_Size - 1,1)+> If (Window_Size .EQ. Scroll_Length) CALL LIB$UP_SCROLL()< If (key .NE. 0) Then !E !process input request Out_Chars = ABS(Key) ' Call Cancel_Type_Ahead(IOChan) 9 Call LIB$GET_SCREEN(Line,Txt(:Out_Chars),Length)s Call LIB$DOWN_SCROLL()t> Text_Line(Curr_Line) = txt(:Out_Chars)//Line(:Length) txt = Line(:Length) Else$ Call LIB$PUT_SCREEN(Txt,,,) End IF, call LIB$SET_CURSOR(Curr_Row,Curr_Col) return end ) SUBROUTINE Scroll_Output(DirectiFon)-# INCLUDE 'Stratego.INC/NOLIST'e( INTEGER Direction, Line, Length, j If (Direction) 1,10,2 C --Here if look backw1 Continue Old_Ptr = Ptr_Line Ptr_Line = Ptr_Line - 1I/ If (Ptr_Line .EQ. 0) Ptr_Line = Max_LinesL#C ----Check boundary conditionsa( If ((Ptr_Line .EQ. Curr_Line) .OR.? +((Ptr_Line .EQ. Max_Lines) .AND. .NOT. Buffer_Full)) Thenr Ptr_Line = Old_PtroA Call S_Error(Curr_Row,Curr_Col,'End of scrolling buffer'r + ,Default) RETURNo End IfC ----Now do some work!E)17 Call LIB$SET_CURSOR(Start_Scroll,1)u Call LIB$DOWN_SCROLL()> Call LIB$PUT_SCREEN(Text_Line(Ptr_Line),Start_scroll,1,), Call LIB$SET_CURSOR(Curr_Row,Curr_Col) Scrolled = .TRUE.a RETURNC --Here if look-ahead2 Continue#C ----Check boundary conditions * Old_Ptr = Ptr_Line + Window_Size - 1? If (Old_Ptr .GT. Max_Lines) Old_Ptr = Old_Ptr - Max_LiH Subroutine Enable_CTRLY2C--Subroutine to enable trapping and routing of ^YC# INCLUDE 'STRATEGO.INC/NOLIST' INCLUDE '($IODEF)' INTEGER IoFunc EXTERNAL CTRLY_Rout- IoFunc = IO$_SETMODE .OR. IO$M_CTRLYASTE Status =SYS$QIOW(,%VAL(IoChan),%VAL(IoFunc),,,,CTRLY_Rout,,,,,)3 IF (.NOT. Status) Call LIB$STOP(%VAL(Status)) RETURN END+ Subroutine Cancel_Type_Ahead(Channel))C--routine to I=ɍC STRATEGO HC Copyright (c) 1984. No copies of this text may be distributed without@C written permission of the author or Hughes SCG/PWB department.C IC Permission is hereby granted to distribute executable images throughoutaGC the DECUS community and Hughes Aircraft. Source modules are releasedGGC to DECUS members and Hughes Aircraft employees only. This software is BC subject to change without notice. Neither the author nor HughesBC Aircraft Co. assumes any liaJbilities for the performance of this C softwareC %C Author: Gordon Howelle@C Hughes Aircraft Space and CommunicationsC PO Box 92919C Bldg S50/X342n'C Los Angeles, CAl$C 213-419-0254CtFC Point --- routine to get a row and a column input from the player.- SUBROUTINE Point (Row,Col,Terminator,*) # INCLUDE 'Stratego.INC/NOLIST'r2 INTEGER Row,Col,char_val,Prev_row,Prev_col,i' INTEGEKR Get_Char !Function belows: LOGICAL Piece_Set !true if a proper terminator seen CHARACTER*1 Place H INTEGER Terminator !non-zero if terminators other than ok PARAMETER (Return = 13,  +Question = 63, +Escape = 27, +R_Bracket = 91,  +Uppercase_A = 65,  +Quit = 81) Piece_Set = .FALSE.  Row = Curr_Row Col = Curr_Col"99 CALL LIB$SET_CURSOR(Row,Col)$ char_val = Get_Char(Error_Set)@ If (Char_Val .eq. LQuestion) GOTO 666 !Look for help pleaF If (Char_Val .eq. Return) GOTO 333 !Look for terminatorJ if (char_val .eq. Escape) goto 72 !Look for start of seq.L If (Terminator .eq. 0) goto 40 !skip next part if only want 'C--Look for proper terminator characterE4 If (Char_Val .le. 122 .AND. Char_Val .ge. 97) 5 +Char_Val = Char_Val - 32 !convert to uppercasef Place = CHAR(Char_Val) Do i = Marshal,Flag ' If (Place .EQ. SyMmbol(i)) Thene Terminator = i Piece_Set = .TRUE.) goto 333 !a proper terminatorl End IfL End Do& Goto 40 !Improper terminator C--Come here on sequence$72 char_val = Get_Char(Error_Set)* if (char_val .NE. R_Bracket) goto 40$ char_val = Get_Char(Error_Set)( index = char_val - Uppercase_A + 1 GOTO (65,66,67,68) Index740 call S_Error(Row,Col,'Illegal character',Default)E goto 99D!65 N IF (Row .LE. Row_0) goto 99. Row = Row - 1 goto 99,%66 IF (Row .GE. Last_Row) goto 99) Row = Row + 1e goto 99m$67 IF (Col .GE. Last_Col) goto 99 Col = Col + 2= goto 99!68 IF (Col .LE. Col_0) goto 99  Col = Col - 2- Goto 99yC--Come here on 333 Continue! Prev_row = Curr_Row - Row_0Q. Prev_col = INT(0.5 * (Curr_Col - Col_0))C----Update current position Curr_Row = Row Curr_Col = Col?C----ModOify Row & Col to reflect the board numbering conventionn Row = Row - Row_0m$ Col = INT(0.5 * (Col - Col_0)) C----Go Home If (Piece_Set) RETURN 1 RETURNC--Come here on plea for HELP!666 Continue Call OUTPUT(0,< +'Move the cursor over the board using the arrow keys') If (SetUP_Mode) Then Call OUTPUT(0, ? + 'Place a piece by typing the symbol for that piece '//_% + '(1,2,3,4,5,6,7,8,9,S,F,@)')n Call OUTPUT(0,aG + 'Remove a piece by hitting the key over that piece') Else Call OUTPUT(0,dG + 'Select a piece to move or a destination square by hitting '//f + 'the key') Call OUTPUT(0,eD + 'Cancel a piece previously selected to move by typing "S"') End If Goto 99_ End_ww1,1)  Call LIB$UP_SCROLL()1 Call LIB$PUT_SCREEN(Text_Line(New_Line),,,)t, Call LIB$SET_CURSOR(Curr_Row,Curr_Col) Scrolled =pORDON MOVEPIECE  K GORDON OUTPUT" K GORDON POINT2K GORDON RECAP`K GORDON SETUP!`'K GORDON STRATEGO=K GORDON STRIKE Q<K GORDON WELCOMEKQ"ތ GORDON CANMOVECLOSEUPCOMLINKDISPLAYERROR FIRSTMOVEGETPIECEHELPINITIWAITKEYQIOLINKUPMAILMOVE MOVEPIECEOUTPUTPOINTRECAPSETUPSTRATEGOSTRIKEWELCOME Hɍ GORDON CANMOVECLOSEUPCOMLINKDIS RnɍC STRATEGO HC Copyright (c) 1984. No copies of this text may be distributed without@C written permission of the author or Hughes SCG/PWB department.C IC Permission is hereby granted to distribute executable images throughout GC the DECUS community and Hughes Aircraft. Source modules are released GC to DECUS members and Hughes Aircraft employees only. This software iseBC subject to change without notice. Neither the author nor HughesBC Aircraft Co. assumes any liaSbilities for the performance of this C softwareCD%C Author: Gordon Howell @C Hughes Aircraft Space and CommunicationsC PO Box 92919C Bldg S50/X342w'C Los Angeles, CAi$C 213-419-0254CHC RECAP --- routine to tell players what has just happened in the gameC : SUBROUTINE Recap(MyValue,HisValue,Row0,Col0,Row,Col)# INCLUDE 'Stratego.INC/NOLIST' 1 CHARACTER*1 InitRow,InitCol,DestRow,DestCoTl  INTEGER MyValue, HisValue  INTEGER Row,Col,Row0,Col0p InitRow = CHAR(Row0+48)E InitCol = CHAR(Col0+48)n DestRow = CHAR(Row+48) DestCol = CHAR(Col+48)C Now get destination right+# IF (HisValue .EQ. Empty) THEN  CALL Mail(Me, OKMove)( ELSE IF (HisValue.EQ.Impasse) THEN CALL Mail(Me,Suicide) Piece_Lost = MyValuel ELSE L CALL Mail(Me,IStrike)- IF (HisValue.EQ.Board(Row,Col)) THENV- U If (ABS(HisValue) .EQ. Bomb) Thena Call S_Error(< + Curr_row,Curr_Col,'KA-BLOOEEY!!!',Bold+Blink)9 msg = 'An opposing '//NAME(ABS(MyValue))// 6 + ' has blundered into one of your bombs' Call Mail(Him,0) : Call OUTPUT(0,'Your '//Name(ABS(MyValue))//= + ' has been splattered by a bomb. Nice going.')t Else1 CALL Mail(Him,YouCap+ABS(MyValue))a1 CALL Mail(Me, VYouLost+ABS(MyValue))  End If9 If (ABS(MyValue) .EQ. Scout .OR. ABS(MyValue)r$ + .EQ. Spy) Call OUTPUT(0,9 + 'The Scout reports a '//Name(IABS(HisValue))) Piece_Lost = MyValue1 ELSE IF (MyValue.EQ.Board(Row,Col)) THENr Piece_Lost = 00 CALL Mail(Him,YouLost+ABS(HisValue))* Msg = 'The Scout reports a '// + Name(IABS(MyValue))E/ If (IABS(HisValue) .EQ. Scout .OR. 5 + IABS(HisValue) .EQ. Spy) Call Mail(Him,0) . CALL Mail(Me,YouCap+ABS(HisValue))% Call Put_Prison(HisValue)e ELSE Piece_Lost = MyValue2 CALL Mail(Both,BothLost+ABS(HisValue))% Call Put_Prison(HisValue)  ENDIF ENDIF-' Call Put_Board(Row0,Col0,default) % call Put_Board(Row,Col,default)v= Call LIB$SET_CURSOR(1,1) !put cursor in "holding area"i RETURN ENDwww Curr_Col = Col?C----Mod XqɍC STRATEGO mHC Copyright (c) 1984. No copies of this text may be distributed without@C written permission of the author or Hughes SCG/PWB department.CNIC Permission is hereby granted to distribute executable images throughout GC the DECUS community and Hughes Aircraft. Source modules are releasedUGC to DECUS members and Hughes Aircraft employees only. This software is BC subject to change without notice. Neither the author nor HughesBC Aircraft Co. assumes any liaYbilities for the performance of this C softwareCo%C Author: Gordon Howell @C Hughes Aircraft Space and CommunicationsC PO Box 92919C Bldg S50/X342h'C Los Angeles, CAe$C 213-419-0254CeBC SETUP --- routine to handle the initial set-up for each playerC  SUBROUTINE SetUp# INCLUDE 'Stratego.INC/NOLIST'(- INTEGER Row, Col, Col_No, Row_No, IndexR INTEGER Pieces_Left  CHZARACTER Line*19, Txt*50 $ LOGICAL Check_Prison, Flag_Set Flag_Set = .FALSE.C--Put the board on the screen5 Call OUTPUT(0,'Deploy your army on the field!').C--Set some base pointse' His_Base_Row = INT((1-Him)*9/2.0)s$ My_Base_Row = 9 - His_Base_Row Curr_Col = Col_0$ Curr_Row = My_Base_Row + Row_0C---Now perform the setup! Pieces_Left = Max_Pieces# Do While (Pieces_Left .GT. 0) 77 Continue  Piece = 1& Call POINT( [Row,Col,Piece,*88)<1 If (Row .GT. MAX(My_Base_Row,My_Base_Row+3*Me) .OR.< + Row .LT. MIN(My_Base_Row,My_Base_Row+3*Me)) goto 79, If (Board(Row,Col) .NE. Empty) Then0 Call Put_Prison(ABS(Board(Row,Col)))A If (ABS(Board(Row,Col)) .EQ. Flag) Flag_set = .FALSE.o" Board(Row,Col) = Empty+ Call Put_Board(Row,Col,default)l) Pieces_Left = Pieces_Left + 1D End IfO GoTo 9979 Continuet( Call S_ \Error(My_Base_Row,Col_0,, + 'You may not set up here!',Default) goto 77 A83 Call S_Error(Row,Col,'Your Flag is already set',default)R Goto 7791 Call S_Error(Row,Col,H +'You must first remove the piece already here (Use )',default) goto 7788 Continuea< If (Row .GT. MAX(My_Base_Row,My_Base_Row+3*Me) .OR.< + Row .LT. MIN(My_Base_Row,My_Base_Row+3*Me)) goto 79/ If (Board(Row,Col) .NE. Empty) goto 91T6 I ]f ((Piece .eq. Flag) .AND. Flag_Set) goto 83F If ((Piece .eq. Flag) .AND. .NOT. Flag_set) Flag_Set = .TRUE.> If ((Piece .EQ. Flag) .OR. Check_Prison(Piece)) Then5 Call Output(0,'Piece is a '//Name(Piece))f$ Call Clear_Prison(Piece)% Board(Row,Col) = me*Piece'+ Call Put_Board(Row,Col,default)') Pieces_Left = Pieces_Left - 1' Else : txt = 'You have already deployed your last '// + Name(Piece),. Call S_Error (Row,Col,txt,Default) End If a99 Continue. End Do4C--Finally, re-draw the screen with up-to date info! Call Output(0,; +'Please hit to continue, or "S" to alter setup')  Piece = 1u" Call Point(Row,Col,Piece,*1) return end wwALL Mail(Him,YouLost+ABS(HisValue))* Msg = 'The Scout reports a '// + Name(IABS(MyValue))C/ If (IABS(HisValue) .EQ. Scout .OR. 5 + _`ŜɍC STRATEGO mHC Copyright (c) 1984. No copies of this text may be distributed without@C written permission of the author or Hughes SCG/PWB department.CIC Permission is hereby granted to distribute executable images throughoutiGC the DECUS community and Hughes Aircraft. Source modules are releasedoGC to DECUS members and Hughes Aircraft employees only. This software isCBC subject to change without notice. Neither the author nor HughesBC Aircraft Co. assumes any lia`bilities for the performance of this C softwareC %C Author: Gordon Howelle@C Hughes Aircraft Space and CommunicationsC PO Box 92919C Bldg S50/X342n'C Los Angeles, CAl$C 213-419-0254CtKC STRATEGO.FOR ------- Plays a two-player, two-terminal game of StrategoHCe3C This beast needs the following files to execute:c?C STRATEGO.COM -- executes program and defines proper log namesc$C (you should custom aize this file)"C STRATEGO.EXE -- executable image'C STRATEGO.TXT -- screen template filesoC STRATEGO.DAT -- message fileC STRATEGO.HLP -- help filet+C STRATEGO.QCK -- quick reference help file +C to build this thing, you will also need: BC STRATEGO.DOC -- instructions for building game and notes on game,C STRATEGO.TLB -- source module text library#C STRATEGO.OPT -- link options fileS;C STRATEGO.INC -- include module describing data structures AC DESCRIP.MMS -- MMS description file. Thisb file also has a list5C of source modules required.lCSC Revision History:1C 12/16/83 Version 1.0 **PRELIMINARY** G.Howelll>C 12/23/83 version 1.1 added "wait" feature, fixed SPAWN bugs.C added quick-reference HELP G.HowellC C %C Future improvements will include: uC - expanded messagesuC - save game facility=C - system-wide playability (current version is restricted tos#C processes in the same UIC Group))C7EC To execute the game, both processes (must be in same cgroup) enter:,C $ @STRATEGOCR PROGRAM Stratego LOGICAL GameOverA GameOver=.FALSE. !controls main program flow L CALL ComLink !establish interprocess communicationsE CALL SetUp !set-up initial board positionsL7 CALL First_move !Synchronize gamelOC ******************Game loop starts here**************************************E@1 CALL Move(GameOver) !processes a pair of movesM IF (.NOT. GameOver) GOTO 1 !determine if game is still in progresstOC ******************End of game loop******************************************* H CALL CloseUp !shutdown everything, close files.D Call Cancel_Exit !Finally, cancel exit handlers END ww If (Row .GT. MAX(My_Base_Row,My_Base_Row+3*Me) .OR.< + Row .LT. MIN(My_Base_Row,My_Base_Row+3*Me)) goto 79/ If (Board(Row,Col) .NE. Empty) goto 91e6 I e`]ꜮɍC STRATEGO gHC Copyright (c) 1984. No copies of this text may be distributed without@C written permission of the author or Hughes SCG/PWB department.CIC Permission is hereby granted to distribute executable images throughouteGC the DECUS community and Hughes Aircraft. Source modules are releasedlGC to DECUS members and Hughes Aircraft employees only. This software isBC subject to change without notice. Neither the author nor HughesBC Aircraft Co. assumes any liafbilities for the performance of this C softwareC %C Author: Gordon Howell @C Hughes Aircraft Space and CommunicationsC PO Box 92919C Bldg S50/X342 'C Los Angeles, CAu$C 213-419-0254CR@C STRIKE ---- INTEGER function to resolve moves. The function<C takes the value of the piece moved and compares it to the BC value of the destination. The return value is the "victorious"C value.0 INTEGER FUgNCTION Strike(Attacker,Defender)# INCLUDE 'Stratego.INC/NOLIST'i# INTEGER Attacker,Defender,A,Do A = ABS(Attacker)  D = ABS(Defender)PC Check general cases firsti IF (A - D) 10,20,30tC Attacker winsm10 Strike = AttackerE GOTO 100 C Neither win.20 Strike = Empty GOTO 100C Defender winsg30 Strike = DefenderlC Now check for special caseso)100 IF (A .EQ. Miner .AND. D .EQ. Bomb)  +Strike = Attacker.+ IF (A .N E. Miner .AND. D .EQ. Bomb ) o +Strike = Defender * IF (A .EQ. Spy .AND. D .EQ. Marshal) +Strike = AttackerA) IF (D .EQ. Empty) Strike = Attackerx+ If (D .EQ. Impasse) Strike = Defender RETURN END ww 213-419-0254C KC STRATEGO.FOR ------- Plays a two-player, two-terminal game of StrategoPCB3C This beast needs the following files to execute:)?C STRATEGO.COM -- executes program and defines proper log namesi$C (you should custom i`ɍC STRATEGO cHC Copyright (c) 1984. No copies of this text may be distributed without@C written permission of the author or Hughes SCG/PWB department.CeIC Permission is hereby granted to distribute executable images throughoutOGC the DECUS community and Hughes Aircraft. Source modules are released-GC to DECUS members and Hughes Aircraft employees only. This software isABC subject to change without notice. Neither the author nor HughesBC Aircraft Co. assumes any liajbilities for the performance of this C softwareCr%C Author: Gordon Howell/@C Hughes Aircraft Space and CommunicationsC PO Box 92919C Bldg S50/X342u'C Los Angeles, CA $C 213-419-0254CwC WELCOME.FOR >C A package of subroutines to perform STRATEGO initialization. C all are called from COMLINK. 'C Consists of the following routines:GDC Associate_EF -- associates event flag cluster and creates uniq kue C event flags for each process9C Signal -- LOGICAL function returns TRUE if process ise3C the first one to play. Sets proper event flagso7C Assign_Terminal -- Assigns the terminal an IO channelrCC Build_Names -- creates unique names for section/mailbox/cluster 2C Map_Data -- maps shared data to global section7C Create_Mailbox -- creates mailboxes for each processeCC Check_Help -- prompts user for HELP and gives it if he wants itM9C Welcome -- say's "hello" to player and finlds his name /C Welcome --- routine to say hello to player i SUBROUTINE Welcome! INCLUDE 'Stratego.INC/LIST'* CHARACTER*80 TxtC--now, setup the screen areae Call Display* Call OUTPUT(0,'Welcome to STRATEGO'). Call OUTPUT(0,'CTRL/A or "?" for help.')B Txt = 'Please state your name, pseudonym or nom de guerre: ' Call OUTPUT(-52,Txt) MyName = Txt(:15)s* Call OUTPUT(0,'Thank-you, '//MyName) RETURN END mMC Routine to create unique event flags for processes and associate the commontC--event flag cluster. Subroutine Associate_EF # INCLUDE 'Stratego.inc/nolist'n*C--Create the temporary event flag cluster6 Status = SYS$ASCEFC(%VAL(Wait_EF), EF_Cluster,,)3 IF (.NOT. Status) Call LIB$STOP(%VAL(Status))IC--Allocate wait flags! My_Wait_Flag = Wait_EF + Me # His_Wait_Flag = Wait_EF + Himh RETURN ENDt GC--Logical function ton determine if there is a player out there waiting LOGICAL FUNCTION Signald# INCLUDE 'Stratego.inc/nolist'u INTEGER Staten CHARACTER*12 Gbl_Cluster Gbl_Cluster = 'strategoEF'%C--Allocate global event flag cluster 6 Status = SYS$ASCEFC(%VAL(Gbl_EF), Gbl_Cluster,,)2 IF (.NOT.Status) Call LIB$STOP(%VAL(Status))OC--Read global event flag to see if anyone out there is looking for an opponenth Call Read_EF(Gbl_EF,State), IF ((State .AND. Gblo_Msk) .EQ. 0) Then,C---Let future process know I was here first Signal = .TRUE. Call Set_EF(Gbl_EF) Else5C---I'm second, but don't let other processes in too!  Signal = .FALSE.,A Call Clear_EF(Gbl_EF) !make sure I don't read own flag0 End Ifi RETURN END *C--Assign a channel to the terminal device) Subroutine Assign_Terminal(Chan_No) ) INTEGER Chan_No, Status, SYS$ASSIGN 0 Status = SYS$ASSIGN('SYS$INPUT',Chan_No,,)3 if (.NOT. Status) Call LIB$STOP(%VAL(Status)) RETURN END 7C Generates unique cluster, section, and mailbox namest<C Seed-name is passed to other process via a common mailbox Subroutine Build_Names# INCLUDE 'Stratego.inc/nolist'A CHARACTER*12 Global_Boxl& CHARACTER Doof*16,Random_Name*10 INTEGER Seed(2)T! Global_Box = 'STRATEGO_BOX' C--Create the mailbox 3 Status = SYS$CREMBX(,MailChan,,,,,Global_Box)aPLAYERROR FIRSTMOVEGETPIECEHELPINITIWAITKEYQIOLINKUPMAILMOVE MOVEPIECEOUTPUTPOINTRECAPSETUPSTRATEGOSTRIKEWELCOMErbilities for the performance of this C softwareC%C Author: Gordon Howelln@C Hughes Aircraft Space and CommunicationsC PO Box 92919C Bldg S50/X342f'C Los Angeles, CAs$C 213-419-0254CfC WELCOME.FOR a>C A package of subroutines to perform STRATEGO initialization. C all are called from COMLINK. 'C Consists of the following routines:rDC Associate_EF -- associates event flag cluster and creates uniqsue C event flags for each process9C Signal -- LOGICAL function returns TRUE if process isV3C the first one to play. Sets proper event flagsr7C Assign_Terminal -- Assigns the terminal an IO channel CC Build_Names -- creates unique names for section/mailbox/clusters2C Map_Data -- maps shared data to global section7C Create_Mailbox -- creates mailboxes for each processnCC Check_Help -- prompts user for HELP and gives it if he wants itx9C Welcome -- say's "hello" to player and finuds his namer/C Welcome --- routine to say hello to player  SUBROUTINE Welcome! INCLUDE 'Stratego.INC/LIST'n CHARACTER*80 TxtC--now, setup the screen area  Call Display* Call OUTPUT(0,'Welcome to STRATEGO'). Call OUTPUT(0,'CTRL/A or "?" for help.')B Txt = 'Please state your name, pseudonym or nom de guerre: ' Call OUTPUT(-52,Txt) MyName = Txt(:15)** Call OUTPUT(0,'Thank-you, '//MyName) RETURN ENDsuMC Routine to create unique event flags for processes and associate the commonsC--event flag cluster. Subroutine Associate_EF*# INCLUDE 'Stratego.inc/nolist' *C--Create the temporary event flag cluster6 Status = SYS$ASCEFC(%VAL(Wait_EF), EF_Cluster,,)3 IF (.NOT. Status) Call LIB$STOP(%VAL(Status))*C--Allocate wait flags! My_Wait_Flag = Wait_EF + Mei# His_Wait_Flag = Wait_EF + Himo RETURN ENDP GC--Logical function tov determine if there is a player out there waitingh LOGICAL FUNCTION Signalt# INCLUDE 'Stratego.inc/nolist't INTEGER State  CHARACTER*12 Gbl_Cluster Gbl_Cluster = 'strategoEF'%C--Allocate global event flag clusterr6 Status = SYS$ASCEFC(%VAL(Gbl_EF), Gbl_Cluster,,)2 IF (.NOT.Status) Call LIB$STOP(%VAL(Status))OC--Read global event flag to see if anyone out there is looking for an opponente Call Read_EF(Gbl_EF,State), IF ((State .AND. Gblw_Msk) .EQ. 0) Then,C---Let future process know I was here first Signal = .TRUE. Call Set_EF(Gbl_EF) Else5C---I'm second, but don't let other processes in too!S Signal = .FALSE. A Call Clear_EF(Gbl_EF) !make sure I don't read own flag End IfN RETURN ENDo*C--Assign a channel to the terminal device) Subroutine Assign_Terminal(Chan_No)o) INTEGER Chan_No, Status, SYS$ASSIGN 0 Status = SYS$ASSIGN('SYS$INPUT',xChan_No,,)3 if (.NOT. Status) Call LIB$STOP(%VAL(Status))O RETURN ENDa7C Generates unique cluster, section, and mailbox namesf<C Seed-name is passed to other process via a common mailbox Subroutine Build_Names# INCLUDE 'Stratego.inc/nolist't CHARACTER*12 Global_Box& CHARACTER Doof*16,Random_Name*10 INTEGER Seed(2)! Global_Box = 'STRATEGO_BOX' C--Create the mailbox 3 Status = SYS$CREMBX(,MailChan,,,,,Global_Box)N3 IF (.NOT. Status) Call LIB$STOP(%VAL(Status))e& If (.NOT. First_Player) Goto 120C--Generate a random namee Status = SYS$GETTIM(Seed)e3 IF (.NOT. Status) Call LIB$STOP(%VAL(Status))n C---put it into CHARACTER format' ENCODE(16,1,Doof) Seed(2),Seed(1) 1 FORMAT(2Z8.8) # Random_Name = 'Q'//Doof(7:15)f)C--Stuff the mailbox with the random nameh) Call PUT_MAIL(MailChan,Random_Name)  Goto 130GC--Here to discover what's the random name (gene z`ИɍC STRATEGO 'HC Copyright (c) 1984. No copies of this text may be distributed without@C written permission of the author or Hughes SCG/PWB department.C IC Permission is hereby granted to distribute executable images throughout GC the DECUS community and Hughes Aircraft. Source modules are released GC to DECUS members and Hughes Aircraft employees only. This software iseBC subject to change without notice. Neither the author nor HughesBC Aircraft Co. assumes any lia{bilities for the performance of this C softwareCC%C Author: Gordon Howelle@C Hughes Aircraft Space and CommunicationsC PO Box 92919C Bldg S50/X342-'C Los Angeles, CA$C 213-419-0254CrGC CanMove --- logical function to test the possibility of a move froml=C any given board location. Returns TRUE if move is possible. AC A player may move anywhere except to a space containing his ownsC piece or off the| board. ) LOGICAL*2 FUNCTION CanMove(Row,Col)O# INCLUDE 'Stratego.INC/NOLIST's INTEGER Row,Col 8 CanMove = .FALSE. !assume guilty until proven... C--Look Northa" IF (Row .EQ. MaxRow) GOTO 101 IF (Board(Row+1,Col)*Me .GE. Marshal .AND. , +Board(Row+1,Col)*Me .LE. Flag) GOTO 10 CanMove = .TRUE. RETURN C--Look Southr"10 IF (Row .EQ. MinRow) GOTO 201 IF (Board(Row-1,Col)*Me .GE. Marshal .AND. , +Board(Row-1,Col)*Me .LE. Flag) GOTO 20 CanMove = .TRUE. RETURN C--Look East"20 IF (Col .EQ. MaxCol) GOTO 301 IF (Board(Row,Col+1)*Me .GE. Marshal .AND. n, +Board(Row,Col+1)*Me .LE. Flag) GOTO 30 CanMove = .TRUE. RETURN C--Look West"30 IF (Col .EQ. MinCol) GOTO 401 IF (Board(Row,Col-1)*Me .GE. Marshal .AND. m, +Board(Row,Col-1)*Me .LE. Flag) GOTO 40 CanMove = .TRUE. 40 RETURN ENDTwwyou, '//MyName) RETURN END ~MC Routine to create unique event flags for processes and associate the commonhC--event flag cluster. Subroutine Associate_EFR# INCLUDE 'Stratego.inc/nolist'o*C--Create the temporary event flag cluster6 Status = SYS$ASCEFC(%VAL(Wait_EF), EF_Cluster,,)3 IF (.NOT. Status) Call LIB$STOP(%VAL(Status))CC--Allocate wait flags! My_Wait_Flag = Wait_EF + MeC# His_Wait_Flag = Wait_EF + Him) RETURN END4 GC--Logical function to  ɍC STRATEGO hHC Copyright (c) 1984. No copies of this text may be distributed without@C written permission of the author or Hughes SCG/PWB department.C IC Permission is hereby granted to distribute executable images throughout GC the DECUS community and Hughes Aircraft. Source modules are releasedCGC to DECUS members and Hughes Aircraft employees only. This software isoBC subject to change without notice. Neither the author nor HughesBC Aircraft Co. assumes any liabilities for the performance of this C softwareCa%C Author: Gordon Howell@C Hughes Aircraft Space and CommunicationsC PO Box 92919C Bldg S50/X342 'C Los Angeles, CA_$C 213-419-0254CfNC CloseUp -- routine to shut everything down and perform normal termination. SUBROUTINE CloseUp# INCLUDE 'Stratego.INC/NOLIST' 6 Call Output (0,'Thank-you for playing STRATEGO')) CALL LIB$SET_CURSOR(End_Scroll+1,1)( Call LIB$UP_SCROLL() Return endEww ENDL7C Generates unique cluster, section, and mailbox namesa<C Seed-name is passed to other process via a common mailbox Subroutine Build_Names# INCLUDE 'Stratego.inc/nolist'l CHARACTER*12 Global_BoxL& CHARACTER Doof*16,Random_Name*10 INTEGER Seed(2)V! Global_Box = 'STRATEGO_BOX'iC--Create the mailbox 3 Status = SYS$CREMBX(,MailChan,,,,,Global_Box)  "ɍC STRATEGO OHC Copyright (c) 1984. No copies of this text may be distributed without@C written permission of the author or Hughes SCG/PWB department.CsIC Permission is hereby granted to distribute executable images throughoutOGC the DECUS community and Hughes Aircraft. Source modules are released GC to DECUS members and Hughes Aircraft employees only. This software islBC subject to change without notice. Neither the author nor HughesBC Aircraft Co. assumes any liabilities for the performance of this C softwareCl%C Author: Gordon Howell@C Hughes Aircraft Space and CommunicationsC PO Box 92919C Bldg S50/X342u'C Los Angeles, CAe$C 213-419-0254CeIC Comlink --- routine to initialize data and communications in STRATEGOr SUBROUTINE ComLink! INCLUDE 'Stratego.INC/LIST'b7 LOGICAL Signal !function to find another playerT%C--See who's out there r eady to play!EI First_Player = Signal() !function associates global clusterC4 Me = -1 !assume second> IF (First_Player) Me = 1 !nope, he's first player9 Him = -Me !identify other guy(I Call Assign_Terminal(TermChan) !Assign terminal channel for TINPUT)F Call Assign_Terminal(IoChan) !Assign terminal channel for I/OJ Call Build_Names !count games in progress/update/unique namesI Call Map_Data !Allocate the global section for BOARD datae; Call Create_Mailbox !create/map process mailboxesyL Call Associate_EF !Associate event flags and event flag clusters6 Call Enable_Band_AST !Enable out-of-band ASTs4 Call Enable_CTRLC !Enable Control-C trap5 Call Enable_exit !Set up an exit handlert= Call Init !initialize the game parametersT4 Call Welcome !Say "Hello", get nameL Call LinkUp !Identify each other and synchronize processes9 Call Check_Help !See if the scum needs helpN RETURN ENDww Continue& Call Cancel_Type_Ahead(TermChan)B Call OUTPUT(0,'Hit any character to continue, "?" for help') InChar = Tinput()Y If (InChar .NE. 63) RETURN Call HelpR Goto 23 END7ww Continue< If (Row .GT. MAX(My_Base_Row,My_Base_Row+3*Me) .OR.< + Row .LT. MIN(My_Base_Row,My_Base_Ro INTEGER R,C CHARACTER Line*19 y) CHARACTER sym*1, Doof*2, Buffer*800  CHARACTER*40 in_line c Call LIB$SET_BUFFER(Buffer,)C-- Clean the screen!&c Call set_video(Code(Reverse_Screen)) Call LIB$SET_CURSOR(1,1) Call LIB$ERASE_PAGE(1,1)'C-- Update the static screen & graphicse9 OPEN(unit=ScrnFil,name='STRATEGO_SCREEN:',READONLY,T +STATUS='OLD')u' Call SET_VIDEO(Code(Graphics_On))t Do i = 1,screen_length( READ(ScrnFil,10,END=33) in_line10 FORMAT(A40)C Call SET_VIDEO(Code(Double)) !set double-width characters ! Call LIB$SET_CURSOR(i,1)m, CALL LIB$PUT_LINE(in_line,,Reverse) End Do) Call LIB$ERASE_PAGE(Start_scroll,1) % READ(ScrnFil,10,END=33) in_linee CALL LIB$SET_CURSOR(24,1)e" Call Set_Video(Code(Double)) CALL LIB$SET_CURSOR(24,1)E+ CALL LIB$PUT_LINE(in_line,-1,Reverse)n(33 Call SET_VIDEO(Code(Graphics_Off)) CLOSE(ScrnFil) If (.NOT.SetUp_Mode) ThenNC--Update the board  DO i=MinRow, MaxRow Do j=MinCol, MaxCol  R = Row_0 + i C = Col_0 + j*2* Call Put_Board(i,j,default)C If (j.ne.MaxCol) Call LIB$PUT_SCREEN(' ',R,C+1,None)+ End Do End Doa Else=C--Highlight his area of the board (ie. dull opponent's area)T* His_Base_Row = INT((1-Him)*9/2.0)' My_Base_Row = 9 - His_Base_RowL i = 0: Do Row_No = His_Base_Row, His_Base_Row+9*Him, Him Row = Row_0 + Row_No i = i + 1o) Do Col = Col_0, Last_Col-2, 2r0 Col_No = INT(0.5 * (Col - Col_0))* Index_1 = 1 + (Col - Col_0)$ Index_2 = Index_1 + 11 Sym = Symbol(Board(Row_No,Col_No))+1 If (i .le. 4) Sym = Enemy_Symbol v/ Line(Index_1:Index_2) = Sym//' 'l End Do. Sym = Symbol(Board(Row_No,Col_No)). If (i .le. 4) Sym = Enemy_Symbol  Line(19:19) = Symb If (i.le.6) then: CALL LIB$PUT_SCREEN(Line,Row,Col_0,Reverse) Else7 Call LIB$PUT_SCREEN(Line,Row,Col_0,Bold)  End If End Do  End If C--Update the player's namee>31 Call LIB$PUT_SCREEN(HisName,Name_Row,Name_Col,Underline) If (Setup_Mode) goto 9C--Update the turn numbers Call Put_TurnmD Call LIB$PUT_SCREEN('Turn Number',Turn_Text_Row,Turn_Text_Col, +Reverse)A Call LIB$PUT_SCREEN(' ',Setup_row,Setup_col,  +Reverse)C--Print the Prisonl9 Call Print_Prison (C--Set the scrolling region & refresh it2 Call LIB$SET_SCROLL(Start_scroll,End_Scroll) Call Scroll_Output(0)p, Call LIB$SET_CURSOR(Curr_Row,Curr_Col) END  ! SUBROUTINE SET_VIDEO(Code) h CHARACTER*(*) Code " CALL LIB$PUT_SCREEN(Code,,,) return endL) SUBROUTINE Put_Board(Row,Col,Video) # INCLUDE 'Stratego.INC/NOLIST'r CHARACTER*1 Sym*% INTEGER Row,Col,R,C,Video, Modev Mode = Video( If (Mode .EQ. Default) Mode = Bold" Sym = Symbol(Board(Row,Col))E If (Me*Board(Row,Col) .LT. 0 .AND. Board(Row,Col) .NE. Impasse)* +Sym = Enemy_Symbol R = Row + Row_0o C = Col*2 + Col_0s' Call LIB$PUT_SCREEN(Sym,R,C,Mode)a ! return end  SUBROUTINE Print_Prisons# INCLUDE 'Stratego.INC/NOLIST'- INTEGER Piece, R, C, i Do i = 1, Max_Prisonersr R = P_Row_0 + (i-1)/15# C = P_Col_0 + MOD(i-1,15) 1 If (R .EQ. P_Row_0 + 2) C = C + P_Indente0 Call LIB$PUT_SCREEN(Prison(i),R,C,None) End Do RETURN END)" SUBROUTINE Put_Prison(Piece)# INCLUDE 'Stratego.INC/NOLIST'g INTEGER Piece, R, C, i#  If (Piece .EQ. Flag) goto 111  Prisoners = Prisoners + 1 ' Prison(Prisoners) = Symbol(Piece)r7 If (Prisoners .GT. Max_Prisoners) Call Fix_Prisone$ R = P_Row_0 + (Prisoners-1)/15) C = P_Col_0 + MOD(Prisoners-1,15) f, If (R .EQ. P_Row_0+2) C = C + P_Indent5 Call LIB$PUT_SCREEN(Prison(Prisoners),R,C,None)u RETURN?111 Call LIB$PUT_SCREEN(Symbol(Piece),Turn_Row,Turn_col,none)r RETURN ENTRY Clear_Prison(Piece)e# If (Piece .EQ. Flag) goto 222I Do i = 1,Prisoners/ If (Symbol(Piece) .EQ. Prison(i)) Then  Prison(i) = ' '" R = P_Row_0 + (i-1)/15' C = P_Col_0 + MOD(i-1,15) e4 If (R .EQ. P_Row_0 + 2) C = C + P_Indent3 Call LIB$PUT_SCREEN(Prison(i),R,C,None)c RETURN End If. End Do RETURN5222 Call LIB$PUT_SCREEN(' ',Turn_Row,Turn_Col,None)D RETURN ENDi* LOGICAL FUNCTION Check_Priso INTEGER Length CHARACTER*(*) Text CHARACTER*38 Line_1,Line_2# DATA Line_1/' '/, Line_2/' '/i Mode = Video* If (Video .EQ. Default) Mode = Bold  length = LEN(Text) e if (length .GT. 38) Then i = 38 ; Do While (INDEX(Text(i:38),' ').EQ.0 .AND. i.GT.0)g i = i - 1i End DoT Line_1 = Text(:i) Line_2 = text(i+1:) else Line_1 = text End IFA call SCR$PUT_SCREEN(Line_1,%VAL(Error_Row),%VAL(Error_Col),R +%VAL(Mode))CC call SCR$PUT_SCREEN(Line_2,%VAL(Error_Row+1),%VAL(Error_Col),C +%VAL(Mode))i call LIB$SET_CURSOR(R,C)< If (Video .EQ. Default) Call Set_Video(Code(Bell)(:1)) Error_Set = .TRUE. return END %C--Subroutine to clear the error aread SUBROUTINE Clear_Error# INCLUDE 'STRATEGO.INC/NOLIST'P CHARACTER*76 Blank DATA Blank/' '/O3 Call S_Error(Curr_Row,Curr_Col,Blank,Reverse)( Error_Set = .FALSE.U RETURN ENDDwwinRow, MaxRow Do j=MinCol, MaxCol  R = Row_0 + i C = Col_0 + j*2* Call Put_Board(i,j,default)C If (j.ne.MaxCol) Call LIB$PUT_SCREEN(' ',R,C+1,None)s End Do End Doe Else=C--Highlight his area of the board (ie. dull opponent's area)s* His_Base_Row = INT((1-Him)*9/2.0)' My_Base_Row = 9 - His_Base_Rowf l)*Me .GT. 0) GOTO 20 !check if enemy pieceoA CALL S_Error(Curr_Row,Curr_Col,Message(Not_Yours),default) GOTO 1+C---check for moveable piece (ie. not bomb)cE20 IF (Board(Row,Col)*Me .NE. Bomb.AND. Board(Row,Col)*Me.NE.Flag)x) +GOTO 30 !check if moveable piecexB CALL S_Error(Curr_Row,Curr_Col,Message(immoveable),default) GOTO 1 C---check for a place to move to$30 IF (CanMove(Row,Col)) GOTO 100? CALL S_Error(Curr_Row,Curr_Col,Message(No_Place),default)a GOTO 15C--Finally, we have found a legitimate piece to move! 100 RETURN ENDeww If (i.le.6) then: CALL LIB$PUT_SCREEN(Line,Row,Col_0,Reverse) Else7 Call LIB$PUT_SCREEN(Line,Row,Col_0,Bold)l End If End Dol End If C--Update the player's namef>31 Call LIB$PUT_SCREEN(HisName,Name_Row,Name_Col,Underline) If (Setup_Mode) goto 9C--Update the turn number  Call Put_TurntD CaageL, Read(MesFil,101,END=999) Message(i)101 FORMAT(A) End Do999 CLOSE(MesFil) RETURN ENDwwwp_col,  +Reverse)C--Print the Prison_9 Call Print_Prison-(C--Set the scrolling region & refresh it2 Call LIB$SET_SCROLL(Start_scroll,End_Scroll) Call Scroll_Output(0)I, Call LIB$SET_CURSOR(Curr_Row,Curr_Col) END  ! SUBROUTINE SET_VIDEO(Code) a CHARACTER*(*) Code " CALL L%VAL(infunc),%VAL(IOSB_addr), " +,,inchar,%VAL(1),,inpterm,,)3 if (.NOT. Status) Call LIB$STOP(%VAL(Status))DMC---Check IO status block for a normal completion. If not, re-issue the QIO.e IF (Inchar .LE. 0) goto 1 ' If (IOSB(1) .NE. SS$_NORMAL) then ) Call Cancel_Type_Ahead(TermChan)( Goto 1 End If Tinput = InChars RETURN ENDyFC--Function to get a single character from the keyboard and return itsIC---ASCII value. The error region is cleared if the flag parameter is set C % INTEGER FUNCTION Get_Char(Flag)N LOGICAL Flag BYTE TInput  Get_Char = TInput() 6 If (Flag) Call Clear_Error !update error region Return END_# SUBROUTINE Keyboard_AST(Doof)RKC--Subroutine to handle keyboard-generated (ie. user-requested) out-of-bandIEC----ASTs. Parameter is passed by AST driver (undocumented feature!)ECi# INCLUDE 'STRATEGO.INC/NOLIST'F INTEGER Key,Doof< Call Cancel_Read(TermChan) !cancel all read requests  Key = %LOC(Doof)) If (Key .EQ. Redraw_Screen) GOTO 10 ( If (Key .EQ. Send_Message) GOTO 20% If (Key .EQ. Make_Note) GOTO 30 ' If (Key .EQ. Back_Scroll) GOTO 40 * If (Key .EQ. Forward_Scroll) GOTO 50' If (Key .EQ. Home_Scroll) GOTO 60T$ If (Key .EQ. Ask_Help) GOTO 70% If (Key .EQ. Full_Help) GOTO 80lC--here if invalid key+ Call s_error(1,1,'invalid key',blink)i returnC--Here for a re-draw requestQ10 Call Display GoTo 100'C--Here for a request to send a messagei20 Call MAIL(Him,-1)_ GoTo 100(C--Here for a request to make a notation30 Call MAIL(Me,-1) Goto 100 PC--Here for requests to scroll 40 Call Scroll_Output(-1) goto 10050 Call Scroll_Output(1)L goto 10060 Call Scroll_Output(0)  goto 10070 Call Quick_Help  goto 10080 Call Hel*p(100 Continue= Call Cancel_Type_Ahead(IoChan) !blow away input bufferh, Call LIB$SET_CURSOR(Curr_Row,Curr_Col) Return End. Subroutine CTRLY_Rout# INCLUDE 'STRATEGO.INC/NOLIST' Call S_ERROR(End_Scroll,1,1 +' ABORTED -- Game being terminated',blink)i Call Abort_Rout_ Endr Subroutine CTRLC_RoutQFC--Subroutine to handle a ^C interrupt. It spawns a DCL process, thenC---re-enables ^C.Ci# INCLUDE 'STRATEGO.INC/NOLIST'P= Call S_ERROR(End_Scroll,1,' [Control passed to DCL]', +blink)4 Msg = 'Your opponent is negotiating DCL talks' Call Mail(Him,0)( Status = LIB$SPAWN(,'SYS$COMMAND')3 IF (.NOT. Status) Call LIB$STOP(%VAL(Status))U% Call S_ERROR(Curr_Row,Curr_Col,r3 +' [Control returned to STRATEGO]',default)i6 Msg = 'Your opponent is back on the battlefield' Call Mail(Him,0) Call Display+ Call Enable_CTRLCu RETURN ENDn  Subroutine Abort_Rout # INCLUDE 'STRATEGO.INC/NOLIST'o Call LIB$ERASE_PAGE(1,1) Exit_Flag = .TRUE.6 msg = 'Your opponent has abdicated his position' Call MAIL(Him,0) Call Set_EF(His_Wait_Flag) Call CLOSEUP STOP 'Aborted.' END Subroutine Enable_Band_AST# INCLUDE 'STRATEGO.INC/NOLIST' INCLUDE '($IODEF)'  INTEGER IoFunc EXTERNAL Keyboard_AST  INTEGER AST_Mask(1:2)t AST_Mask(1) = 0tD AST_Mask(2) = IBSET(IBSET(IBSET(IBSET(IBSET(IBSET(IBSET(IBSET(9 +AST_Mask(1),Redraw_Screen),Back_Scroll),Make_Note),lE +Send_Message),Forward_Scroll),Home_Scroll),Ask_Help),Full_Help)e* IoFunc = IO$_SETMODE + IO$M_OUTBAND C Status = SYS$QIOW(,%VAL(IOChan),%VAL(IoFunc),,,,Keyboard_AST,a +AST_Mask,,,,)N3 IF (.NOT. Status) Call LIB$STOP(%VAL(Status))a + RETURN END Subroutine Enable_CTRLC02C--Subroutine to enable trapping and routing of ^CC # INCLUDE 'STRATEGO.INC/NOLIST'9 INCLUDE '($IODEF)' INTEGER IoFunc EXTERNAL CTRLC_Rout - IoFunc = IO$_SETMODE .OR. IO$M_CTRLCAST E Status =SYS$QIOW(,%VAL(IoChan),%VAL(IoFunc),,,,CTRLC_Rout,,,,,)o3 IF (.NOT. Status) Call LIB$STOP(%VAL(Status)) RETURN ENDc Subroutine Enable_CTCome here if I lose game 'cause I can't move or I quit1000 GameOver=.TRUE.( GameFlag = GameOver( If (Surrender) ThenO CALL Mail(Me, IQuit)l# CALL Mail(Him, ISurrender) Else, CALL Mail(Me, ILose) !console self5 CALL Mail(Him,YouWin) !congrats to opponentn End If Call Set_EF(Abort_EF)i Call Set_EF(His_Wait_Flag) RETURN$C Come here if premature termination2000 GameOver=.TRUE.tH If (Surrender) Call Mail(ME, ISurrender) !*** Temporary line ****? CALL Mail(Both, AllDone) !confirm to both that game done( GameFlag = GameOver' CALL LIB$SET_CURSOR(End_Scroll,1)n RETURN ENDawwear_Error !update error region Return END # SUBROUTINE Keyboard_AST(Doof)MKC--Subroutine to handle keyboard-generated (ie. user-requested) out-of-band EC----ASTs. Parameter is passed by AST driver (undocumented feature!)C# INCLUDE 'S C----now see if all intervening spaces are empty60 IF (ColMove) GOTO 70C-----check row move> IF (fromR .GT. Row) Step=-1 !move backwards numerically, DO 65 R=fromR + Step, Row - Step, Step- If (Board(R,Col) .EQ. Empty) GOTO 653C CALL S_Error(Curr_Row,Curr_Col,message(Bad_Scout),default)a2 GOTO 1 !jump out of loop (I luv gotos)65 CONTINUE! GOTO 100 !row move is OK C-----check column move >70 IF (fromC .GT. Col) Step=-1 !move backwards numerically, DO 75 C=fromC + Step, Col - Step, Step- If (Board(Row,C) .EQ. Empty) GOTO 751C CALL S_Error(Curr_Row,Curr_Col,message(Bad_Scout),default) 2 GOTO 1 !jump out of loop (I luv gotos)75 CONTINUE' GoTo 10 !check other conditions C--We have successfully moved! 100 R = Rowt C = Colo RETURN ENDuww1)A goto 10060 Call Scroll_Output(0)i goto 10070 Call Quick_Helps goto 10080 Call Helnes8 If (Old_Ptr .EQ. Curr_Line .OR. Old_Ptr.LE.0) ThenA Call S_Error(Curr_Row,Curr_Col,'End of scrolling buffer' + ,Default) RETURN End If, Ptr_Line = MOD(Ptr_Line,Max_Lines) + 1+ New_Line = MOD(Old_Ptr,Max_Lines) + 1dC ----Now do some work!-718 Call LIB$SET_CURSOR(Start_Scroll+Window_size-1,1) Call LIB$UP_SCROLL()1 Call LIB$PUT_SCREEN(Text_Line(New_Line),,,)n, Call LIB$SET_CURSOR(Curr_Row,Curr_Col) Scrolled = .TRUE.l RETURN%C --Here if home scrolling region 10 Continue, Ptr_Line = Curr_Line - Window_Size + 1; If (Ptr_Line .LE. 0 ) Ptr_Line = Max_Lines + Ptr_Linek Line = Ptr_Line,9 Do j = Start_Scroll, Start_Scroll + Window_Size - 1T2 Call LIB$PUT_SCREEN(Text_Line(Line),j,1,)' Line = MOD(Line,Max_Lines) + 1o End do Scrolled = .FALSE. RETURN Endiwwk on the battlefield' Call Mail(Him,0) Call Display3 IF (.NOT. Status) Call LIB$STOP(%VAL(Status))& If (.NOT. First_Player) Goto 120C--Generate a random nameN Status = SYS$GETTIM(Seed) 3 IF (.NOT. Status) Call LIB$STOP(%VAL(Status)). C---put it into CHARACTER format' ENCODE(16,1,Doof) Seed(2),Seed(1)i1 FORMAT(2Z8.8)E# Random_Name = 'Q'//Doof(7:15) )C--Stuff the mailbox with the random name) Call PUT_MAIL(MailChan,Random_Name)d Goto 130GC--Here to discover what's the random name (generated by first player) 120 Continue/ Call Read_Mail_Wait(MailChan,Random_Name)  @C--Now assign the local event flags and allocate the EF clusters130 Continue' EF_Cluster = Random_Name//'_EFCL'l% Gbl_Sect = Random_Name//'_SECT'w$ Mbx_Name = Random_Name//'_BOX' RETURN END$ Subroutine Map_DataS?C---Map the common block SHARED into a writeable global sectionaC,# INCLUDE 'STRATEGO.INC/NOLIST'B INCLUDE '($SECDEF)'  INTEGER Retadr(2)# INTEGER CRMPSC_Flags,Inadr(2)E @ CRMPSC_Flags = SEC$M_GBL .OR. SEC$M_PAGFIL .OR. SEC$M_WRT 6C + .OR. SEC$M_SYSGBL !need SYSGBL priv for this+ Inadr(1) = %LOC(Board(MinRow,MinCol))R Inadr(2) = %LOC(Last_Data)( Status = SYS$CRMPSC(Inadr,Retadr,,7 +%VAL(CRMPSC_Flags),Gbl_Sect,,,%VAL(0),%VAL(1),,,) 3 If (.NOT. Status) Call LIB$STOP(%VAL(Status)) RETURN ENDJC Create/map mailboxes for each process. Must be called AFTER Build_Names Subroutine Create_Mailbox # INCLUDE 'Stratego.INC/NOLIST' , My_MailBx_Name = Mbx_Name//CHAR(me+49). His_MailBx_Name = Mbx_Name//CHAR(Him+49)#C--Create/map the process mailboxes,5 Status = SYS$CREMBX(,MyChan,,,,,My_MailBx_Name)F3 IF (.NOT. Status) Call LIB$STOP(%VAL(Status)) 7 Status = SYS$CREMBX(,HisChan,,,,,His_MailBx_Name)u3 IF (.NOT. Status) Call LIB$STOP(%VAL(Status)) $C--Put write-attention on my mailbox Call Set_Mail_attention RETURN ENDN Subroutine Check_Help INTEGER Tinput,InChar,Flag23 Continue& Call Cancel_Type_Ahead(TermChan)B Call OUTPUT(0,'Hit any character to continue, "?" for help') InChar = Tinput() If (InChar .NE. 63) RETURN Call Help, Goto 23 ENDtww Call LIB$STOP(%VAL(Status))  If (All_Channels) Then All_Channels = .FALSE.T Channel = IOChan  Goto 2 End If RETURN ENDi Subroutine Enable_Exit# INCLUDE 'Stratego.inc/nolist'= EXTERNAL Abort_Rout  Exit_Block(1) = 0 & Exit_Block(2) = %LOC(Abort_Rout) Exit_Block(3) = 0 " Exit_Block(4) = %LOC(status)% Status = SYS$DCLEXH(Exit_Block) 3 if (.NOT. Status) Call LIB$STOP(%VAL(Status)) RETURN END)(C--Cancels exit handler for normal exits Subroutine Cancel_Exit# INCLUDE 'Stratego.inc/nolist'r% Status = SYS$CANEXH(Exit_Block)P3 if (.NOT. Status) Call LIB$STOP(%VAL(Status))F RETURN END_-C--Cancels read requests on channel specifiedf% Subroutine Cancel_Read(Channel) ' INTEGER Channel,Status,SYS$CANCEL,( Status = SYS$CANCEL(%VAL(Channel))3 if (.NOT. Status) Call LIB$STOP(%VAL(Status)) RETURN END_JC Wait for a particular event flag. Sets a timer request to interrupt the%C wait every seconds.sCi% Subroutine Wait_For(Event_Flag) INCLUDE 'stratego.inc/nolist' integer Event_Flag, State O( Call Set_Timer(EF_Wait_ID,EF_Wait_Time)- Status = SYS$WAITFR(%VAL(Event_Flag))T5 IF (.NOT. Status) Call LIB$STOP(%VAL(Status)) , Status = SYS$CLREF(%VAL(Event_Flag))5 IF (.NOT. Status) Call LIB$STOP(%VAL(Status)) A Call LIB$PUT_SCREEN(' ',Wait_row,Wait_Col,Reverse)( Call Cancel_Timer(EF_Wait_ID) RETURNTC--Set a single event flag Entry Set_EF(Event_Flag).- Status = SYS$SETEF(%VAL(Event_Flag)) )4 IF (.NOT.Status) Call LIB$STOP(%VAL(Status)) RETURN C--Clear a single event flag Entry Clear_EF(Event_Flag)- Status = SYS$CLREF(%VAL(Event_Flag)) E4 IF (.NOT.Status) Call LIB$STOP(%VAL(Status)) RETURNiAC--Read an event-flag cluster and return the state of the clusterr! Entry Read_EF(Event_Flag, State)j4 Status = SYS$READEF(%VAL(Event_Flag), State)4 IF (.NOT.Status) Call LIB$STOP(%VAL(Status)) RETURN ENDDC Set a timer request of a given ID and a given wait-time in secondsBC (must be < 60.00) If invoked with the same parameter value forAC seconds, code to convert time is skipped (old values are used)C) Subroutine Set_Timer(Request_ID,Seconds)  REAL Seconds,Old_SecondsT INTEGER Request_ID + integer SYS$SETIMR, SYS$BINTIM, SYS$CANTIM2 CHARACTER Wait_Time*9,Secs*5P integer Status,Blank,3 integer Time64(2) !output time buffer from BINTIM integer Timadr,Timbuf EXTERNAL Timer_AST SAVEC If (Old_Seconds .EQ. Seconds) goto 10 !don't bother with this code; Old_Seconds = Seconds !save the value for next invocation ENCODE (5,1,Secs) Seconds1 FORMAT (F5.2) Blank = INDEX(Secs,' ')( If (Blank.NE.0) Secs(Blank:Blank) = '0'3 Wait_Time = '0 ::'//Secs !the wait-time in seconds Timbuf = %LOC(Wait_Time) Timadr = %LOC(Time64)& Status = SYS$BINTIMue) .EQ. Flag) GOTO 900 !check for wins GameOver=.FALSE.I If (First_Turn .NE. Me) Turn = Turn + 1 !SECOND player updates turn. GameFlag = GameOver - RETURN !normal successful completionE3C Come here if I win the game cause I got his flag.E900 GameOver=.TRUE.O- CALL Mail(Me, IWin) !congratulate self / CALL Mail(Him,YouLose) !chastise opponentu Call Set_EF(Abort_EF)H Call Set_EF(His_Wait_Flag) GameFlag = GameOverQ RETURN8C Come here if I lose game 'cause I can't move or I quit1000 GameOver=.TRUE.( GameFlag = GameOver( If (Surrender) ThenO CALL Mail(Me, IQuit)l# CALL Mail(Him, ISurrender) Else, CALL Mail(Me, ILose) !console self5 CALL Mail(Him,YouWin) !congrats to opponentn End If Call Set_EF(Abort_EF)i Call Set_EF(His_Wait_Flag) RETURN$C Come here if premature termination2000 GameOver=.TRUE.tH If (Surrender) Call Mail(ME, ISurrender) !*** Temporary line ****? CALL Mail(Both, AllDone) !confirm to both that game done( GameFlag = GameOver' CALL LIB$SET_CURSOR(End_Scroll,1)n RETURN ENDawwear_Error !update error region Return END# SUBROUTINE Keyboard_AST(Doof)KC--Subroutine to handle keyboard-generated (ie. user-requested) out-of-bandEC----ASTs. Parameter is passed by AST driver (undocumented feature!)C# INCLUDE 'S .TRUE.. RETURN%C --Here if home scrolling regione10 Continue, Ptr_Line = Curr_Line - Window_Size + 1; If (Ptr_Line .LE. 0 ) Ptr_Line = Max_Lines + Ptr_Line( Line = Ptr_LineG9 Do j = Start_Scroll, Start_Scroll + Window_Size - 1e2 Call LIB$PUT_SCREEN(Text_Line(Line),j,1,)' Line = MOD(Line,Max_Lines) + 1H End do Scrolled = .FALSE. RETURN Endfww .EQ. Full_Help) GOTO 80C--here if invalid key+ Call s_errrated by first player) i120 Continue/ Call Read_Mail_Wait(MailChan,Random_Name)s @C--Now assign the local event flags and allocate the EF clusters130 Continue' EF_Cluster = Random_Name//'_EFCL'k% Gbl_Sect = Random_Name//'_SECT' $ Mbx_Name = Random_Name//'_BOX' RETURN ENDl Subroutine Map_DataS?C---Map the common block SHARED into a writeable global section C # INCLUDE 'STRATEGO.INC/NOLIST'  INCLUDE '($SECDEF)' INTEGER Retadr(2)a# INTEGER CRMPSC_Flags,Inadr(2)w @ CRMPSC_Flags = SEC$M_GBL .OR. SEC$M_PAGFIL .OR. SEC$M_WRT 6C + .OR. SEC$M_SYSGBL !need SYSGBL priv for this+ Inadr(1) = %LOC(Board(MinRow,MinCol))I Inadr(2) = %LOC(Last_Data)( Status = SYS$CRMPSC(Inadr,Retadr,,7 +%VAL(CRMPSC_Flags),Gbl_Sect,,,%VAL(0),%VAL(1),,,)3 If (.NOT. Status) Call LIB$STOP(%VAL(Status))- RETURN ENDCJC Create/map mailboxes for each process. Must be called AFTER Build_Names Subroutine Create_MailboxR# INCLUDE 'Stratego.INC/NOLIST'o, My_MailBx_Name = Mbx_Name//CHAR(me+49). His_MailBx_Name = Mbx_Name//CHAR(Him+49)#C--Create/map the process mailboxesM5 Status = SYS$CREMBX(,MyChan,,,,,My_MailBx_Name)u3 IF (.NOT. Status) Call LIB$STOP(%VAL(Status)) 7 Status = SYS$CREMBX(,HisChan,,,,,His_MailBx_Name) 3 IF (.NOT. Status) Call LIB$STOP(%VAL(Status))l$C--Put write-attention on my mailbox Call Set_Mail_attention RETURN END Subroutine Check_HelpR INTEGER Tinput,InChar,Flag23 Continue& Call Cancel_Type_Ahead(TermChan)B Call OUTPUT(0,'Hit any character to continue, "?" for help') InChar = Tinput() If (InChar .NE. 63) RETURN Call Help Goto 23r END ww Subroutine Enable_Band_AST# INCLUDE 'STRATEGO.INC/NOLIST' INCLUDE '($IODEF)'n(Piece)# INCLUDE 'Stratego.INC/NOLIST'r INTEGER Piece, i Check_Prison = .FALSE. DO i = 1,Prisoners@ If (Prison(i) .EQ. Symbol(Piece)) Check_Prison = .TRUE. End Do RETURN ENDt SUBROUTINE Fix_Prisono# INCLUDE 'STRATEGO.INC/NOLIST'  INTEGER N, i,j& N = MIN(Max_Prisoners,Prisoners) Do i = 1, NI% If (Prison(i) .EQ. ' ') Thenk% Prisoners = Prisoners - 1B Do j = i,N& Prison(j) = Prison(j+1) Prison(j+1) = ' ' End Do End Ifi End Do# Prison(Max_Prisoners+1) = ' 'N2 Do While (Prison(i) .EQ. ' ' .AND. i .GT. 0) i = i - 1 END DO Prisoners = i  Call Print_Prison RETURN END, Subroutine Put_Turn,# INCLUDE 'STRATEGO.INC/NOLIST'B Character*3 Doof  encode(3,12,Doof) Turn12 FORMAT(I3)6 Call LIB$PUT _SCREEN(doof,Turn_Row,Turn_Col,None) Return END wwIST' INCLUDE '($IODEF)' INTEGER IoFunc EXTERNAL CTRLY_Rout- IoFunc = IO$_SETMODE .OR. IO$M_CTRLYASTE Status =SYS$QIOW(,%VAL(IoChan),%VAL(IoFunc),,,,CTRLY_Rout,,,,,)3 IF (.NOT. Status) Call LIB$STOP(%VAL(Status)) RETURN END+ Subroutine Cancel_Type_Ahead(Channel))C--routine to erase the type-ahead bufferC# RLYL2C--Subroutine to enable trapping and routing of ^YC # INCLUDE 'STRATEGO.INC/NOLIST'E INCLUDE '($IODEF)' INTEGER IoFunc EXTERNAL CTRLY_Rout- IoFunc = IO$_SETMODE .OR. IO$M_CTRLYAST=E Status =SYS$QIOW(,%VAL(IoChan),%VAL(IoFunc),,,,CTRLY_Rout,,,,,)3 IF (.NOT. Status) Call LIB$STOP(%VAL(Status)), RETURN ENDt+ Subroutine Cancel_Type_Ahead(Channel) )C--routine to erase the type-ahead bufferlCI# INCLUDE 'STRATEGO.INC/NOLIST'f INCLUDE '($IODEF)' INTEGER InFunc, InChar INTEGER Channelx LOGICAL All_Channels If (Channel .EQ. 0) Then All_Channels = .TRUE. Channel = TermChanC End If+ InFunc = IO$_READVBLK .OR. IO$M_PURGE =2 status = SYS$QIOW(,%VAL(channel),%VAL(infunc),,,,,,,,,) 3 if (.NOT. Status) Call LIB$STOP(%VAL(Status))  If (All_Channels) Then All_Channels = .FALSE.  Channel = IOChan . Goto 2n End If RETURN ENDo Subroutine Enable_Exit# INCLUDE 'Stratego.inc/nolist'S EXTERNAL Abort_Rout  Exit_Block(1) = 0& Exit_Block(2) = %LOC(Abort_Rout) Exit_Block(3) = 0r" Exit_Block(4) = %LOC(status)% Status = SYS$DCLEXH(Exit_Block) 3 if (.NOT. Status) Call LIB$STOP(%VAL(Status)) RETURN ENDS(C--Cancels exit handler for normal exits Subroutine Cancel_Exit# INCLUDE 'Stratego.inc/nolist'a% Status = SYS$CANEXH(Exit_Block)W3 if (.NOT. Status) Call LIB$STOP(%VAL(Status)) RETURN END-C--Cancels read requests on channel specifiedF% Subroutine Cancel_Read(Channel) ' INTEGER Channel,Status,SYS$CANCEL ( Status = SYS$CANCEL(%VAL(Channel))3 if (.NOT. Status) Call LIB$STOP(%VAL(Status)) RETURN END JC Wait for a particular event flag. Sets a timer request to interrupt the%C wait every seconds.tCS% Subroutine Wait_For(Event_Flag)S INCLUDE 'stratego.inc/nolist' integer Event_Flag, State $( Call Set_Timer(EF_Wait_ID,EF_Wait_Time)- Status = SYS$WAITFR(%VAL(Event_Flag))5 IF (.NOT. Status) Call LIB$STOP(%VAL(Status)) , Status = SYS$CLREF(%VAL(Event_Flag))5 IF (.NOT. Status) Call LIB$STOP(%VAL(Status))tA Call LIB$PUT_SCREEN(' ',Wait_row,Wait_Col,Reverse)  Call Cancel_Timer(EF_Wait_ID) RETURNtC--Set a single event flag Entry Set_EF(Event_Flag))- Status = SYS$SETEF(%VAL(Event_Flag)) v4 IF (.NOT.Status) Call LIB$STOP(%VAL(Status)) RETURNfC--Clear a single event flag Entry Clear_EF(Event_Flag)t- Status = SYS$CLREF(%VAL(Event_Flag)) 4 IF (.NOT.Status) Call LIB$STOP(%VAL(Status)) RETURNlAC--Read an event-flag cluster and return the state of the clusterS! Entry Read_EF(Event_Flag, State)S4  Status = SYS$READEF(%VAL(Event_Flag), State)4 IF (.NOT.Status) Call LIB$STOP(%VAL(Status)) RETURN  ENDDC Set a timer request of a given ID and a given wait-time in secondsBC (must be < 60.00) If invoked with the same parameter value forAC seconds, code to convert time is skipped (old values are used)XCc) Subroutine Set_Timer(Request_ID,Seconds)= REAL Seconds,Old_SecondsS INTEGER Request_ID + integer SYS$SETIMR, SYS$BINTIM, SYS$CANTIM  CHARACTER Wait_Time*9,Secs*5T integer Status,Blank 3 integer Time64(2) !output time buffer from BINTIM integer Timadr,Timbuf EXTERNAL Timer_ASTA SAVEsC If (Old_Seconds .EQ. Seconds) goto 10 !don't bother with this code; Old_Seconds = Seconds !save the value for next invocationD ENCODE (5,1,Secs) Seconds1 FORMAT (F5.2) Blank = INDEX(Secs,' ')( If (Blank.NE.0) Secs(Blank:Blank) = '0'3 Wait_Time = '0 ::'//Secs !the wait-time in secondse Timbuf = %LOC(Wait_Time) Timadr = %LOC(Time64)& Status = SYS$BINTIM(wait_time,Time64)5 IF (.NOT. Status) Call LIB$STOP(%VAL(Status))R:10 Status = SYS$SETIMR(,Time64,Timer_AST,%VAL(Request_ID))5 IF (.NOT. Status) Call LIB$STOP(%VAL(Status))R RETURN1C-- Cancel a timer request Entry Cancel_Timer(Request_ID)t' Status = SYS$CANTIM(%VAL(Request_ID),)_5 IF (.NOT. Status) Call LIB$STOP(%VAL(Status))r RETURNh ENDGC Subroutine to handle timer interrupts. The system service should passm,C the timer ID number as the AST parameter.CI Subroutine Timer_AST(Doof)M INCLUDE 'Stratego.INC/nolist' PARAMETER (txt_Length = 15)# PARAMETER (Mid = txt_length/2 + 1)) PARAMETER (Max_Count = 8, Min_Count = 1)e PARAMETER (Leap = 1)  INTEGER ID,DoofC INTEGER Counter !counts times this routine has been called MOD 6  character*(txt_Length) txta INTEGER i,j,nextN< CHARACTER*1 Left_Character,Right_Character,Center_Character" CHARACTER*1 Scum_Char(-Leap:Leap) SAVEa DATA Scum_Char/'<','|','>'/ Center_Character = ' '-( If (Counter .EQ. 0) counter = Min_Count If (Next .eq. 0) Next = 1 If (Direction .NE. 0) ThenO! Counter = Counter + direction-< If (Counter .EQ. Max_Count .OR. Counter .EQ. Min_Count)  + Direction = 0n6 If (Counter .EQ. Max_Count) Center_Character = '*' Elset Direction = Next$ Left_Character = Scum_Char(Next)& Right_Character = scum_Char(-next) Next = -Next? If (Counter .EQ. Max_Count) Center_Character = scum_Char(0)D end IFT ID = %LOC(Doof)>C---# Subroutine Set_Mail_AttentionCC--Place write attention ASTs on my own mailbox. Direct the AST toC----the routine READ_MAIL# INCLUDE 'STRATEGO.INC/NOLIST' INCLUDE '($IODEF)' INTEGER IoFunc EXTERNAL Read_Mail) IoFunc = IO$_SETMODE + IO$M_WRTATTNE Status = SYS$QIOW(,%VAL(MyChan),%VAL(IoFunc),,,,Read_Mail,,,,,)2 If (.NOT.Status) Call LIB$STOP(%VAL(Status)) RETURN END& Subroutine PUT_MAIL(Channel,txt)# Check the ID to see who called me/ take appropriate action" IF (ID .EQ. EF_Wait_ID) Goto 10 ! STOP 'Timer_AST :: Bad timer ID'c.C---Here if it was a wait for Event flag timer 10 Continue i = counter j = Txt_Length + 1 - counter txt = ' ' txt(i:i) = Left_Character txt(j:j) = Right_Character txt(mid:mid) = Center_Character0 CAll LIB$PUT_SCREEN(txt,Wait_Row,Wait_Col,bold)5 Call LIB$SET_CURSOR(Cursor_Wait_Row,Cursor_wait_Col)h Call Set_Timer(ID,EF_Wait_Time) RETURN END# Subroutine Set_Mail_Attention CC--Place write attention ASTs on my own mailbox. Direct the AST toTC----the routine READ_MAIL# INCLUDE 'STRATEGO.INC/NOLIST'_ INCLUDE '($IODEF)' INTEGER IoFunc EXTERNAL Read_Mail) IoFunc = IO$_SETMODE + IO$M_WRTATTNsE Status = SYS$QIOW(,%VAL(MyChan),%VAL(IoFunc),,,,Read_Mail,,,,,),2 If (.NOT.Status) Call LIB$STOP(%VAL(Status)) RETURN END1& Subroutine PUT_MAIL(Channel,txt)#  INCLUDE 'STRATEGO.INC/NOLIST'r INCLUDE '($IODEF)' INTEGER Channele CHARACTER*(*) txt INTEGER IoFunc,Length,Addr Addr = %LOC(Txt) Length = LEN(txt) ' IoFunc = IO$_WRITEVBLK + IO$M_NOWSB Status = SYS$QIOW(,%VAL(Channel),%VAL(IoFunc),,,,%VAL(Addr), +%VAL(Length),,,,) 2 If (.NOT.Status) Call LIB$STOP(%VAL(Status)) RETURN ENDmCC--Subroutine to read the mailbox. Called on a write-attention AST C  Subroutine Read_Mail# INCLUDE 'STRATEGO.INC/NOLIST'x INCLUDE '($IODEF)' CHARACTER*80 Txt INTEGER IoFunc INTEGER Addr< Call Cancel_Read(TermChan) !cancel all read requests  Addr = %LOC(Txt)& IoFunc = IO$_READVBLK + IO$M_NOWA Status = SYS$QIOW(,%VAL(MyChan),%VAL(IoFunc),,,,%VAL(Addr),) +%VAL(80),,,,) 2 If (.NOT.Status) Call LIB$STOP(%VAL(Status))( If (ICHAR(Txt(:1)) .EQ. 0) Goto 99 txt = txt(:79)//Code(Bell)12 (wait_time,Time64)5 IF (.NOT. Status) Call LIB$STOP(%VAL(Status)):10 Status = SYS$SETIMR(,Time64,Timer_AST,%VAL(Request_ID))5 IF (.NOT. Status) Call LIB$STOP(%VAL(Status)) RETURNC-- Cancel a timer request Entry Cancel_Timer(Request_ID)' Status = SYS$CANTIM(%VAL(Request_ID),)5 IF (.NOT. Status) Call LIB$STOP(%VAL(Status)) RETURN ENDGC Subroutine to handle timer interrupts. The system service should pass,C the timer ID number as the AST parameter.C Subroutine Timer_AST(Doof) INCLUDE 'Stratego.INC/nolist' PARAMETER (txt_Length = 15)# PARAMETER (Mid = txt_length/2 + 1)) PARAMETER (Max_Count = 8, Min_Count = 1) PARAMETER (Leap = 1) INTEGER ID,DoofC INTEGER Counter !counts times this routine has been called MOD 6 character*(txt_Length) txt INTEGER i,j,next< CHARACTER*1 Left_Character,Right_Character,Center_Character" CHARACTER*1 Scum_Char(-Leap:Leap) SAVE DATA Scum_Char/'<','|','>'/ Center_Character = ' '( If (Counter .EQ. 0) counter = Min_Count If (Next .eq. 0) Next = 1 If (Direction .NE. 0) Then! Counter = Counter + direction< If (Counter .EQ. Max_Count .OR. Counter .EQ. Min_Count)  + Direction = 06 If (Counter .EQ. Max_Count) Center_Character = '*' Else Direction = Next$ Left_Character = Scum_Char(Next)& Right_Character = scum_Char(-next) Next = -Next? If (Counter .EQ. Max_Count) Center_Character = scum_Char(0) end IF ID = %LOC(Doof)>C---Check the ID to see who called me/ take appropriate action" IF (ID .EQ. EF_Wait_ID) Goto 10 ! STOP 'Timer_AST :: Bad timer ID'.C---Here if it was a wait for Event flag timer 10 Continue i = counter j = Txt_Length + 1 - counter txt = ' ' txt(i:i) = Left_Character txt(j:j) = Right_Character txt(mid:mid) = Center_Character0 CAll LIB$PUT_SCREEN(txt,Wait_Row,Wait_Col,bold)5 Call LIB$SET_CURSOR(Cursor_Wait_Row,Cursor_wait_Col) Call Set_Timer(ID,EF_Wait_Time) RETURN END# Subroutine Set_Mail_AttentionCC--Place write attention ASTs on my own mailbox. Direct the AST toC----the routine READ_MAIL# INCLUDE 'STRATEGO.INC/NOLIST' INCLUDE '($IODEF)' INTEGER IoFunc EXTERNAL Read_Mail) IoFunc = IO$_SETMODE + IO$M_WRTATTNE Status = SYS$QIOW(,%VAL(MyChan),%VAL(IoFunc),,,,Read_Mail,,,,,)2 If (.NOT.Status) Call LIB$STOP(%VAL(Status)) RETURN END& Subroutine PUT_MAIL(Channel,txt)# INCLUDE 'STRATEGO.INC/NOLIST' INCLUDE '($IODEF)' INTEGER Channel CHARACTER*(*) txt INTEGER IoFunc,Length,Addr Addr = %LOC(Txt) Length = LEN(txt)' IoFunc = IO$_WRITEVBLK + IO$M_NOWB Status = SYS$QIOW(,%VAL(Channel),%VAL(IoFunc),,,,%VAL(Addr), +%VAL(Length),,,,)2 If (.NOT.Status) Call LIB$STOP(%VAL(Status)) RETURN ENDCC--Subroutine to read the mailbox. Called on a write-attention ASTC  Subroutine Read_Mail# INCLUDE 'STRATEGO.INC/NOLIST' INCLUDE '($IODEF)' CHARACTER*80 Txt INTEGER IoFunc INTEGER Addr< Call Cancel_Read(TermChan) !cancel all read requests  Addr = %LOC(Txt)& IoFunc = IO$_READVBLK + IO$M_NOWA Status = SYS$QIOW(,%VAL(MyChan),%VAL(IoFunc),,,,%VAL(Addr), +%VAL(80),,,,)2 If (.NOT.Status) Call LIB$STOP(%VAL(Status))( If (ICHAR(Txt(:1)) .EQ. 0) Goto 99 txt = txt(:79)//Code(Bell)12 Call OUTPUT(0,Txt)QC--Now read the EXIT_flag for indication of an abnormal termination by the other &C process. If flag is set, then punt.C If (Exit_Flag) Then Call CLOSEUP STOP 'Aborted.' End If4 Call Set_Mail_Attention !re-enable mail ASTs RETURN99 Txt = '***No message' goto 12 EndJC--Function to read mailbox and wait for something to show up if necessary, Subroutine Read_Mail_Wait(Channel,Txt) INCLUDE '($IODEF)' INTEGER Channel,Length CHARACTER*(*) Txt$ INTEGER IoFunc,Status,SYS$QIOW INTEGER Addr Addr = %LOC(Txt) Length = LEN(Txt) IoFunc = IO$_READVBLKB Status = SYS$QIOW(,%VAL(Channel),%VAL(IoFunc),,,,%VAL(Addr), +%VAL(Length),,,,)2 If (.NOT.Status) Call LIB$STOP(%VAL(Status)) RETURN ENDww DތC STRATEGO HC Copyright (c) 1984. No copies of this text may be distributed without@C written pe Call OUTPUT(0,Txt)QC--Now read the EXIT_flag for indication of an abnormal termination by the other &C process. If flag is set, then punt.C If (Exit_Flag) Then Call CLOSEUP STOP 'Aborted.' End If4 Call Set_Mail_Attention !re-enable mail ASTs RETURN99 Txt = '***No message' goto 12 EndJC--Function to read mailbox and wait for something to show up if necessary, Subroutine Read_Mail_Wait(Channel,Txt) INCLUDE '($I,ODEF)' INTEGER Channel,Length CHARACTER*(*) Txt$ INTEGER IoFunc,Status,SYS$QIOW INTEGER Addr Addr = %LOC(Txt) Length = LEN(Txt) IoFunc = IO$_READVBLKB Status = SYS$QIOW(,%VAL(Channel),%VAL(IoFunc),,,,%VAL(Addr), +%VAL(Length),,,,)2 If (.NOT.Status) Call LIB$STOP(%VAL(Status)) RETURN ENDwwmQɍC STRATEGO HC Copyright (c) 1984. No copies of this text may be distributed without@C written pe