Compucolor.org – Virtual Media

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