perm filename GEMSUB[GEM,BGB] blob sn#099401 filedate 1974-04-27 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00021 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002	TITLE GEMSUB GEOMETRIC MODELING SYSTEM SUBROUTINES.
C00005 00003	INITIALIZE APR TRAP
C00007 00004	PRINT BACKTRACE
C00011 00005	WHAT USER CAN DO ABOUT ERROR
C00013 00006	WE GET HERE ON AT INTERRUPT
C00016 00007	TAKE CARE OF OVERFLOW.
C00020 00008	SUBROUTINES (WHICH USE PP INSTEAD OF P)
C00023 00009	DATA STORAGE
C00024 00010	ROUTINES TO PUSH AND POP ACCUMULATORS.
C00026 00011	TITLE ARITH  -  ARITHMETIC ROUTINES.
C00029 00012	SUBR(SIN,X)
C00031 00013	SUBR(ATAN,X)		ARC TANGENT
C00034 00014	SUBR(ATAN2,DY,DX)	ARC TANGENT (DELTA-Y,DELTA-X)
C00037 00015	SUBR(REALI)
C00039 00016	PRIMARY:
C00042 00017	TITLE III    - III DISPLAY SUBROUTINES - BGB - JANUARY 1973.
C00043 00018	SUBRS DPYSET,DPYBIG,DPYBRT	Set buffer,char. size, brightness*
C00045 00019	SUBRS AVECT,AIVECT,RVECT,RIVECT	Vectors
C00048 00020	SUBRS DPYSTR,DTYO,DPYOUT	Output string,character, POG	*
C00050 00021	SUBRS OCTDPY,DECDPY,FLODPY	Numeric display
C00053 ENDMK
C⊗;
TITLE GEMSUB; GEOMETRIC MODELING SYSTEM SUBROUTINES.

	INTERNAL FATAL.,WARN.,TRAPINIT,PUSHIT,POPIT,DDTGO,OVRGAG
	EXTERNAL PDL
	EXTERNAL JOBCNI,JOBAPR,JOBTPC,JOBREL,JOBHRL,JOBDDT
	EXTERNAL JOBREN,JOBOPC,JOBSA

	IFNDEF PUSHIT<
	DEFINE PUSHACS<PUSHJ P,PUSHIT↑
	GLOBAL .PLEVEL↔.PLEVEL←←.PLEVEL+20>
	DEFINE POPACS<PUSHJ P,POPIT↑
	GLOBAL .PLEVEL↔.PLEVEL←←.PLEVEL-20>>

