perm filename EUCLID[GEM,BGB]1 blob
sn#032385 filedate 1973-04-01 generic text, type T, neo UTF8
00100 TITLE EUCLID - EUCLIDEAN TRANSFORMATIONS - JULY 1972.
00200
00300 EXTERN ECW,ECCW,OTHER
00400 EXTERN BGET,FCW,FCCW,VCW,VCCW
00500 EXTERN MKCOPY,MKFRAME,KLNODE
00600
00700 COMMENT/
00800 CONTENTS:
00900
01000 FRAME ← TRANSLATE(REFRAM+OBJECT,DX,DY,DZ);
01100 FRAME ← ROTATE(REFRAM+OBJECT,ABOUTX,ABOUTY,ABOUTZ);
01200 FRAME ← SHRINK(REFRAM+OBJECT,KX,KY,KZ);
01300 NORM(FRAME);
01400 ORTHO1(FRAME);
01500 SQRT(X);
01600 DISTANCE(V1,V2);
01700 SIN(X);
01800 COS(X);
01900 ROTOR; V,Q.
02000 APTRAN(CBFEV,ETRAN);
02100 INTRAN(TRAN);
02200 /
00100 SUBR(TRANSLATE)REFRAM+OBJECT,DX,DY,DZ-----------------------------
00200 BEGIN TRANSLATE; OBJECT TRANSLATION WITH RESPECT TO REFRAM.
00300
00400 CALL(MKFRAME)
00500 LAC ARG3↔DAC XWC(1)
00600 LAC ARG2↔DAC YWC(1)
00700 LAC ARG1↔DAC ZWC(1)
00800
00900 ↑QTRAN: DAC 1,TMP1
01000 LACM 2,ARG4↔CDR 2,2↔DAC 2,OBJECT
01100 NIP 1,ARG4↔SKIPGE 1↔GO[
01200 SETZ 1,↔JUMPE 2,.+1
01300 CALL(BGET,OBJECT)
01400 FRAME 1,1↔GO .+1]
01500 DAC 1,REFRAM
01600
01700 LAC 1,TMP1↔SKIPN REFRAM↔GO L1
01800 L0: SETQ(TMP2,{MKCOPY,REFRAM})
01900 CALL(INTRAN,TMP2)
02000 CALL(APTRAN,TMP2,TMP1)
02100 CALL(APTRAN,TMP2,REFRAM)
02200 CALL(KLNODE,TMP1)
02300 LAC 1,TMP2↔DAC 1,TMP1
02400
02500 L1: SKIPN OBJECT↔POP4J ;RETURN TRANSFORMATION.
02600 CALL(APTRAN,OBJECT,TMP1)
02700 CALL(KLNODE,TMP1)
02800 LAC 1,OBJECT↔POP4J ;RETURN OBJECT.
02900
03000 DECLARE{TMP1,TMP2,REFRAM,OBJECT}
03100 BEND TRANSLATE; BGB 18 MARCH 1973 --------------------------------
00100 SUBR(ROTATE)REFRAM+OBJECT,ABOUTX,ABOUTY,ABOUTZ--------------------
00200 BEGIN ROTATE; OBJECT ROTATION WITH RESPECT TO REFRAM.
00300
00400 L1: DZM TMP1↔SKIPN ARG3↔GO L2↔SETQ(TMP1,{MKFRAME})
00500 CALL(COS,ARG3)↔LAC 2,TMP1↔DAC 1,JY(2)↔DAC 1,KZ(2)
00600 CALL(SIN,ARG3)↔LAC 2,TMP1↔DAC 1,JZ(2)↔DACN 1,KY(2)
00700
00800 L2: DZM TMP2↔SKIPN ARG2↔GO L3↔SETQ(TMP2,{MKFRAME})
00900 CALL(COS,ARG2)↔LAC 2,TMP2↔DAC 1,IX(2)↔DAC 1,KZ(2)
01000 CALL(SIN,ARG2)↔LAC 2,TMP2↔DAC 1,KX(2)↔DACN 1,IZ(2)
01100
01200 L3: DZM TMP3↔SKIPN ARG1↔GO L4↔SETQ(TMP3,{MKFRAME})
01300 CALL(COS,ARG1)↔LAC 2,TMP3↔DAC 1,IX(2)↔DAC 1,JY(2)
01400 CALL(SIN,ARG1)↔LAC 2,TMP3↔DAC 1,IY(2)↔DACN 1,JX(2)
01500
01600 L4: SKIPN 1,TMP2↔GO L5 ;TMP1 ← TMP1 * TMP2.
01700 SKIPN TMP1↔GO[DAC 1,TMP1↔GO L5]
01800 CALL(APTRAN,TMP1,TMP2)
01900 CALL(KLNODE,TMP2)
02000
02100 L5: SKIPN 1,TMP3↔GO L6 ;TMP1 ← TMP1 * TMP3.
02200 SKIPN TMP1↔GO[DAC 1,TMP1↔GO L6]
02300 CALL(APTRAN,TMP1,TMP3)
02400 CALL(KLNODE,TMP3)
02500
02600 L6: SKIPN 1,TMP1↔CALL(MKFRAME) ;IDENTITY.
02700 GO QTRAN
02800
02900 DECLARE{TMP1,TMP2,TMP3,REFRAM,OBJECT}
03000 BEND ROTATE; BGB 18 MARCH 1973 -----------------------------------
03100
03200
03300 SUBR(SHRINK)REFRAM+OBJECT,KX,KY,KZ--------------------------------
03400 ;DILATION-REFLECTION WITH RESPECT TO REFRAM.
03500
03600 CALL(MKFRAME)
03700 SKIPN 2,ARG3↔SLACI 2,(1.0)↔DAC 2,IX(1)
03800 SKIPN 2,ARG2↔SLACI 2,(1.0)↔DAC 2,JY(1)
03900 SKIPN 2,ARG1↔SLACI 2,(1.0)↔DAC 2,KZ(1)
04000 GO QTRAN
04100
04200 ;SHRINK BGB 18 MARCH 1973 ----------------------------------------
00100 SUBR(NORM)FRAME---------------------------------------------------
00200 BEGIN NORM; NORMALIZE AN ORIENTATION MATRIX.
00300
00400 ;ACCUMULATORS:
00500 ; 05 06 07 IX IY IZ
00600 ; 10 11 12 JX JY JZ
00700 ; 13 14 15 KX KY KZ
00800 SAVAC(15)
00900 SLAC ARG1↔LAPI 5↔BLT 15
01000
01100 ; R ← SQRT(A↑2+B↑2+C↑2); A←A/R; B←B/R; C←C/R;
01200 FOR Q IN (5,10,13){
01300 LACM 1,Q↔CAMG 1,[1.0E-8]↔SETZB 1,Q↔FMPR 1,1
01400 LACM 1+Q↔CAMG 0,[1.0E-8]↔SETZB 1+Q↔FMPR↔FADR 1,0
01500 LACM 2+Q↔CAMG 0,[1.0E-8]↔SETZB 2+Q↔FMPR↔FADR 1,0
01600 SKIPE 1↔CAMN 1,[1.0]↔GO .+6↔CALL(SQRT,1)
01700 FDVR Q,1↔FDVR Q+1,1↔FDVR Q+2,1}
01800
01900 ;PUT'EM DOWN.
02000 LAC 1,ARG1
02100 SLACI 5↔LAPI IX(1)↔BLT KZ(1)
02200 GETAC(15)↔POP1J↔VAR
02300
02400 BEND NORM; BGB 14 JANUARY 1973 -----------------------------------
02500
00100 SUBR(ORTHO2)FRAME-------------------------------------------------
00200 BEGIN ORTHO2; ACCEPT I; K' ← I CROSS J; J' ← K CROSS I;
00300 LAC 1,ARG1
00400 DZM KX(1)↔DZM KY(1)↔DZM KZ(1)
00500 CALL(NORM,1)
00600 SLAC ARG1↔LAPI 1↔BLT 9
00700 LAC 12,4↔LAC 13,5↔LAC 14,6 ;SAVE J VECTOR.
00800
00900 ;VECTOR-K ← VECTOR-I CROSS VECTOR-J.
01000
01100 LAC 2↔FMP 6↔DAC 7
01200 LAC 5↔FMP 3↔FSB 7,
01300 LAC 4↔FMP 3↔DAC 8
01400 LAC 1↔FMP 6↔FSB 8,
01500 LAC 1↔FMP 5↔DAC 9
01600 LAC 4↔FMP 2↔FSB 9,
01700
01800 ;VECTOR-J ← VECTOR-K CROSS VECTOR-I.
01900
02000 LAC 8↔FMP 3↔DAC 4
02100 LAC 2↔FMP 9↔FSB 4,
02200 LAC 1↔FMP 9↔DAC 5
02300 LAC 7↔FMP 3↔FSB 5,
02400 LAC 7↔FMP 2↔DAC 6
02500 LAC 1↔FMP 8↔FSB 6,
02600
02700 LAC 15,ARG1↔SLACI 1
02800 LAPI IX(15)↔BLT KZ(15)
02900 POP1J
03000
03100 BEND ORTHO2;BGB 30 MARCH 1973 ------------------------------------
03200
03300
03400 SUBR(DETERM)FRAME-------------------------------------------------
03500 SLAC ARG1↔LAPI 1↔BLT 9
03600 LAC 5↔FMP 9↔LAC 12,
03700 LAC 6↔FMP 8↔FSB 12,↔FMP 1,12
03800 LAC 6↔FMP 7↔LAC 12,
03900 LAC 4↔FMP 9↔FSB 12,↔FMP 2,12↔FAD 1,2
04000 LAC 4↔FMP 8↔LAC 12,
04100 LAC 5↔FMP 7↔FSB 12,↔FMP 3,12↔FAD 1,3↔POP1J
04200 ;DETERM - BGB 1 APRIL 1973 ---------------------------------------
00100 SUBR(ANGL3V)V1,V2,V3 ---------------------------------------------
00200 BEGIN ANGL3V; ANGLE V1,V2,V3 CCW; RETURNS VALUE 0 TO 2π.
00300
00400 v1 ←← 13
00500 v2 ←← 14
00600 v3 ←← 15
00700
00800 ;DETERMINE WHETHER THE ANGLE IS MORE OR LESS THAN PI.
00900
01000 LAC V1,ARG3↔SLACI XWC(V1)↔LAPI 1↔BLT 3
01100 LAC V2,ARG2↔SLACI XWC(V2)↔LAPI 4↔BLT 6
01200 LAC V3,ARG1↔SLACI XWC(V3)↔LAPI 7↔BLT 9
01300 FSBR 1,4↔FSBR 2,5↔FSBR 3,6 ;V1' ← (V1-V2).
01400 FSBR 7,4↔FSBR 8,5↔FSBR 9,6 ;V3' ← (V3-V2).
01500 LAC 2↔FMP 9↔LAC 4,↔LAC 3↔FMP 8↔FSB 4, ;V2' ← (V1 X V3).
01600 LAC 3↔FMP 7↔LAC 5,↔LAC 1↔FMP 9↔FSB 5,
01700 LAC 1↔FMP 8↔LAC 6,↔LAC 2↔FMP 7↔FSB 6,
01800 FADR 1,4↔FADR 2,5↔FADR 3,6 ;V1" ← (V1'+V2').
01900 FADR 7,4↔FADR 8,5↔FADR 9,6 ;V3" ← (V3'+V2').
02000
02100 ;determ negative indicates ccw order, 0 to π.
02200 ;determ positive indicates cw order, π to 2π.
02300 CALL({DETERM+3},0)
02400 SKIPL 1↔SKIPA 1,PI↔SETZ 1,↔PUSH P,1
02500
02600 ;COSINE LAW.
02700 CALL(DISTANCE,V2,V1)↔PUSH P,1
02800 CALL(DISTANCE,V2,V3)↔PUSH P,1
02900 CALL(DISTANCE,V1,V3)
03000 FMPR 1,1↔MOVNS 1
03100 POP P,2↔LAC 2↔FMPR 2,2
03200 POP P,3↔FMP 3↔FMPR 3,3
03300 FSC 1↔FADR 1,2↔FADR 1,3
03400 FDVR 1,0↔CALL(ACOS,1)
03500 POP P,0↔FADR 1,0↔POP3J
03600 BEND ANGL3V; BGB 1 APRIL 1973 ------------------------------------
03700
03800 SUBR(ATEST)FACE
03900 BEGIN ATEST
04000 ACCUMULATORS{F,E,V1,V2,V3}
04100 LAC F,ARG1
04200 PED E,F
04300 SETQ(V1,{VCW,E,F})
04400 SETQ(V2,{VCCW,E,F})
04500 SETQ(E,{ECCW,E,F})
04600 SETQ(V3,{VCCW,E,F})
04700 CALL(ANGL3V,V1,V2,V3)
04800 FMP 1,[180.0]
04900 FDVR 1,PI
05000 POP1J
05100 BEND ATEST
00100 SUBR(ORTHO1)FRAME-------------------------------------------------
00200 BEGIN ORTHO1; ORTHOGONIZE AN ORIENTATION MATRIX.
00300 ;IT IS ASSUMED THAT THE ROW VECTORS ARE UNIT VECTORS.
00400
00500 X←←0 ↔ Y←←1 ↔ Z←←2 ;ADDRESS DISPLACEMENTS.
00600 Q←←9 ↔ R←←13 ↔ A←←14 ↔ B←←15 ;ACCUMULATORS.
00700 SAVAC(15)
00800 SETOM FLG# ;FIRST TIME THRU FLAG.
00900 L0: LAC R,ARG1
01000 SLACI Q,IX(R)↔BLT Q,KZ ;FIRST NINE ACCUMULATORS.
01100
01200 ;DOT EACH ROW VECTOR INTO THE NEXT ROW.
01300 FMPR IX,JX↔FMPR IY,JY↔FMPR IZ,JZ
01400 FADR IX,IY↔FADR IX,IZ
01500 FMPR JX,KX↔FMPR JY,KY↔FMPR JZ,KZ
01600 FADR JX,JY↔FADR JX,JZ
01700 FMPR KX,IX(R)↔FMPR KY,IY(R)↔FMPR KZ,IZ(R)
01800 FADR KX,KY↔FADR KX,KZ
01900
02000 ;TAKE ABSOLUTE VALUES AND FIND THE WORST TOTAL COSINE.
02100 MOVMS IX↔MOVMS JX↔MOVMS KX
02200 LAC Q,KX↔FADR KX,JX↔FADR JX,IX↔FADR Q,IX
02300 EXCH Q,JX↔SETZM SIGN#
02400 LACI 1,IX(R)↔LACI 2,JX(R)↔LACI 3,KX(R) ;GET ROW POINTERS.
02500 CAML Q,IX↔GO .+4
02600 EXCH 2,1↔EXCH Q,IX↔SETCMM SIGN ;GET 2 BIGGER THAN 1.
02700 CAML KX,Q↔GO .+4
02800 EXCH 3,2↔EXCH KX,Q↔SETCMM SIGN ;GET 3 BIGGER THAN 2.
02900 CAMG KX,[0.00001]↔GO L1 ;GOOD ENUF FOR GOVERNMENT WORK.
03000
03100 ;STRAIGHTEN UP THE WORST VECTOR.
03200 LAC A,Y(1)↔FMPR A,Z(2)
03300 LAC B,Y(2)↔FMPR B,Z(1)↔FSBR A,B↔DAC A,X(3)
03400 LACM A,A↔CAMG A,[1.0E-8]↔SETZM X(3)
03500 LAC A,X(2)↔FMPR A,Z(1)
03600 LAC B,X(1)↔FMPR B,Z(2)↔FSBR A,B↔DAC A,Y(3)
03700 LACM A,A↔CAMG A,[1.0E-8]↔SETZM Y(3)
03800 LAC A,X(1)↔FMPR A,Y(2)
03900 LAC B,X(2)↔FMPR B,Y(1)↔FSBR A,B↔DAC A,Z(3)
04000 LACM A,A↔CAMG A,[1.0E-8]↔SETZM Z(3)
04100 SKIPE SIGN↔GO[MOVNS X(3)↔MOVNS Y(3)↔MOVNS Z(3)↔GO .+1]
04200 SKIPN FLG↔GO L1↔SETZM FLG↔GO L0
04300 L1: GETAC(15)↔POP1J↔LIT
04400
04500 BEND ORTHO1; BGB 14 JANUARY 1973 ---------------------------------
00100 SUBR(SQRT)X ------------------------------------------------------
00200 BEGIN SQRT;MODIFIED OLDE LIB40 SQUARE ROOT.
00300 A←←0 ↔ B←←1 ↔ C←←2
00400 LACM B,ARG1↔JUMPE B,POP1J.↔PUSH P,2
00500
00600 ;LET X=F*(2↑2B) WHERE 0.25<F<1.00 THEN SQRT(X)=SQRT(F)*(2↑B).
00700 ASHC B,-=27↔SUBI B,201 ;GET EXPONENT IN B, FRACTION IN C.
00800 ROT B,-1 ;CUT EXP IN HALF, SAVE ODD BIT
00900 DAP B,L↔LSH B,-=35 ;USE THAT ODD BIT.
01000 ASH C,-10↔FSC C,177(B) ;0.25 < FRACTION < 1.00
01100
01200 ;LINEAR APPROXIMATION TO SQRT(F).
01300 DAC C,A
01400 FMP C,[0.8125↔0.578125](B)
01500 FAD C,[0.302734↔0.421875](B)
01600
01700 ;TWO ITERATIONS OF NEWTON'S METHOD.
01800 LAC B,A
01900 FDV B,C↔FAD C,B↔FSC C,-1
02000 FDV A,C↔FADR A,C
02100 L: FSC A,0↔LAC 1,A↔POP P,2
02200 POP1J↔LIT
02300 BEND SQRT; BGB 28 DECEMBER 1972 ----------------------------------
02400
02500 SUBR(DISTAN)V1,V2-------------------------------------------------
02600 BEGIN DISTAN; DISTANCE BETWEEN TWO VERTICES.
02700 LAC 1,ARG1↔LAC 2,ARG2
02800 LAC XWC(1)↔FSBR XWC(2)↔FMPR↔DAC 3
02900 LAC YWC(1)↔FSBR YWC(2)↔FMPR↔FADRM 3
03000 LAC ZWC(1)↔FSBR ZWC(2)↔FMPR↔FADR 3
03100 CALL(SQRT,0)↔POP2J
03200 BEND DISTAN; BGB 10 FEBRUARY 1973 --------------------------------
00100 INTERN SIN,COS;---------------------------------------------------
00200 BEGIN SINCOS;MODIFIED OLDE LIB40 SINE & COSINE - BGB.
00300 A←←1 ↔ B←←2 ↔ C←←3
00400 ↑COS: SKIPA A,ARG1
00500 ↑SIN: SKIPA A,ARG1
00600 FADR A,HALFPI ;COS(X) = SIN(X+π/2).
00700 MOVM B,A↔CAMG B,[17B5]↔POP1J ;FOR SMALL X, SIN(X)=X.
00800
00900 ;B ← (ABS(X)MODULO 2π)/HALFPI
01000 ;C ← QUADRANT 0, 1, 2 OR 3.
01100 FDVR B,HALFPI
01200 LAC C,B↔FIX C,233000
01300 CAILE C,3↔GO[
01400 TRZ C,3↔FSC C,233
01500 FSBR B,C↔GO .-3] ;MODULO 2π.
01600 GO .+1(C)↔GO .+4↔JFCL↔GO[
01700 FSBRI B,(2.0)↔MOVNS B↔GO .+2] ;SIN(X+π)=SIN(-X)
01800 FSBRI B,(4.0) ;SIN(X+2π)=SIN(X)
01900 SKIPGE A↔MOVNS B ;SIN(-X) = -SIN(X).
02000
02100 ;FOR -1 ≤ B ≤ +1 REPRESENTING -π/2 ≤ X ≤ +π/2,
02200 ;COMPUTE SINE(X) APPROXIMATION BY TAYLOR SERIES.
02300 DAC B,C↔FMPR B,B
02400 LAC A,[164475536722]↔FMP A,B
02500 FAD A,[606315546346]↔FMP A,B
02600 FAD A,[175506321276]↔FMP A,B
02700 FAD A,[577265210372]↔FMP A,B
02800 FAD A,HALFPI↔FMPR A,C↔POP1J
02900 LIT
03000 BEND;-------------------------------------------------------------
03100 INTERN HALFPI,PI,TWOPI
03200 HALFPI: 201622077325 ;PI/2
03300 PI: 202622077325 ;PI
03400 TWOPI: 203622077325 ;2*PI
00100 SUBR(ACOS)--------------------------------------------------------
00200 ;ACOS(X)= π/2 - ASIN(X).
00300 ;GIVEN -1 ≤ X ≤ +1 RETURN 0 ≤ ACOS(X) ≤ +π.
00400 PUSH 17,ARG1↔PUSHJ 17,ASIN
00500 MOVNS 1↔FADR 1,HALFPI↔POP1J
00600 ;-----------------------------------------------------------------
00700
01000 SUBR(ASIN)--------------------------------------------------------
01100 BEGIN ASIN
01110 ;ASIN(X)=ATAN(X/SQRT(1-X↑2)).
01155 ;GIVEN -1 ≤ X ≤ +1 RETURN -π/2 ≤ ASIN(X) ≤ +π/2.
01200 A←1 ↔ B←2
01300 LACN A,ARG1↔FMPR A,ARG1↔FADRI A,(1.0)
01400 JUMPE A,[ ;WAS X EITHER -1.0 OR 1.0?
01500 LAC A,HALFPI
01600 SKIPGE ARG1
01700 MOVNS A↔POP1J]
01800 PUSH 17,A↔PUSHJ 17,SQRT
01900 LAC B,ARG1↔FDVR B,1↔DAC B,ARG1 ;CALCULATE X/SQRT(1-X↑2)
02000 GO ATAN ;CALCULATE ATAN(SQRT(1-X↑2))
02100 BEND;-------------------------------------------------------------
02200
02300 SUBR(LOG)---------------------------------------------------------
02400 BEGIN LOG
02500 MOVM ARG1↔SKIPE 1,0↔CAMN 0,[1.0]↔POP1J
02600 ASHC 0,-33↔ADDI 0,211000↔MOVSM 0,TMP1#
02700 MOVSI 0,(-128.5)↔FADM 0,TMP1
02800 ASH 1,-10↔TLC 1,200000↔FAD 1,[-0.70710678]
02900 LAC 0,1↔FAD 0,[1.4142135]↔FDV 1,0
03000 DAC 1,TMP2#↔FMP 1,1
03100 LAC 0,[0.59897864]↔FMP 0,1
03200 FAD 0,[0.96147063]↔FMP 0,1
03300 FAD 0,[2.88539120]↔FMP 0,TMP2↔FAD 0,TMP1
03400 FMP 0,[0.69314718]↔LAC 1,0↔POP1J
03500 LIT↔VAR
03600 BEND;-------------------------------------------------------------
00010 SUBR(ATAN)--------------------------------------------------------
00020 BEGIN ATAN
00100 ;ATAN(X) = X*(B0+A1 / (Z+B1-A2 / (Z+B2-A3 / (Z+B3))) )
00200 ;WHERE Z=X↑2, IF 0<X<=1
00300 ;IF X>1, THEN ATAN(X) = PI/2 - ATAN(1/X)
00400 ;IF X>1, THEN RH(D) =-1, AND LH(D) = -SGN(X)
00500 ;IF X<1, THEN RH(D) = 0, AND LH(D) = SGN(X)
00800 A←←1 ↔ B←←2 ↔ C←←3 ↔ D←←4 ↔ E←←5
00900 LAC A,ARG1 ;PICK UP THE ARGUMENT IN A
01000 ATAN1: LACM B, A ;GET ABSF OF ARGUMENT
01100 CAMG B, A1 ;IF X<2↑-33, THEN RETURN WITH...
01200 POP1J ;ATAN(X) = X
01300 HLLO D, A ;SAVE SIGN, SET RH(D) = -1
01400 CAML B, A2 ;IF A>2↑33, THEN RETURN WITH
01500 GO[LAC A,HALFPI ↔POP1J]; ATAN(X) = PI/2
01600 MOVSI C, 201400 ;FORM 1.0 IN C
01700 CAMG B, C ;IS ABSF(X)>1.0?
01800 TRZA D, -1 ;IF B ≤ 1.0, THEN RH(D) = 0
01900 FDVM C, B ;B IS REPLACED BY 1.0/B
02000 TLC D, (D) ;XOR SIGN WITH > 1.0 INDICATOR
02100
02200 DAC B,E↔FMP B,B
02300 LAC C,B↔FAD C,KB3↔LAC A,KA3↔FDVM A,C
02400 FAD C,B↔FAD C,KB2↔LAC A,KA2↔FDVM A,C
02500 FAD C,B↔FAD C,KB1↔LAC A,KA1↔FDV A,C
02600 FAD A,KB0↔FMP A,E
02700
02800 TRNE D, -1 ;CHECK > 1.0 INDICATOR
02900 FSB A, HALFPI ;ATAN(A) = -(ATAN(1/A)-PI/2)
03000 SKIPGE D ;LH(D) = -SGN(B) IF B>1.0
03100 MOVNS A ;NEGATE ANSWER
03200 POP1J ;EXIT
03300 A1: 145000000000 ;2↑-33
03400 A2: 233000000000 ;2↑33
03500
03600 KB0: 176545543401 ;0.1746554388
03700 KB1: 203660615617 ;6.762139240
03800 KB2: 202650373270 ;3.316335425
03900 KB3: 201562663021 ;1.448631538
04000
04100 KA1: 202732621643 ;3.709256262
04200 KA2: 574071125540 ;-7.106760045
04300 KA3: 600360700773 ;-0.2647686202
04400 BEND ATAN;--------------------------------------------------------
00100 SUBR(ATAN2)-------------------------------------------------------
00200 BEGIN ATAN2
00300
00400 ; OMEGA ← ATAN2(Y,X).
00500 Y←←1 ↔ X←←2
00600 LACM Y,ARG2↔LACM X,ARG1
00700 CAML Y,X↔GO L1
00800
00900 ;HORIZONTAL TO π/2; ABS(Y) < ABS(X).
01000 LAC Y,ARG2↔FDVR Y,ARG1
01100 PUSH 17,Y↔PUSHJ 17,ATAN ;ARCTAN(Y/X)
01200 SKIPL ARG1↔POP2J ;1ST & 2ND QUADRANTS.
01300 JUMPGE Y,[
01400 FSBR Y,PI↔POP2J] ;3RD QUADRANT.
01500 FADR Y,PI↔POP2J ;2ND QUADRANT.
01600
01700 ;VERTICAL TO π/2; ABS(X) < ABS(Y).
01800 L1: LACN X,ARG1↔FDVR X,ARG2
01900 PUSH 17,X↔PUSHJ 17,ATAN ;ARCTAN(X/Y)
02000 SKIPG ARG2↔GO[
02100 FSB Y,HALFPI↔POP2J]
02200 FADR Y,HALFPI
02300 POP2J
02400
02500 BEND ATAN2;-------------------------------------------------------
00100 ROTOR:;-----------------------------------------------------------
00200 BEGIN ROTOR
00300 ;APTRAN'S INNER MOST SUBROUTINE.
00400 ;EXPECTS ARGUMENTS IN V AND Q. CLOBBERS 1,2,X,Y,Z.
00500 ;
00600 ; X ← XWC(V);
00700 ; Y ← YWC(V);
00800 ; Z ← ZWC(V);
00900 ;
01000 ; XWC(V) ← X*IX(Q) + Y*JX(Q) + Z*KX(Q) + XWC(Q);
01100 ; YWC(V) ← X*IY(Q) + Y*JY(Q) + Z*KZ(Q) + YWC(Q);
01200 ; ZWC(V) ← X*IZ(Q) + Y*JZ(Q) + Z*KZ(Q) + ZWC(Q);
01300 ;
01400 ACCUMULATORS{B,F,E,V,X,Y,Z,Q}
01500
01600 LAC X,XWC(V)↔LAC Y,YWC(V)↔LAC Z,ZWC(V)
01700
01800 LAC 1,IX(Q)↔CAMN 1,[1.0]↔SKIPA 1,X↔FMPR 1,X
01900 SKIPE 2,JX(Q)↔GO[FMPR 2,Y↔FADR 1,2↔GO .+1]
02000 SKIPE 2,KX(Q)↔GO[FMPR 2,Z↔FADR 1,2↔GO .+1]
02100 SKIPE 2,XWC(Q)↔FADR 1,2↔DAC 1,XWC(V)
02200
02300 LAC 1,JY(Q)↔CAMN 1,[1.0]↔SKIPA 1,Y↔FMPR 1,Y
02400 SKIPE 2,IY(Q)↔GO[FMPR 2,X↔FADR 1,2↔GO .+1]
02500 SKIPE 2,KY(Q)↔GO[FMPR 2,Z↔FADR 1,2↔GO .+1]
02600 SKIPE 2,YWC(Q)↔FADR 1,2↔DAC 1,YWC(V)
02700
02800 LAC 1,KZ(Q)↔CAMN 1,[1.0]↔SKIPA 1,Z↔FMPR 1,Z
02900 SKIPE 2,JZ(Q)↔GO[FMPR 2,Y↔FADR 1,2↔GO .+1]
03000 SKIPE 2,IZ(Q)↔GO[FMPR 2,X↔FADR 1,2↔GO .+1]
03100 SKIPE 2,ZWC(Q)↔FADR 1,2↔DAC 1,ZWC(V)
03200
03300 POP0J
03400 BEND ROTOR; BGB 18 MARCH 1973 ------------------------------------
00100 SUBR(APTRAN)OBJECT,TRAN-------------------------------------------
00200 BEGIN APTRAN; APPLY EUCLIDEAN TRANSFORMATION TO THE OBJECT.
00300 ACCUMULATORS{B,F,E,V,X,Y,Z,TRN,N,OBJ,E0}
00400 SKIPN TRN,ARG1↔POP2J
00500
00600 ;BRANCH ON TYPE OF OBJECT.
00700 LAC OBJ,ARG2
00800 LACM 1,(OBJ)↔JUMPE 1,LROTA
00900 TLNE 1,(1B9)↔GO LROTA ;FRAME.
01000 ANDI 1,17
01100 CAIN 1,$BODY↔GO BROTA ;BODY.
01200 CAIN 1,$CAMERA↔GO CROTA ;CAMERA.
01300 CAIN 1,$FACE↔GO FROTA ;FACE.
01400 CAIN 1,$EDGE↔GO EROTA ;EDGE.
01500 CAIN 1,$VERT↔GO VROTA ;VERT.
01600 POP2J
01700
01800 LROTA: SKIPA V,OBJ ;FRAME CASE.
01900 CROTA: FRAME V,OBJ ;CAMERA CASE.
02000
02100 CALL(ROTOR)
02200 PUSH P,XWC(TRN)↔PUSH P,YWC(TRN)↔PUSH P,ZWC(TRN)
02300 DZM XWC(TRN)↔DZM YWC(TRN)↔DZM ZWC(TRN)
02400 ADDI V,3↔CALL(ROTOR)
02500 ADDI V,3↔CALL(ROTOR)
02600 ADDI V,3↔CALL(ROTOR)
02700 POP P,ZWC(TRN)↔POP P,YWC(TRN)↔POP P,XWC(TRN)
02800 POP2J
00100 ;BODY ROTATION.
00200 BROTA: LAC B,OBJ
00300 TESTZ B,BDVBIT↔GO L2 ;DON'T MOVE VERTICES.
00400 LAC V,B ;1ST VERTEX.
00500 L1: PVT V,V
00600 CAMN V,OBJ↔GO L2 ;SKIP WHEN VERTEX.
00700 CALL(ROTOR)↔GO L1 ;ROTATE VERTEX.
00800
00900 L2: LAC B,OBJ
01000 TESTZ B,BDLBIT↔GO L3 ;DON'T MOVE FRAME.
01100 FRAME V,B↔SKIPN V↔GO L3
01200 DAC V,TMP#↔PUSH P,B
01300 CALL(APTRAN,V,TRN) ;BODY'S FRAME.
01400 CALL(NORM,TMP#)
01500 CALL(ORTHO1,TMP#)
01600 POP P,B
01700
01800 ;PARTS OF THIS BODY.
01900 L3: TESTZ B,BDPBIT↔POP2J ;DON'T MOVE PARTS.
02000 SON N,B↔JUMPE N,POP2J.
02100 L4: PUSH P,N
02200 CALL(APTRAN,N,TRN)
02300 POP P,N↔LAC B,ARG2
02400 BRO N,N↔SON 0,B
02500 CAME 0,N↔GO L4
02600 POP2J
00100 ;FACE ROTATION.
00200 FROTA: LAC F,OBJ↔NCNT N,F↔MOVMS N
00300 PED E,F↔DAC E,E0↔JUMPE E0,[ ;VERTEX FACE.
00400 PFACE B,F↔PVT V,B↔CALL(ROTOR)↔POP2J]
00500
00600 PCW 0,E↔SKIPN N↔CAMN 0,E↔GO[ ;WIRE OR SHELL FACE.
00700 SETQ(V,{VCW,E,F})↔CALL(ROTOR)↔GO .+1]
00800
00900 L5: SETQ(V,{VCCW,E,F})
01000 CALL(ROTOR)↔CALL(ECCW,E,F)
01100 CAMN 1,E↔POP2J ;END OF WIRE FACE.
01200 LAC E,1↔CAMN E,E0↔POP2J ;END OF NORMAL FACE.
01300 SOJN N,L5↔POP2J ;END OF SHELL FACE.
01400
01500 ;EDGE ROTATION.
01600 EROTA: LAC E,OBJ
01700 PVT V,E↔CALL(ROTOR)
01800 NVT V,E↔CALL(ROTOR)
01900 POP2J
02000
02100 ;VERTEX ROTATION.
02200 VROTA: LAC V,OBJ
02300 CALL(ROTOR)
02400 POP2J
02500
02600 BEND;1/14/72------------------------------------------------------
00100 SUBR(INTRAN)TRAN -------------------------------------------------
00200 BEGIN INTRAN; INVERT A TRANSFORMATION.
00300 Q ←← 6
00400
00500 LAC 2,ARG1
00600 SLACI XWC(2)↔LAPI XWC+Q↔BLT KZ+Q
00700
00800 ;XWC' ← -(XWC*IX + YWC*IY + ZWC*IZ);
00900 LAC 1,XWC+Q↔FMPR 1,IX+Q
01000 LAC YWC+Q↔FMPR IY+Q↔FADR 1,0
01100 LAC ZWC+Q↔FMPR IZ+Q↔FADR 1,0
01200 DACN 1,XWC(2)
01300
01400 ;YWC' ← -(XWC*JX + YWC*JY + ZWC*JZ);
01500 LAC 1,XWC+Q↔FMPR 1,JX+Q
01600 LAC YWC+Q↔FMPR JY+Q↔FADR 1,0
01700 LAC ZWC+Q↔FMPR JZ+Q↔FADR 1,0
01800 DACN 1,YWC(2)
01900
02000 ;ZWC' ← -(XWC*KX + YWC*KY + ZWC*KZ);
02100 LAC 1,XWC+Q↔FMPR 1,KX+Q
02200 LAC YWC+Q↔FMPR KY+Q↔FADR 1,0
02300 LAC ZWC+Q↔FMPR KZ+Q↔FADR 1,0
02400 DACN 1,ZWC(2)
02500
02600 ;TRANSPOSE ROTATION MATRIX.
02700 DAC JX+Q,IY(2)
02800 DAC KX+Q,IZ(2)
02900 DAC IY+Q,JX(2)
03000 DAC KY+Q,JZ(2)
03100 DAC IZ+Q,KX(2)
03200 DAC JZ+Q,KY(2)
03300 LAC 1,2↔POP1J
03400
03500 BEND INTRAN; BGB 18 MARCH 1973 -----------------------------------
00100 END
00200 EUCLID-EOF.