Listing of file='BACK.FOR;08' on disk='vmedia/backgammon-sideB-sector.ccvf'
SUBROUTINE BOARD(A1,B1) INTEGER A1(26),B1(26) BYTE POSN,NUM,I,J,K,N BYTE ADD,INC,OFFSET,STRT BYTE X,Y,BG,FG LOGICAL BAR Y = 29 INC = -2 ADD = -3 POSN = 0 STRT = 63 OFFSET = 0 BAR = .FALSE. DO 300 I=1,2 DO 200 J=1,2 DO 100 K=1,6 POSN = POSN+1 IF(B1(POSN).EQ.A1(POSN))GOTO 100 BG = 2 N = POSN-(POSN/2)*2 IF(N.NE.0) BG = 4 X= STRT+ADD*(POSN-OFFSET) FG = 7 IF(B1(POSN).GT.0) FG= 1 NUM = IABS(B1(POSN)) CALL FILL(X,Y,INC,NUM,FG,BG,BAR) IF(NUM.EQ.0) GOTO 100 CALL CURSOR(X+1,Y) CALL CO(6) CALL CO(8*FG) CALL WRNUM(NUM) 100 CONTINUE STRT = STRT+ADD 200 CONTINUE Y = 5 INC = 2 ADD = 3 STRT = 21 OFFSET = 12 300 CONTINUE BAR = .TRUE. Y = 27 INC = -2 IF(B1(25).EQ.A1(25))GOTO 400 BG= 5 FG= 7 X= 42 NUM = -B1(25) CALL FILL(X,Y,INC,NUM,FG,BG,BAR) 400 Y = 7 INC = 2 IF(B1(26).EQ.A1(26))GOTO 500 BG= 5 FG= 1 X= 42 NUM = B1(26) CALL FILL(X,Y,INC,NUM,FG,BG,BAR) 500 CALL CURSOR(0,0) DO 600 I=1,26 600 A1(I)= B1(I) CALL CO(6) CALL CO(2) RETURN END SUBROUTINE FILL(X,Y,INC,NUM,FG,BG,BAR) BYTE X,Y,INC,NUM,FG,BG LOGICAL BAR BYTE N,SYMBOL,YT YT = Y DO 1000 N=1,5 SYMBOL = 6 IF(N.GT.NUM) SYMBOL = N GOTO (100,200,300,400,500,600),SYMBOL 100 CALL WIDE(X,YT,BG) GOTO 700 200 CALL WIDE(X,YT,BG) GOTO 700 300 IF(BAR) GOTO 100 CALL MEDIUM(X,YT,BG) GOTO 700 400 IF(BAR) GOTO 100 CALL MEDIUM(X,YT,BG) GOTO 700 500 IF(BAR) GOTO 100 CALL NARROW(X,YT,BG) GOTO 700 600 CALL PIECE(X,YT,FG) 700 CONTINUE YT = YT+INC 1000 CONTINUE RETURN END SUBROUTINE PIECE(X,Y,FG) BYTE X,Y,FG BYTE SEQ(29) DATA SEQ/3,0,0,6,0,29,116,6,0,30,32,29,6,0,117, * 10,26,26,26,118,6,0,30,32,29,6,0,119,X'EF'/ SEQ(2) = X SEQ(3) = Y SEQ(5) = FG SEQ(9) = 8*FG SEQ(14) = FG SEQ(22) = 8*FG SEQ(27) = FG CALL OSTR(SEQ) RETURN END SUBROUTINE WIDE(X,Y,BG) BYTE X,Y,BG BYTE SEQ(20) DATA SEQ/3,0,0,6,0,30,32,32,32,29, * 10,26,26,26,30,32,32,32,29,X'EF'/ SEQ(2) = X SEQ(3) = Y SEQ(5) = 8*BG CALL OSTR(SEQ) RETURN END SUBROUTINE MEDIUM(X,Y,BG) BYTE X,Y,BG BYTE SEQ(40) DATA SEQ/3,0,0,6,0,2,254,240,255,6,0,30,32,29,6,0, * 2,254,15,255,10,26,26,26,2,254,240,255,6,0, * 30,32,29,6,0,2,254,15,255,X'EF'/ SEQ(2) = X SEQ(3) = Y SEQ(5) = BG SEQ(11) = 8*BG SEQ(16) = BG SEQ(30) = 8*BG SEQ(35) = BG CALL OSTR(SEQ) RETURN END SUBROUTINE NARROW(X,Y,BG) BYTE X,Y,BG BYTE SEQ(30) DATA SEQ/3,0,0,6,0,29,32,6,0,30,32,29,6,0,32, * 10,26,26,26,29,32,6,0,30,32,29,6,0,32,X'EF'/ SEQ(2) = X SEQ(3) = Y SEQ(9) = 8*BG SEQ(23) = 8*BG CALL OSTR(SEQ) RETURN END