IFNDEF JENFIX<JENFIX←←0 >	;SET TO -1 WHEN INTJEN IS FIXED

	OPDEF INTJEN[723B8]
	OPDEF JRSTF[JRST 2,]

	CNT←14
	RA←15
	PP←16
	P←17
	INTTTI←←1B15		; INTERRUPT ON <ESC>I
	POV←←1B19		; INTERRHUPT ON PDL OV
	ILM←←1B22		; INTERRUPT ON ILL. MEM. REF.
	NXM←←1B23		; INTERRUPT ON NON-EX. MEM.
	INTFOV←←1B29		; INTERRUPT ON FOATING OVERFLOW
	INTOV←←1B32		; INTERRUPT ON ARITHMETIC ROVERFHLOW

	OVBOTH←←INTOV+INTFOV
	DEFINE INTFOR <FOR @` I ⊂ (INTTTI,POV,ILM,OVBOTH)>
;INITIALIZE APR TRAP
TRAPINIT↑:
;--------------------------------------------------------------------
	MOVEI 0,INTLOC↔DAC 0,JOBAPR
	IFN JENFIX <POP P,INTPC↔INTJEN INTWRD>
	IFE JENFIX <LAC 0,INTWRD↔INTENB 0,↔POPJ P,>

	XWD 777000,[SIXBIT/WARN./]
WARN.↑:	SETZM NOCONT↔GO FATAL2
	XWD 777000,[SIXBIT/FATAL./]
FATAL.↑:SETOM NOCONT↔SETZM ALWAYS
FATAL2:	SETOM ILOCK		;INTERLOCK AGAINST INTERRUPT
	POP P,INTPC
	DAC 0,ACSAVE		;SAVE STATE OF WORLD
	LAC 0,[XWD 1,ACSAVE+1]
	BLT ACSAVE+17

;TYPE THE MESSAGE STRING.
	SKIPE NOCONT↔OUTSTR[ASCIZ/FATAL:  /]
	SKIPN NOCONT↔OUTSTR[ASCIZ/WARNING:  /]
	LAC 0,@1(P)↔OUTSTR @0↔DAC 0,ERRTXT
	CRLF

	SETZ↔INTENB		;TURN OFF OUR ENABLINGS
	SETZM ILOCK		;RESET INTERLOCK, WE'RE SAFE NOW
	LAC PP,[IOWD 10,BKPDL]	;GET A TEMPORARY PDL
	SKIPE NOCONT↔GO BTRACE
	GO CONT
;PRINT BACKTRACE

	USERMODE←←1B5		;ALWAYS ON IN A PC
	PC.OFF←←1B4+1B6+37B17	;ALWAYS OFF IN A PC
				;1B4 is byte interrupt, never in user PDL
				;1B6 is IOT mode, almost never on in PDL

BTRACE:	CDR P,P		;GET READY TO PRINT A BACKTRACE
	OUTSTR[ASCIZ/
BACKTRACE: /]
PCLOOP:	LAC RA,(P)		;PICK UP WORD OFF OF STACK AND SEE IF IT'S A PC
	TLNE RA,(USERMODE)	;IS USER MODE ON?
	TLNE RA,(PC.OFF)	;AND OTHER DETERMINING BITS OFF?
	GO NOTPC		;NO, NOT A PC
	PUSH PP,RA		;LEFT HALF GOOD, NOW, IS IT IN OUR CORE IMAGE
	PUSHJ PP,ADRCHK
	GO NOTPC		;NO, PROBABLY NOT A PC
	MOVEI CNT,3		;DON'T LOOK MORE THAN THREE BACK
	OUTSTR[ASCIZ/ /]
PJLOOP:	SUBI RA,1↔JUMPLE RA,UNKNPJ
	CAR 0,(RA)↔CAIN 0,(<PUSHJ P,>)↔GO GOTPJ
	SOJG CNT,PJLOOP
UNKNPJ:	OUTSTR[ASCIZ/(?)/]	;WE DIDN'T FIND A PUSHJ, INDICATE AN UNKNOWN ROUTINE
	GO NOTPC		;AND LOOK FOR MORE

GOTPJ:	PUSH PP,(RA)		;WE FOUND A PUSHJ P,
	PUSHJ PP,ADRCHK		;CHECK ADDRESS
	GO UNKNPJ		;OOPS, PRINT BARF MESSAGE
	LDB 0,[POINT 12,-1(1),11]	;LOOK BACK AT SUBROUTINE-1
	CAIE 0,7770			;IS SPECIAL MARK THERE?
	GO [ LDB 0,[POINT 12,-1(1),11]	;NO, TRY BACK ANOTHER, IN CASE IT STARTS
	     CAIN 0,7770		;AT SUBROUTINE+1
	     GO [ LAC 1,-2(1)		;SPECIAL MARK THERE
		  PUSH PP,(1)		;PRINT NAME+1
		  PUSHJ PP,SIXOUT
		  OUTSTR[ASCIZ/+1/]
		  GO NOTPC ]
	     PUSH PP,1		;PRINT OCTAL OF SUBROUTINE ADDRESS
	     PUSHJ PP,OCTOUT
	     GO NOTPC ]
	LAC 1,-1(1)		;PRINT NAME OF ROUTINE
	PUSH PP,(1)
	PUSHJ PP,SIXOUT
NOTPC:	SOS P			;NOW, LETS TRY NEXT ONE DOWN
	CAIL P,PDL		;END YET?
	GO PCLOOP		;NO
	OUTSTR[ASCIZ/
/]				;YES, CRLF
	MOVSI 17,ACSAVE		;RESTORE ACS
	BLT 17,16
	SKIPN OVRGAG↔GO CMLOOP	;WE COULD FALL THRU BUT THIS IS SAFER
	GO CMLOOP
;WHAT USER CAN DO ABOUT ERROR
;
CMLOOP:	SKIPN NOCONT
	GO [ SKIPE ALWAYS↔GO CONT
	     OUTSTR [ASCIZ/→/]
	     GO CMLOO2]
	OUTSTR [ASCIZ/?/]
CMLOO2:	CLRBFI			;NO TYPE AHEAD, THANK YOU
	INCHRW 17↔ANDI 17,137	;WHAT DOES USER WANT TO DO
	CAIN 17,"R"↔GO @JOBREN
	CAIN 17,"S"↔GO [ CDR 17,JOBSA↔GO (17) ]
	CAIN 17,"D"↔GO DDTCALL
	CAIN 17,"α"↔GO CONT
	SKIPE NOCONT↔GO NOTCOM
	CAIN 17,12
	CAIE 17,15
	GO [	CAIN 17,12↔SETOM ALWAYS
	CONT:	SETZM ILOCK↔GO INTRT2 ]

NOTCOM:	OUTSTR[ASCIZ/???
D - DDT, R - REENTER, S - START/]
	SKIP NOCONT
	OUTSTR[ASCIZ/, <RETURN> CONTINUE
/]↔	OUTSTR[ASCIZ/
/]↔	OUTSTR @ERRTXT
	GO CMLOOP

;SEE IT DDT IS LOADED AND RUN IT
DDTCALL:SKIPN 17,JOBDDT
	GO [ OUTSTR[ASCIZ/
NO DDT.
?/]↔	       GO CMLOOP ]
IFE JENFIX
<	SETOM ILOCK		;WATCH THE RACE CONDITION
	LAC 17,INTPC
	DAC 17,JOBOPC
	OUTSTR[ASCIZ/
YOU'RE IN DDT.
/]
	LAC 17,INTWRD
	INTENB 17,
	LAC 17,ACSAVE+17
	SETZM ILOCK		;WATCH THE RACE CONDITION
	GO @JOBDDT
>
	OUTSTR [ASCIZ/
YOU'RE IN DDT.
/]
IFN JENFIX
<	LAC 17,ACSAVE+17
	INTJEN INTWRD
>
;WE GET HERE ON AT INTERRUPT
;
INTLOC:	SETZ		;TURN OFF INTERRUPTS, JUST IN CASE!
	INTENB
	DAC 5,STAT6	;REMEMBER THE STATUS OF PDP-6
	LAC 0,JOBCNI		;HOW DID WE GET HERE?
	INTFOR
<IFE I∧777777 < TLNE 0,(I)
>IFN I∧777777 < TRNE 0,I
>	GO [ MOVEI .`I
	     JRST USRRET ]
>
	MOVEI .UNKNOWN
USRRET:	DAC PCGO
	SKIPE ILOCK
	GO ILOSE
	UWAIT		;WHEN WE RETURN, WE'LL GET OUR AC'S BACK
	DAC 0,ACSAVE
	LAC 0,JOBTPC↔TLNN 0,USERMODE↔SETOM BAZFLG#↔DAC 0,INTPC
	LAC 0,[XWD 1,ACSAVE+1]
	BLT 0,ACSAVE+17
	DEBREAK
	LAC PP,[IOWD 10,BKPDL]
	JRSTF @PCGO

