Listing of file='BACK.FOR;07' 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)
CALL CURSOR(X,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