.POV:	OUTSTR[ASCIZ/?
PDL OV/]
	SOS INTPC		;INSTRUCTION WHERE IT REALLY HAPPENED
	PUSHJ PP,ATUSER
	GO IFATAL

.ILM:	PUSH PP,INTPC
	PUSHJ PP,ADRCHK
	GO [ OUTSTR[ASCIZ/?
PC OUT OF BOUNDS/]
	     GO .ILM2 ]
	OUTSTR[ASCIZ/?
ILL MEM REF/]
.ILM2:	PUSHJ PP,ATUSER
	GO IFATAL

.INTTT:	OUTSTR[ASCIZ/
<ESC> I  INTERRUPT/]
	PUSHJ PP,ATUSER
	SETZM NOCONT
	SETZM ALWAYS
	GO BTRACE

.UNKNO:	OUTSTR[ASCIZ/?
UNEXPECTED INTERRUPT/]
	PUSHJ PP,ATUSER
	GO IFATAL

IFATAL:	SETOM NOCONT
	SETZM ALWAYS
	GO BTRACE

ILOSE:	CAIN .INTTTI
	GO [ LAC 0,INTWRD	;WE'RE ALREADY IN AN ERROR ROUTINE
	       INTENB 0,
	       DISMIS ]
	LAC 0,JOBTPC
	DAC 0,INTPC
	UWAIT		;GET BACK USER ACS, ETC.
	DEBREAK		;GET BACK TO USER LEVEL
	OUTSTR[ASCIZ/?
INTERRUPT OCCURED DURING ERROR ROUTINE!  /]
	HALT .+1
	JRSTF @INTPC
;TAKE CARE OF OVERFLOW.
.OVBOTH:LAC 0,INTPC
	TLNE 0,000040		;TEST ZERO DIVIDE
	GO [ SKIPN OVRGAG	;DIVISION BY ZERO RESULTS IN INFINITY!
	     OUTSTR[ASCIZ/DIVISION BY ZERO/]
	     LAC 0,[377777777777]
	     GO FIXOVER ]
	TLNE 0,000100		;TEST FLOATING UNDERFLOW
 	GO [ SKIPN OVRGAG	;SET TO ZERO
	     OUTSTR[ASCIZ/FLOATING UNDERFLOW/]
	     SETZ 0,
	     GO FIXOVER ]
	TLNE 0,040000
	GO [	SKIPN OVRGAG
		OUTSTR[ASCIZ/FLOATING OVERFLOW/]
		LAC 0,[377777777777]	;FLOATING OVERFLOW PRODUCES INFINITY
		GO FIXOVER ]
	TLNN 0,400000		;INTEGER OVERFLOW?
	HALT .+1
	MOVSI 1,400000
	ANDCAM 1,INTPC
	GO INTRET
FIXOVER:DAC 0,OVFIX
	SKIPN OVRGAG
	PUSHJ PP,ATUSER
	MOVSI 1,440140		;TURN OFF LOSING BITS
	ANDCAB 1,INTPC
	LAC 1,-1(1)		;IT HAPPENED AT PC-1

XCLOOP:	LDB 2,[POINT 9,1,8]		;GET OPCODE
	CAIN 2,<XCT>/1B8		;IS IT AN XCT INSTRUCTION
	GO [ TLZ 1,777400		;TURN OFF OPCODE
	       TLO 1,(<LAC 1,>)
	       DAC 1,OVINST
	       MOVSI 17,ACSAVE		;YES, TRY NEXT ONE IN CHAIN
	       BLT 17,16
	       LAC 17,ACSAVE+17
	       XCT OVINST
	       GO XCLOOP ]
	DAC 1,OVINST
	TLZ 1,777740		;TURN IT INTO A MOVEI TO CALCULATE EFFECTIVE ADDRESS
	TLO 1,(<MOVEI 2,>)
	DAC 1,OVOP
	MOVSI 17,ACSAVE		;GET ACS FOR EFFECTIVE ADDRESS CALCULATION
	BLT 17,16
	LAC 17,ACSAVE+17
	XCT OVOP		;DO ADDRESS CALCULATION, PUTTING RESULT INTO AC.2
	CAIGE 2,17		;IN CASE THE EFFECTIVE ADDRESS IN AN AC
	ADDI 2,ACSAVE		;POINT TO SAVED ACS
	LDB 3,[POINT 4,OVINST,12];GET AC FIELD INTO AC.3
	ADDI 3,ACSAVE		;POINT TO SAVED ACS
	LDB 1,[POINT 9,OVINST,8];GET OPCODE
	LAC 0,OVFIX	
	CAIN 1,<FSC>/1B8	;SPECIAL TEST FOR FSC
	GO [ SETZ 1,		;RESULT INTO AC.0
	       GO NTEST2 ]
	CAILE 1,140↔CAILE 1,177↔GO NTEST	;FLOATING IMMEDIATE.
	ANDI 1,7↔CAIE 1,5↔	GO NTEST
	MOVSS 2,2↔SKIPGE 2↔MOVN 0,0
	GO NTEST2

NTEST:	ANDI 1,3↔CAIN 1,1↔GO NTEST2
	SKIPGE (2)↔MOVN 0,0		;CHANGE SIGN AS IF (MEMORY)<0
NTEST2:	SKIPGE (3)↔MOVN 0,0		;CHANGE SIGN IF (AC)<0
	SKIPN (3)↔SETZ			;MAKE 0/0=0
	ANDI 1,3↔TRNE 1,2↔DAC 0,(2)	;RESULT TO MEMORY.
	CAIE 1,2↔DAC 0,(3)		;RESULT TO ACCUMULATOR.
INTRET:	MOVSI 17,ACSAVE
	BLT 17,16
INTRT2:
	LAC 17,INTWRD
	INTENB 17,
	LAC 17,ACSAVE+17
	JRSTF @INTPC
;SUBROUTINES (WHICH USE PP INSTEAD OF P)
;--------------------------------------------------------------------
; Routine to check to make sure RH is in core image.  Returns RH is 1
; and skips if legal address
ADRCHK:	CDR 1,-1(PP)
	CAMLE 1,JOBREL
	GO [ CAIL 1,400000	;(DON'T NEGLECT UPPER!)
	     CAILE 1,JOBHRL
	     GO POPP1J
	     GO .+1]
	AOS (PP)
POPP1J:	SUB PP,[XWD 2,2]↔GO @2(PP)
;--------------------------------------------------------------------
; Print a right half in octal	(if called at OCTOUT+1, print left half)
OCTOUT:	MOVSS -1(PP)			;LAC INTO LEFT HALF
	SKIPA 4,[[ ROTC 3↔"0" ]]	;WE CAN SHARE CODE WITH SIXOUT
; Print a number in sixbit
SIXOUT:	MOVEI 4,[ ROTC 6↔" "]	;(TO SHARE WITH OCTOUT)
	MOVEI 3,6		;NUMBER OF CHARACTERS
	LAC 1,-1(PP)		;GET ARG.
SXLOOP:	SETZ 0,			;CLEAR AC WERE ABOUT TO ROTC INTO
	XCT (4)			;GET HIGH ORDER DIGIT/CHARACTER
	ADD 0,1(4)		;ADD APPROPRIATE THING
	OUTCHR 0		;OUTPUT
	CAIE 0," "		;TEST FOR END.
	SOJG 3,SXLOOP		;MORE TO COME
	SUB PP,[XWD 2,2]	;WE'RE DONE, RETURN
	JRSTF @2(PP)
;--------------------------------------------------------------------
;PRINT ' AT USER 000000'
ATUSER:	PUSH PP,0		;SAVE AC 0
	OUTSTR [ASCIZ/ AT USER /]
	PUSH PP,INTPC
	PUSHJ PP,OCTOUT
	OUTSTR [ASCIZ/
/]↔	POP PP,0↔POPJ PP,
;--------------------------------------------------------------------
;DATA STORAGE
ACSAVE:	BLOCK 20
BKPDL:	BLOCK 10

;INTWRD AND INTPC MUST BE IN ORDER OR INTJEN WILL LOSE!
	.INTWRD←←0
	INTFOR <.INTWRD←←.INTWRD!I
>
INTWRD:	.INTWRD
INTPC:	BLOCK 1

PCGO:	BLOCK 1

ILOCK:	BLOCK 1
STAT6:	BLOCK 1

OVFIX:	BLOCK 1
OVOP:	BLOCK 1
OVINST:	BLOCK 1

NOCONT:	BLOCK 1
ALWAYS:	BLOCK 1
OVRGAG:		-1	;SHUT UP !!
ERRTXT:	BLOCK 1
;ROUTINES TO PUSH AND POP ACCUMULATORS.

IFNDEF PUSHIT <
↑↑PUSHIT:
	PUSH P,0	; SAVE 0
	HLRE 0,P	; PICK UP COUNT
	ADDI 0,20	; ADD IN DISPLACEMENT
	XOR 0,P		; IF SIGNS ARE DIFFERENT, NOT ENOUGH STACK
	JUMPGE 0,PUSHOK
	POP P,0		; CAN'T DO IT, LOSE BIG
	OUTSTR [ASCIZ ⊗NOT ENOUGH ROOM TO PUSH ACS!!
⊗]
	SKIPN JOBDDT
	GO [ OUTSTR[ASCIZ⊗YOU LOSE.	⊗]
	       HALT PUSHIT ]
↑↑DDTGO:OUTSTR[ASCIZ⊗YOU'RE IN DDT
⊗]
	POP P,JOBOPC
	GO @JOBDDT
PUSHOK:	POP P,0		; GET BACK 0
	EXCH 0,(P)	;SAVE 0 AND GET RETURN.
	DAC 0,20(P)	;GEE, THIS WAY WE RETURN WITH A POPJ
	MOVEI 0,1(P)
	HRLI 0,1
	BLT 0,17(P)
	ADD P,[XWD 20,20]
	POPJ P,		;RETURN TO SENDER

↑↑POPIT:
	MOVSI 0,-17(P)
	HRRI 0,1
	BLT 0,17
	LAC 0,20(P)
	EXCH 0,(P)
	POPJ P,
>
;TITLE ARITH  -  ARITHMETIC ROUTINES.

	HALFPI↑:	201622077325 ;PI/2
	PI↑:		202622077325 ;PI
	TWOPI↑:		203622077325 ;2*PI

SUBR(SQRT,X)		;SQUARE ROOT OF ABS(X).
COMMENT ⊗------------------------------------------------------------
⊗
	A←←0 ↔ B←←1 ↔ C←←2
	MOVM B,X↔JUMPE B,POP1J.↔PUSHP 2

;LET X=F*(2↑2B) WHERE 0.25<F<1.00 THEN SQRT(X)=SQRT(F)*(2↑B).
	ASHC B,-=27↔SUBI B,201	;GET EXPONENT IN B, FRACTION IN C.
	ROT B,-1		;CUT EXP IN HALF, SAVE ODD BIT
	DAP B,L↔LSH B,-=35	;USE THAT ODD BIT.
	ASH C,-10↔FSC C,177(B)	;0.25 < FRACTION < 1.00

;LINEAR APPROXIMATION TO SQRT(F).
	DAC C,A
	FMP C,[0.8125↔0.578125](B)
	FAD C,[0.302734↔0.421875](B)

;TWO ITERATIONS OF NEWTON'S METHOD.
	LAC B,A
	FDV B,C↔FAD C,B↔FSC C,-1
	FDV A,C↔FADR A,C
     L: FSC A,0↔LAC 1,A↔POPP 2
	POP1J
ENDR SQRT; BGB 28 DECEMBER 1972 -------------------------------------

SUBR(LOG,X)	;NATURAL LOGRITHM.
COMMENT ⊗------------------------------------------------------------
⊗
	MOVM X↔SKIPE 1,0↔CAMN 0,[1.0]↔POP1J
	ASHC 0,-33↔ADDI 0,211000↔MOVSM 0,TMP1#
	MOVSI 0,(-128.5)↔FADM 0,TMP1
	ASH 1,-10↔TLC 1,200000↔FAD 1,[-0.70710678]
	LAC 0,1↔FAD 0,[1.4142135]↔FDV 1,0
	DAC 1,TMP2#↔FMP 1,1
	LAC 0,[0.59897864]↔FMP 0,1
	FAD 0,[0.96147063]↔FMP 0,1
	FAD 0,[2.88539120]↔FMP 0,TMP2↔FAD 0,TMP1
	FMP 0,[0.69314718]↔LAC 1,0↔POP1J
	VAR
ENDR LOG;---------------------------------------------------------
SUBR(SIN,X)
	GO SIN.↔ENDR SIN
SUBR(COS,X)
	GO COS.↔ENDR COS
	
BEGIN SINCOS			;MODIFIED OLDE LIB40 SINE & COSINE - BGB.
	A←←1 ↔ B←←2 ↔ C←←3
↑COS.:	SKIPA A,-1(P)
↑SIN.:	SKIPA A,-1(P)
	FADR  A,HALFPI			;COS(X) = SIN(X+π/2).
	MOVM B,A↔CAMG B,[17B5]↔POP1J	;FOR SMALL X, SIN(X)=X.

;B ← (ABS(X)MODULO 2π)/HALFPI
;C ← QUADRANT 0, 1, 2 OR 3.
	FDVR B,HALFPI
	LAC C,B↔FIX C,233000
	CAILE C,3↔GO[
	TRZ C,3↔FSC C,233
	FSBR B,C↔GO .-3]		;MODULO 2π.
	GO .+1(C)↔GO .+4↔JFCL↔GO[
	FSBRI B,(2.0)↔MOVNS B↔GO .+2]	;SIN(X+π)=SIN(-X)
	FSBRI B,(4.0)			;SIN(X+2π)=SIN(X)
	SKIPGE A↔MOVNS	B		;SIN(-X) = -SIN(X).

;FOR -1 ≤ B ≤ +1 REPRESENTING -π/2 ≤ X ≤ +π/2,
;COMPUTE SINE(X) APPROXIMATION BY TAYLOR SERIES.
	DAC B,C↔FMPR B,B	
	LAC A,[164475536722]↔FMP A,B
	FAD A,[606315546346]↔FMP A,B
	FAD A,[175506321276]↔FMP A,B
	FAD A,[577265210372]↔FMP A,B
	FAD A,HALFPI↔FMPR A,C↔POP1J
	LIT
BEND SINCOS;---------------------------------------------------------
SUBR(ATAN,X)		;ARC TANGENT
COMMENT ⊗------------------------------------------------------------
	IF 0.0 < X ≤ 1.0 THEN ⊂ Z ← X*X;
	RETURN (ATAN(X) = X*(B0+A1/(Z+B1-A2/(Z+B2-A3/(Z+B3)))));⊃;
	IF X>1 THEN ATAN(X) = PI/2 - ATAN(1/X);
	IF X>1 THEN RH(D) =-1, AND LH(D) = -SGN(X)
	IF X<1, THEN RH(D) = 0, AND LH(D) =  SGN(X)
⊗
	A←←1 ↔ B←←2 ↔ C←←3 ↔ D←←4 ↔ E←←5
	LAC	A,X		;PICK UP THE ARGUMENT IN A
ATAN1:	MOVM	B, A		;GET ABSF OF ARGUMENT
	CAMG	B, A1		;IF X<2↑-33, THEN RETURN WITH...
	POP1J		;ATAN(X) = X
	HLLO	D, A		;SAVE SIGN, SET RH(D) = -1
	CAML	B, A2		;IF A>2↑33, THEN RETURN WITH
	GO[LAC A,HALFPI ↔POP1J];	ATAN(X) = PI/2
	MOVSI	C,(<1.0>)	;FORM 1.0 IN C
	CAMG	B, C		;IS ABSF(X)>1.0?
	TRZA	D, -1		;IF B ≤ 1.0, THEN RH(D) = 0
	FDVM	C, B		;B IS REPLACED BY 1.0/B
	TLC	D, (D)		;XOR SIGN WITH > 1.0 INDICATOR

	DAC B,E↔FMP B,B
	LAC C,B↔FAD C,KB3↔LAC A,KA3↔FDVM A,C
	FAD C,B↔FAD C,KB2↔LAC A,KA2↔FDVM A,C
	FAD C,B↔FAD C,KB1↔LAC A,KA1↔FDV  A,C
	FAD A,KB0↔FMP A,E

	TRNE	D, -1		;CHECK > 1.0 INDICATOR
	FSB	A, HALFPI		;ATAN(A) = -(ATAN(1/A)-PI/2)
	SKIPGE	D		;LH(D) = -SGN(B) IF B>1.0
	MOVNS A		;NEGATE ANSWER
	POP1J		;EXIT
A1:	145000000000		;2↑-33
A2:	233000000000		;2↑33

KB0:	176545543401		;0.1746554388
KB1:	203660615617		;6.762139240
KB2:	202650373270		;3.316335425
KB3:	201562663021		;1.448631538

KA1:	202732621643		;3.709256262
KA2:	574071125540		;-7.106760045
KA3:	600360700773		;-0.2647686202
ENDR ATAN;--------------------------------------------------------
SUBR(ATAN2,DY,DX)	;ARC TANGENT (DELTA-Y,DELTA-X)
COMMENT .-----------------------------------------------------------.
; OMEGA ← ATAN2(Y,X).
	Y←←1 ↔ X←←2
	MOVM Y,DY↔MOVM X,DX
	CAMN X,Y↔JUMPE Y,L2
	CAML Y,X↔GO L1

;HORIZONTAL TO π/2; ABS(Y) < ABS(X).
	LAC  Y,DY↔FDVR Y,DX
	PUSH 17,Y↔PUSHJ 17,ATAN		;ARCTAN(Y/X)
	SKIPL DX↔POP2J			;1ST & 2ND QUADRANTS.
	JUMPGE Y,[
	FSBR Y,PI↔POP2J]		;3RD QUADRANT.
	FADR Y,PI↔POP2J			;2ND QUADRANT.

;VERTICAL TO π/2; ABS(X) < ABS(Y).
L1:	MOVN X,DX↔FDVR X,DY
	PUSH 17,X↔PUSHJ 17,ATAN		;ARCTAN(X/Y)
	SKIPG DY↔GO[
	FSB Y,HALFPI↔POP2J]
	FADR Y,HALFPI
L2:	POP2J

ENDR ATAN2;----------------------------------------------------------

SUBR(ASIN,X)	;ARC SINE.
COMMENT .-----------------------------------------------------------.
; ASIN(X)=ATAN(X/SQRT(1-X↑2)).
; GIVEN -1 ≤ X ≤ +1 RETURN -π/2 ≤ ASIN(X) ≤ +π/2.
	A←1 ↔ B←2
	MOVN A,X↔FMPR A,X↔FADRI A,(1.0)
	JUMPE A,[LAC A,HALFPI		;WAS X EITHER -1.0 OR 1.0?
	SKIPGE X↔MOVNS A↔POP1J]
	CALL(SQRT,A)
	LAC B,X↔FDVR B,1↔DAC B,X	;CALCULATE X/SQRT(1-X↑2)
	GO ATAN			;CALCULATE ATAN(SQRT(1-X↑2))
ENDR ASIN;-----------------------------------------------------------

SUBR(ACOS,X)	;ARC COSINE.
COMMENT .-----------------------------------------------------------.
; ACOS(X)= π/2 - ASIN(X).
; GIVEN -1 ≤ X ≤ +1 RETURN 0 ≤ ACOS(X) ≤ +π.
	CALL(ASIN,X)
	MOVNS 1↔FADR 1,HALFPI
	POP1J
ENDR ACOS;--------------------------------------------------------
SUBR(REALI)
COMMENT ⊗------------------------------------------------------------
 <EXPR>		::= <EXPR>+<TERM>|<EXPR>-<TERM>|<TERM>
 <TERM>		::= <TERM>*<PRIMARY>|<TERM>/<PRIMARY>|<PRIMARY>
 <PRIMARY>	::= -<PRIMARY>|(<EXPR>)|π|<REAL NUMBER> ⊗

REAL0:	CALL(TERM)
REAL1:	CAIN 1,"+"↔GO[PUSH P,0
	     CALL(TERM)↔FADR 0,(P)
  	     SUB P,[XWD 1,1]↔GO REAL1]
	CAIN 1,"-"↔GO[PUSH P,0
	     CALL(TERM)↔MOVN 0,0
	     FADR 0,(P)
  	     SUB P,[XWD 1,1]↔GO REAL1]
	CAIN 1,15↔CALL(GETCHL)		;CARRIAGE RETURN - LINE FEED.
	POP0J
;--------------------------------------------------------------------
TERM:	CALL(PRIMARY)
TERM2:	CAIN 1,"*"↔GO[PUSH P,0
	     CALL(PRIMARY)↔FMPR 0,(P)
  	     SUB P,[XWD 1,1]↔GO TERM2 ]
	CAIN 1,"/"↔GO[PUSH P,0
	     CALL(PRIMARY)↔EXCH 0,(P)
	     FDVR 0,(P)
  	     SUB P,[XWD 1,1]↔GO TERM2 ]
	POPJ P,
;--------------------------------------------------------------------
PRIMARY:
BEGIN PRIMARY;-------------------------------------------------------
ITG ←← 0	;INTEGER ACCUMULATION.	 AC-0 RETURNS REAL NUMBER
CHR ←← 1	;CHARACTER JUST SCANNED. AC-1 RETURNS BREAK CHR.
CNT ←← 2	;COUNTER OF DIGITS TO RIGHT OF DECIMAL POINT +1.
FLG ←← 3	;MINUS SIGN FLAG.

	SETZ ITG↔SETZB CNT,FLG				;INITIALIZATION.
L0:	CALL(GETCHL↑)					;FIRST CHARACTER.
	CAIN 1," "↔GO L0				;LEADING BLANKS.
	CAIN 1,"0"↔GO L0				;LEADING ZEROES.
	CAIN 1,"-"↔GO[SETCMM 3↔GO L0]			;UNARY MINUS SIGNS.
	CAIN 1,"π"↔GO[LAC 0,PI↔GO L3]			;PI
	CAIN 1,"("↔GO[PUSH P,FLG↔CALL(REALI)↔POP P,FLG	;PARENTHESES
		CAIN 1,")"↔GO L3
		OUTSTR[ASCIZ/WARNING: MISSING ')'/]↔CRLF
		POPJ P,]
	SKIPA
L1:	CALL(GETCHL)
	CAIE CHR,"."↔GO .+3
	JUMPN CNT,L2		;EXIT IF THIS IS A 2ND DECIMAL POINT.
	AOJA  CNT,L1		;BEGIN COUNT OF DIGITS TO RIGHT OF DECIMAL POINT.

	CAIL CHR,"0"↔CAILE CHR,"9"↔GO L2	;DIGITS FALL THRU.
	SKIPE CNT↔AOS CNT			;COUNT DIGITS RIGHT OF DECIMAL.
	ANDI 1,17↔IMULI =10↔ADD 1↔GO L1		;ACCUMULATE A DIGIT.

L2:	FLOAT↔CAIL CNT,2
	FDVR[1E1↔1E2↔1E3↔1E4↔1E5↔1E6↔1E7↔1E8↔1E9↔1E10]-2(2) ;SCALE MANTISSA.
	CAIN CHR,42↔GO[FDVR[12.0]↔GO L3]	;INCHES ?
	CAIN CHR,"`"↔GO[FMPR[1.74532925E-2]↔GO L3];DEGREES ?
	SKIPA
L3:	CALL(GETCHL)
	SKIPE 3↔MOVNS		;SIGNED.
	POPJ P,
BEND PRIMARY
ENDR REALI;12/16/72(BGB),14-MAR-73(TVR)------------------------------
;TITLE III    - III DISPLAY SUBROUTINES - BGB - JANUARY 1973.

	↓A←1↔↓B←2↔↓C←3

BUFDPY↑: .+2↔=250
	BLOCK =260

DPYBUF↑:DPYBU.↔=2048 
DPYBU.: BLOCK =2048

IGNORE:		0
SIZBRT:		0
DPYCOL:		0
DPYPTR↑:	0
BUFEND:		0
BUFHD:		0↔0		;UPG ARGUMENT. ;ADDRESS ↔ LENGTH.

;VERNIER III TEXT POSITIONING.
	VERNX ←← 14
	VERNY ←← 11

;DISPLAY SAIL STRING.
DPYSST↑: POP 16,1↔POP 16,2↔SKIPGE IGNORE↔POPJ P,
	HRRZS 2			;LENGTH	OF STRING.
	JUMPLE 2,SSRET
	ILDB 3,1
	IDPB 3,DPYPTR
	SOJG 2,.-2
SSRET:	HRRZ 1,DPYPTR
	CAML 1,BUFEND
	SETOM IGNORE
	POPJ P,
;SUBRS DPYSET,DPYBIG,DPYBRT	;Set buffer,char. size, brightness*

SUBR(DPYSET,BUFFER)	;Initialize a display buffer			*
;____________________________________________________________________
	LAC 1,BUFFER↔CDR 2,-1(1)	;BUFFER SIZE.
	ADDI 2,-1(1)↔DAC 2,BUFEND
	ADDI 1,2↔DAC 1,BUFHD		;POINT TO THIRD WORD.
	SETZM IGNORE
	SETZM SIZBRT
CLR2:	LAC A,BUFHD	;BLIT THE BUFFER WITH THE III-TEXT OPCODE 1.
	MOVEI B,1↔DAC B,1(A)
	MOVEI B,2(A)↔HRLI B,1(A)
	BLT B,@BUFEND
	PUSH P,(P)↔GO LV3
ENDR DPYSET

SUBR(DPYBIG,SIZE)	;Set character size
;____________________________________________________________________
;USES AC 1
	LAC A,SIZE↔DPB A,[POINT 3,SIZBRT,27]	;REMEMBER NEW SIZE
	POP1J
ENDR DPYBIG
;____________________________________________________________________

SUBR(DPYBRT,SIZE)	;Set brightness
;USES AC 1
	LAC A,SIZE↔DPB A,[POINT 3,SIZBRT,24]	;REMEMBER NEW BRIGHTNESS
	POP1J
ENDR DPYBRT
;SUBRS AVECT,AIVECT,RVECT,RIVECT	;Vectors
COMMENT ⊗
	The  III display  processor  is  a stored  program  computer,
these  III subroutines  make  a III  program using  only  two display
operations: the  long vector operation  and the  text operation.  The
pointer to the display buffer is  always maintained as a BYTE POINTER
to  the last character displayed.  The flag named  IGNORE is set when
display buffer  overflow occurs  and  all further  display calls  are
ignored  until the buffer  is used.  The III instruction  formats are
given below, unlike  most CPU  (but like must  display processors  of
its day)  the immediate data  fields are in  the left portion  of the
instruction and the opcode in the right.
	TEXT DISPLAY WORD:	 ASCII/ABCDE/ + 1
	LONG VECTOR  WORD:  BYTE(11)X,Y(3)BRT,SIZ(7)OPCODE
The  long vector opcodes appear in the following four lines: ⊗

	SUBR(RIVECT)
		GO RIV.	↔ENDR RIVECT
	SUBR(RVECT)
		GO RV.	↔ENDR RVECT
	SUBR(AIVECT)
		GO AIV.	↔ENDR AIVECT
	SUBR(AVECT)
		GO AV.	↔ENDR AVECT

;USES AC 1-3
;DTYO DEPENDS ON THIS
RIV.:	SKIPA C,[046]		;RELATIVE INVISIBLE VECTOR.
RV.:	MOVEI  C, 006 ↔GO LV0	;RELATIVE   VISIBLE VECTOR.
AIV.:	SKIPA C,[146]		;ABSOLUTE INVISIBLE VECTOR.
AV.:	MOVEI  C, 106		;ABSOLUTE   VISIBLE VECTOR.
	SETZM DPYCOL		;RESET TAB LOCATION

LV0:	SKIPGE IGNORE↔POP2J
LV:	LAC A,-2(P)↔LAC B,-1(P)		;PICKUP X AND Y.
LVC:	DPB A,[POINT 11,C,10]		;PACK X INTO III-WORD.
	DPB B,[POINT 11,C,21]		;PACK Y INTO III-WORD.
	SKIPE A,SIZBRT			;NEW BRIGHTNESS OR SIZE?
	GO [ IOR C,A↔SETZM SIZBRT↔GO LV2]	;YES, SET IT
LV2:	AOS A,DPYPTR↔DAC C,(A)		;PACK WORD INTO III-BUFFER.
LV3:	HRLI A,<(<POINT 7,0,35>)>	;UPDATE DPYPTR...
	DAC A,DPYPTR↔MOVEI A,(A)		;WHICH IS A BYTE-POINTER.
	CAML A,BUFEND↔SETOM IGNORE	;CHECK FOR BUFFER OVERFLOW.
	POP2J
;SUBRS DPYSTR,DTYO,DPYOUT	;Output string,character, POG	*
;--------------------------------------------------------------------

SUBR(DPYSTR,TEXT)
;USES AC 1,3
	LAC 3,TEXT↔HRLI 3,440700
L1:	ILDB 3↔JUMPE POP1J.
	CALL(DTYO,0)↔GO L1
ENDR DPYSTR;---------------------------------------------------------

SUBR(DTYO,CHAR)
;USES AC 1
;DPYSTR DEPENDS ON DTYO NOT CLOBBERING 3
	SKIPE SIZBRT
	GO [ PUSHP 0↔PUSHP 2↔PUSHP 3
	     CALL(RIVECT,[0],[0])
	     POPP 3↔POPP 2↔POPP 0
	     GO .+1]
	LAC 1,CHAR
	CAIN 1,15↔SETOM DPYCOL
	CAIN 1,11↔GO DOTAB
DTYO1:	IDPB 1,DPYPTR↔AOS DPYCOL
	CDR 1,DPYPTR↔CAML 1,BUFEND
	SETOM IGNORE↔POP1J
DOTAB:	CALL(DTYO,[" "])	;We got a tab, put out spaces until
	LAC 1,DPYCOL		;column is divisible by 8
	TRNE 1,7↔GO DOTAB
	CDR 1,DPYPTR
	POP1J
ENDR DTYO;-----------------------------------------------------------

SUBR(DPYOUT,POG)
COMMENT ⊗------------------------------------------------------------
⊗↔	SKIPN A,BUFHD↔GO L1
	LAC 2,DPYPTR↔DAC 2,-2(1)
	MOVEI 2,2(2)↔SUB 2,1↔DAC 2,-1(1)

L1:	CDR B,DPYPTR↔SUB B,BUFHD		;BUFFER LENGTH.
	AOS B↔DAC B,BUFHD+1

	MOVM A,POG↔DPB A,[POINT 4,UPGOP,12]	;GLASS TO AC FIELD.
	XCT UPGOP
	POP1J
UPGOP:	703B8+BUFHD
ENDR DPYOUT;---------------------------------------------------------
;SUBRS OCTDPY,DECDPY,FLODPY	;Numeric display
;--------------------------------------------------------------------

SUBR(OCTDPY,INTEGER)	;OCTAL NUMBER DISPLAY.
	Q←15 ↔ N←13
	JFCL↔GO L2
	LAC 14,INTEGER↔LAC Q,[POINT 3,14,-1]↔MOVEI N,6
L1:	ILDB Q↔IORI 60↔CALL(DTYO,0)↔SOJG N,L1
	CALL(DTYO,[" "])
L2:	LAC 14,INTEGER↔LAC Q,[POINT 3,14,17]↔MOVEI N,6
L3:	ILDB Q↔IORI 60↔CALL(DTYO,0)↔SOJG N,L3
	POP1J
ENDR OCTDPY;3/25/73(BGB)---------------------------------------------

DECDPY↑:;(INTEGER)	;DECIMAL NUMBER DISPLAY.
BEGIN DECDPY
	LAC 1,-1(P)↔POP P,-1(P)		;FETCH ARG AND LAC RET. ADR.
L1:	JUMPGE 1,L2			;TEST FOR NEGATIVE NUMBER.
	MOVM 2,1↔CALL(DTYO,["-"])	;PRINT MINUS SIGN.
	LAC 1,2
L2:	IDIVI 1,12↔PUSH P,2		;MODULO TEN AND SAVE.
	SKIPE 1↔PUSHJ P,L2		;TEST FOR DONE.
	POP P,1↔ADDI 1,60↔CALL(DTYO,1)	;RESTORE & PRINT.
	POPJ P,
BEND DECDPY;12/17/72(BGB)--------------------------------------------

SUBR(FLODPY,FLONUM,PLACES)	;FLOATING NUMBER DISPLAY.
	LAC FLONUM
	JUMPL[CALL(DTYO,["-"])↔MOVM FLONUM↔GO .+1]
	MOVM 2,PLACES↔CAILE 2,6↔MOVEI 2,6↔DAC 2,PLACES
	FMPR[1.↔10.↔100.↔1000.↔10000.↔100000.↔1000000.](2)↔FIXX
	IDIV[=1↔=10↔=100↔=1000↔=10000↔=100000↔=1000000](2)
	PUSHP 1↔CALL(DECDPY,0)↔POPP 0
	LAC 2,PLACES
	ADD[=1↔=10↔=100↔=1000↔=10000↔=100000↔=1000000](2)
	PUSHP DPYPTR↔CALL(DECDPY,0)↔POPP 1
	MOVEI "."↔IDPB 0,1
	POP2J
ENDR FLODPY;12/17/72(BGB)--------------------------------------------
END