perm filename EUCLID[LSP,BGB] blob
sn#039892 filedate 1973-05-09 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00020 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002 TITLE EUCLID - EUCLIDEAN TRANSFORMATIONS - JULY 1972.
C00005 00003 SUBR(TRANSLATE)REFRAM+OBJECT,DX,DY,DZ-----------------------------
C00007 00004 SUBR(ROTATE)REFRAM+OBJECT,ABOUTX,ABOUTY,ABOUTZ--------------------
C00010 00005 SUBR(NORM)FRAME---------------------------------------------------
C00012 00006 SUBR(ORTHO2)FRAME-------------------------------------------------
C00014 00007 SUBR(ANGL3V)V1,V2,V3 ---------------------------------------------
C00017 00008 SUBR(ORTHO1)FRAME-------------------------------------------------
C00020 00009 SUBR(SQRT)X ------------------------------------------------------
C00022 00010 SUBR(DISTAN)V1,V2-------------------------------------------------
C00023 00011 INTERN SIN,COS---------------------------------------------------
C00025 00012 SUBR(ACOS)--------------------------------------------------------
C00028 00013 SUBR(ATAN)--------------------------------------------------------
C00031 00014 SUBR(ATAN2)-------------------------------------------------------
C00033 00015 ROTOR:-----------------------------------------------------------
C00035 00016 SUBR(APTRAN)OBJECT,TRAN-------------------------------------------
C00037 00017 BODY ROTATION.
C00038 00018 FACE ROTATION.
C00039 00019 SUBR(INTRAN)TRAN -------------------------------------------------
C00041 00020 END
C00042 ENDMK
C⊗;
TITLE EUCLID - EUCLIDEAN TRANSFORMATIONS - JULY 1972.
EXTERN ECW,ECCW,OTHER
EXTERN BGET,FCW,FCCW,VCW,VCCW
EXTERN MKCOPY,MKFRAME,KLNODE
; EXTERN SIN,COS,SQRT,ATAN,ATAN2,ASIN,ACOS,LOG,HALFPI,PI,TWOPI
COMMENT/
CONTENTS:
FRAME ← TRANSLATE(REFRAM+OBJECT,DX,DY,DZ);
FRAME ← ROTATE(REFRAM+OBJECT,ABOUTX,ABOUTY,ABOUTZ);
FRAME ← SHRINK(REFRAM+OBJECT,KX,KY,KZ);
NORM(FRAME);
ORTHO1(FRAME);
SQRT(X); ! NOW ON ARITH.FAI;
DISTANCE(V1,V2);
SIN(X); ! NOW ON ARITH.FAI;
COS(X); ! NOW ON ARITH.FAI;
ROTOR; V,Q.
APTRAN(CBFEV,ETRAN);
INTRAN(TRAN);
/
SUBR(TRANSLATE)REFRAM+OBJECT,DX,DY,DZ-----------------------------
BEGIN TRANSLATE; OBJECT TRANSLATION WITH RESPECT TO REFRAM.
CALL(MKFRAME)
LAC ARG3↔DAC XWC(1)
LAC ARG2↔DAC YWC(1)
LAC ARG1↔DAC ZWC(1)
↑QTRAN: DAC 1,TMP1
LACM 2,ARG4↔CDR 2,2↔DAC 2,OBJECT
NIP 1,ARG4↔SKIPGE 1↔GO[
SETZ 1,↔JUMPE 2,.+1
CALL(BGET,OBJECT)
FRAME 1,1↔GO .+1]
DAC 1,REFRAM
LAC 1,TMP1↔SKIPN REFRAM↔GO L1
L0: SETQ(TMP2,{MKCOPY,REFRAM})
CALL(INTRAN,TMP2)
CALL(APTRAN,TMP2,TMP1)
CALL(APTRAN,TMP2,REFRAM)
CALL(KLNODE,TMP1)
LAC 1,TMP2↔DAC 1,TMP1
L1: SKIPN OBJECT↔POP4J ;RETURN TRANSFORMATION.
CALL(APTRAN,OBJECT,TMP1)
CALL(KLNODE,TMP1)
LAC 1,OBJECT↔POP4J ;RETURN OBJECT.
DECLARE{TMP1,TMP2,REFRAM,OBJECT}
BEND TRANSLATE; BGB 18 MARCH 1973 --------------------------------
SUBR(ROTATE)REFRAM+OBJECT,ABOUTX,ABOUTY,ABOUTZ--------------------
BEGIN ROTATE; OBJECT ROTATION WITH RESPECT TO REFRAM.
L1: DZM TMP1↔SKIPN ARG3↔GO L2↔SETQ(TMP1,{MKFRAME})
CALL(COS,ARG3)↔LAC 2,TMP1↔DAC 1,JY(2)↔DAC 1,KZ(2)
CALL(SIN,ARG3)↔LAC 2,TMP1↔DAC 1,JZ(2)↔DACN 1,KY(2)
L2: DZM TMP2↔SKIPN ARG2↔GO L3↔SETQ(TMP2,{MKFRAME})
CALL(COS,ARG2)↔LAC 2,TMP2↔DAC 1,IX(2)↔DAC 1,KZ(2)
CALL(SIN,ARG2)↔LAC 2,TMP2↔DAC 1,KX(2)↔DACN 1,IZ(2)
L3: DZM TMP3↔SKIPN ARG1↔GO L4↔SETQ(TMP3,{MKFRAME})
CALL(COS,ARG1)↔LAC 2,TMP3↔DAC 1,IX(2)↔DAC 1,JY(2)
CALL(SIN,ARG1)↔LAC 2,TMP3↔DAC 1,IY(2)↔DACN 1,JX(2)
L4: SKIPN 1,TMP2↔GO L5 ;TMP1 ← TMP1 * TMP2.
SKIPN TMP1↔GO[DAC 1,TMP1↔GO L5]
CALL(APTRAN,TMP1,TMP2)
CALL(KLNODE,TMP2)
L5: SKIPN 1,TMP3↔GO L6 ;TMP1 ← TMP1 * TMP3.
SKIPN TMP1↔GO[DAC 1,TMP1↔GO L6]
CALL(APTRAN,TMP1,TMP3)
CALL(KLNODE,TMP3)
L6: SKIPN 1,TMP1↔CALL(MKFRAME) ;IDENTITY.
GO QTRAN
DECLARE{TMP1,TMP2,TMP3,REFRAM,OBJECT}
BEND ROTATE; BGB 18 MARCH 1973 -----------------------------------
SUBR(SHRINK)REFRAM+OBJECT,KX,KY,KZ--------------------------------
;DILATION-REFLECTION WITH RESPECT TO REFRAM.
CALL(MKFRAME)
SKIPN 2,ARG3↔SLACI 2,(1.0)↔DAC 2,IX(1)
SKIPN 2,ARG2↔SLACI 2,(1.0)↔DAC 2,JY(1)
SKIPN 2,ARG1↔SLACI 2,(1.0)↔DAC 2,KZ(1)
GO QTRAN
;SHRINK BGB 18 MARCH 1973 ----------------------------------------
SUBR(NORM)FRAME---------------------------------------------------
BEGIN NORM; NORMALIZE AN ORIENTATION MATRIX.
;ACCUMULATORS:
; 05 06 07 IX IY IZ
; 10 11 12 JX JY JZ
; 13 14 15 KX KY KZ
SAVAC(15)
SLAC ARG1↔LAPI 5↔BLT 15
; R ← SQRT(A↑2+B↑2+C↑2); A←A/R; B←B/R; C←C/R;
FOR Q IN (5,10,13){
LACM 1,Q↔CAMG 1,[1.0E-8]↔SETZB 1,Q↔FMPR 1,1
LACM 1+Q↔CAMG 0,[1.0E-8]↔SETZB 1+Q↔FMPR↔FADR 1,0
LACM 2+Q↔CAMG 0,[1.0E-8]↔SETZB 2+Q↔FMPR↔FADR 1,0
SKIPE 1↔CAMN 1,[1.0]↔GO .+6↔CALL(SQRT,1)
FDVR Q,1↔FDVR Q+1,1↔FDVR Q+2,1}
;PUT'EM DOWN.
LAC 1,ARG1
SLACI 5↔LAPI IX(1)↔BLT KZ(1)
GETAC(15)↔POP1J↔VAR
BEND NORM; BGB 14 JANUARY 1973 -----------------------------------
SUBR(ORTHO2)FRAME-------------------------------------------------
BEGIN ORTHO2; ACCEPT I; K' ← I CROSS J; J' ← K CROSS I;
LAC 1,ARG1
DZM KX(1)↔DZM KY(1)↔DZM KZ(1)
CALL(NORM,1)
SLAC ARG1↔LAPI 1↔BLT 9
LAC 12,4↔LAC 13,5↔LAC 14,6 ;SAVE J VECTOR.
;VECTOR-K ← VECTOR-I CROSS VECTOR-J.
LAC 2↔FMP 6↔DAC 7
LAC 5↔FMP 3↔FSB 7,
LAC 4↔FMP 3↔DAC 8
LAC 1↔FMP 6↔FSB 8,
LAC 1↔FMP 5↔DAC 9
LAC 4↔FMP 2↔FSB 9,
;VECTOR-J ← VECTOR-K CROSS VECTOR-I.
LAC 8↔FMP 3↔DAC 4
LAC 2↔FMP 9↔FSB 4,
LAC 1↔FMP 9↔DAC 5
LAC 7↔FMP 3↔FSB 5,
LAC 7↔FMP 2↔DAC 6
LAC 1↔FMP 8↔FSB 6,
LAC 15,ARG1↔SLACI 1
LAPI IX(15)↔BLT KZ(15)
POP1J
BEND ORTHO2;BGB 30 MARCH 1973 ------------------------------------
SUBR(DETERM)FRAME-------------------------------------------------
SLAC ARG1↔LAPI 1↔BLT 9
LAC 5↔FMP 9↔LAC 12,
LAC 6↔FMP 8↔FSB 12,↔FMP 1,12
LAC 6↔FMP 7↔LAC 12,
LAC 4↔FMP 9↔FSB 12,↔FMP 2,12↔FAD 1,2
LAC 4↔FMP 8↔LAC 12,
LAC 5↔FMP 7↔FSB 12,↔FMP 3,12↔FAD 1,3↔POP1J
;DETERM - BGB 1 APRIL 1973 ---------------------------------------
SUBR(ANGL3V)V1,V2,V3 ---------------------------------------------
BEGIN ANGL3V; ANGLE V1,V2,V3 CCW; RETURNS VALUE 0 TO 2π.
v1 ←← 13
v2 ←← 14
v3 ←← 15
;DETERMINE WHETHER THE ANGLE IS MORE OR LESS THAN PI.
LAC V1,ARG3↔SLACI XWC(V1)↔LAPI 1↔BLT 3
LAC V2,ARG2↔SLACI XWC(V2)↔LAPI 4↔BLT 6
LAC V3,ARG1↔SLACI XWC(V3)↔LAPI 7↔BLT 9
FSBR 1,4↔FSBR 2,5↔FSBR 3,6 ;V1' ← (V1-V2).
FSBR 7,4↔FSBR 8,5↔FSBR 9,6 ;V3' ← (V3-V2).
LAC 2↔FMP 9↔LAC 4,↔LAC 3↔FMP 8↔FSB 4, ;V2' ← (V1 X V3).
LAC 3↔FMP 7↔LAC 5,↔LAC 1↔FMP 9↔FSB 5,
LAC 1↔FMP 8↔LAC 6,↔LAC 2↔FMP 7↔FSB 6,
FADR 1,4↔FADR 2,5↔FADR 3,6 ;V1" ← (V1'+V2').
FADR 7,4↔FADR 8,5↔FADR 9,6 ;V3" ← (V3'+V2').
;determ negative indicates ccw order, 0 to π.
;determ positive indicates cw order, π to 2π.
CALL({DETERM+3},0)
SKIPL 1↔SKIPA 1,PI↔SETZ 1,↔PUSH P,1
;COSINE LAW.
CALL(DISTANCE,V2,V1)↔PUSH P,1
CALL(DISTANCE,V2,V3)↔PUSH P,1
CALL(DISTANCE,V1,V3)
FMPR 1,1↔MOVNS 1
POP P,2↔LAC 2↔FMPR 2,2
POP P,3↔FMP 3↔FMPR 3,3
FSC 1↔FADR 1,2↔FADR 1,3
FDVR 1,0↔CALL(ACOS,1)
POP P,0↔FADR 1,0↔POP3J
BEND ANGL3V; BGB 1 APRIL 1973 ------------------------------------
SUBR(ATEST)FACE
BEGIN ATEST
ACCUMULATORS{F,E,V1,V2,V3}
LAC F,ARG1
PED E,F
SETQ(V1,{VCW,E,F})
SETQ(V2,{VCCW,E,F})
SETQ(E,{ECCW,E,F})
SETQ(V3,{VCCW,E,F})
CALL(ANGL3V,V1,V2,V3)
FMP 1,[180.0]
FDVR 1,PI
POP1J
BEND ATEST
SUBR(ORTHO1)FRAME-------------------------------------------------
BEGIN ORTHO1; ORTHOGONIZE AN ORIENTATION MATRIX.
;IT IS ASSUMED THAT THE ROW VECTORS ARE UNIT VECTORS.
X←←0 ↔ Y←←1 ↔ Z←←2 ;ADDRESS DISPLACEMENTS.
Q←←9 ↔ R←←13 ↔ A←←14 ↔ B←←15 ;ACCUMULATORS.
SAVAC(15)
SETOM FLG# ;FIRST TIME THRU FLAG.
L0: LAC R,ARG1
SLACI Q,IX(R)↔BLT Q,KZ ;FIRST NINE ACCUMULATORS.
;DOT EACH ROW VECTOR INTO THE NEXT ROW.
FMPR IX,JX↔FMPR IY,JY↔FMPR IZ,JZ
FADR IX,IY↔FADR IX,IZ
FMPR JX,KX↔FMPR JY,KY↔FMPR JZ,KZ
FADR JX,JY↔FADR JX,JZ
FMPR KX,IX(R)↔FMPR KY,IY(R)↔FMPR KZ,IZ(R)
FADR KX,KY↔FADR KX,KZ
;TAKE ABSOLUTE VALUES AND FIND THE WORST TOTAL COSINE.
MOVMS IX↔MOVMS JX↔MOVMS KX
LAC Q,KX↔FADR KX,JX↔FADR JX,IX↔FADR Q,IX
EXCH Q,JX↔SETZM SIGN#
LACI 1,IX(R)↔LACI 2,JX(R)↔LACI 3,KX(R) ;GET ROW POINTERS.
CAML Q,IX↔GO .+4
EXCH 2,1↔EXCH Q,IX↔SETCMM SIGN ;GET 2 BIGGER THAN 1.
CAML KX,Q↔GO .+4
EXCH 3,2↔EXCH KX,Q↔SETCMM SIGN ;GET 3 BIGGER THAN 2.
CAMG KX,[0.00001]↔GO L1 ;GOOD ENUF FOR GOVERNMENT WORK.
;STRAIGHTEN UP THE WORST VECTOR.
LAC A,Y(1)↔FMPR A,Z(2)
LAC B,Y(2)↔FMPR B,Z(1)↔FSBR A,B↔DAC A,X(3)
LACM A,A↔CAMG A,[1.0E-8]↔SETZM X(3)
LAC A,X(2)↔FMPR A,Z(1)
LAC B,X(1)↔FMPR B,Z(2)↔FSBR A,B↔DAC A,Y(3)
LACM A,A↔CAMG A,[1.0E-8]↔SETZM Y(3)
LAC A,X(1)↔FMPR A,Y(2)
LAC B,X(2)↔FMPR B,Y(1)↔FSBR A,B↔DAC A,Z(3)
LACM A,A↔CAMG A,[1.0E-8]↔SETZM Z(3)
SKIPE SIGN↔GO[MOVNS X(3)↔MOVNS Y(3)↔MOVNS Z(3)↔GO .+1]
SKIPN FLG↔GO L1↔SETZM FLG↔GO L0
L1: GETAC(15)↔POP1J↔LIT
BEND ORTHO1; BGB 14 JANUARY 1973 ---------------------------------
SUBR(SQRT)X ------------------------------------------------------
BEGIN SQRT;MODIFIED OLDE LIB40 SQUARE ROOT.
A←←0 ↔ B←←1 ↔ C←←2
LACM B,ARG1↔JUMPE B,POP1J.↔PUSH P,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↔POP P,2
POP1J↔LIT
BEND SQRT; BGB 28 DECEMBER 1972 ----------------------------------
SUBR(DISTAN)V1,V2-------------------------------------------------
BEGIN DISTAN; DISTANCE BETWEEN TWO VERTICES.
LAC 1,ARG1↔LAC 2,ARG2
LAC XWC(1)↔FSBR XWC(2)↔FMPR↔DAC 3
LAC YWC(1)↔FSBR YWC(2)↔FMPR↔FADRM 3
LAC ZWC(1)↔FSBR ZWC(2)↔FMPR↔FADR 3
CALL(SQRT,0)↔POP2J
BEND DISTAN; BGB 10 FEBRUARY 1973 --------------------------------
INTERN SIN,COS;---------------------------------------------------
BEGIN SINCOS;MODIFIED OLDE LIB40 SINE & COSINE - BGB.
A←←1 ↔ B←←2 ↔ C←←3
↑COS: SKIPA A,ARG1
↑SIN: SKIPA A,ARG1
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;-------------------------------------------------------------
INTERN HALFPI,PI,TWOPI
HALFPI: 201622077325 ;PI/2
PI: 202622077325 ;PI
TWOPI: 203622077325 ;2*PI
SUBR(ACOS)--------------------------------------------------------
;ACOS(X)= π/2 - ASIN(X).
;GIVEN -1 ≤ X ≤ +1 RETURN 0 ≤ ACOS(X) ≤ +π.
PUSH 17,ARG1↔PUSHJ 17,ASIN
MOVNS 1↔FADR 1,HALFPI↔POP1J
;-----------------------------------------------------------------
SUBR(ASIN)--------------------------------------------------------
BEGIN ASIN
;ASIN(X)=ATAN(X/SQRT(1-X↑2)).
;GIVEN -1 ≤ X ≤ +1 RETURN -π/2 ≤ ASIN(X) ≤ +π/2.
A←1 ↔ B←2
LACN A,ARG1↔FMPR A,ARG1↔FADRI A,(1.0)
JUMPE A,[ ;WAS X EITHER -1.0 OR 1.0?
LAC A,HALFPI
SKIPGE ARG1
MOVNS A↔POP1J]
PUSH 17,A↔PUSHJ 17,SQRT
LAC B,ARG1↔FDVR B,1↔DAC B,ARG1 ;CALCULATE X/SQRT(1-X↑2)
GO ATAN ;CALCULATE ATAN(SQRT(1-X↑2))
BEND;-------------------------------------------------------------
SUBR(LOG)---------------------------------------------------------
BEGIN LOG
MOVM ARG1↔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
LIT↔VAR
BEND;-------------------------------------------------------------
SUBR(ATAN)--------------------------------------------------------
BEGIN ATAN
;ATAN(X) = X*(B0+A1 / (Z+B1-A2 / (Z+B2-A3 / (Z+B3))) )
;WHERE Z=X↑2, IF 0<X<=1
;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,ARG1 ;PICK UP THE ARGUMENT IN A
ATAN1: LACM 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, 201400 ;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
BEND ATAN;--------------------------------------------------------
SUBR(ATAN2)-------------------------------------------------------
BEGIN ATAN2
; OMEGA ← ATAN2(Y,X).
Y←←1 ↔ X←←2
LACM Y,ARG2↔LACM X,ARG1
CAML Y,X↔GO L1
;HORIZONTAL TO π/2; ABS(Y) < ABS(X).
LAC Y,ARG2↔FDVR Y,ARG1
PUSH 17,Y↔PUSHJ 17,ATAN ;ARCTAN(Y/X)
SKIPL ARG1↔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: LACN X,ARG1↔FDVR X,ARG2
PUSH 17,X↔PUSHJ 17,ATAN ;ARCTAN(X/Y)
SKIPG ARG2↔GO[
FSB Y,HALFPI↔POP2J]
FADR Y,HALFPI
POP2J
BEND ATAN2;-------------------------------------------------------
ROTOR:;-----------------------------------------------------------
BEGIN ROTOR
;APTRAN'S INNER MOST SUBROUTINE.
;EXPECTS ARGUMENTS IN V AND Q. CLOBBERS 1,2,X,Y,Z.
;
; X ← XWC(V);
; Y ← YWC(V);
; Z ← ZWC(V);
;
; XWC(V) ← X*IX(Q) + Y*JX(Q) + Z*KX(Q) + XWC(Q);
; YWC(V) ← X*IY(Q) + Y*JY(Q) + Z*KZ(Q) + YWC(Q);
; ZWC(V) ← X*IZ(Q) + Y*JZ(Q) + Z*KZ(Q) + ZWC(Q);
;
ACCUMULATORS{B,F,E,V,X,Y,Z,Q}
LAC X,XWC(V)↔LAC Y,YWC(V)↔LAC Z,ZWC(V)
LAC 1,IX(Q)↔CAMN 1,[1.0]↔SKIPA 1,X↔FMPR 1,X
SKIPE 2,JX(Q)↔GO[FMPR 2,Y↔FADR 1,2↔GO .+1]
SKIPE 2,KX(Q)↔GO[FMPR 2,Z↔FADR 1,2↔GO .+1]
SKIPE 2,XWC(Q)↔FADR 1,2↔DAC 1,XWC(V)
LAC 1,JY(Q)↔CAMN 1,[1.0]↔SKIPA 1,Y↔FMPR 1,Y
SKIPE 2,IY(Q)↔GO[FMPR 2,X↔FADR 1,2↔GO .+1]
SKIPE 2,KY(Q)↔GO[FMPR 2,Z↔FADR 1,2↔GO .+1]
SKIPE 2,YWC(Q)↔FADR 1,2↔DAC 1,YWC(V)
LAC 1,KZ(Q)↔CAMN 1,[1.0]↔SKIPA 1,Z↔FMPR 1,Z
SKIPE 2,JZ(Q)↔GO[FMPR 2,Y↔FADR 1,2↔GO .+1]
SKIPE 2,IZ(Q)↔GO[FMPR 2,X↔FADR 1,2↔GO .+1]
SKIPE 2,ZWC(Q)↔FADR 1,2↔DAC 1,ZWC(V)
POP0J
BEND ROTOR; BGB 18 MARCH 1973 ------------------------------------
SUBR(APTRAN)OBJECT,TRAN-------------------------------------------
BEGIN APTRAN; APPLY EUCLIDEAN TRANSFORMATION TO THE OBJECT.
ACCUMULATORS{B,F,E,V,X,Y,Z,TRN,N,OBJ,E0}
SKIPN TRN,ARG1↔POP2J
;BRANCH ON TYPE OF OBJECT.
LAC OBJ,ARG2
LACM 1,(OBJ)↔JUMPE 1,LROTA
TLNE 1,(1B9)↔GO LROTA ;FRAME.
ANDI 1,17
CAIN 1,$BODY↔GO BROTA ;BODY.
CAIN 1,$CAMERA↔GO CROTA ;CAMERA.
CAIN 1,$FACE↔GO FROTA ;FACE.
CAIN 1,$EDGE↔GO EROTA ;EDGE.
CAIN 1,$VERT↔GO VROTA ;VERT.
POP2J
LROTA: SKIPA V,OBJ ;FRAME CASE.
CROTA: FRAME V,OBJ ;CAMERA CASE.
CALL(ROTOR)
PUSH P,XWC(TRN)↔PUSH P,YWC(TRN)↔PUSH P,ZWC(TRN)
DZM XWC(TRN)↔DZM YWC(TRN)↔DZM ZWC(TRN)
ADDI V,3↔CALL(ROTOR)
ADDI V,3↔CALL(ROTOR)
ADDI V,3↔CALL(ROTOR)
POP P,ZWC(TRN)↔POP P,YWC(TRN)↔POP P,XWC(TRN)
POP2J
;BODY ROTATION.
BROTA: LAC B,OBJ
TESTZ B,BDVBIT↔GO L2 ;DON'T MOVE VERTICES.
LAC V,B ;1ST VERTEX.
L1: PVT V,V
CAMN V,OBJ↔GO L2 ;SKIP WHEN VERTEX.
CALL(ROTOR)↔GO L1 ;ROTATE VERTEX.
L2: LAC B,OBJ
TESTZ B,BDLBIT↔GO L3 ;DON'T MOVE FRAME.
FRAME V,B↔SKIPN V↔GO L3
DAC V,TMP#↔PUSH P,B
CALL(APTRAN,V,TRN) ;BODY'S FRAME.
CALL(NORM,TMP#)
CALL(ORTHO1,TMP#)
POP P,B
;PARTS OF THIS BODY.
L3: TESTZ B,BDPBIT↔POP2J ;DON'T MOVE PARTS.
SON N,B↔JUMPE N,POP2J.
L4: PUSH P,N
CALL(APTRAN,N,TRN)
POP P,N↔LAC B,ARG2
BRO N,N↔SON 0,B
CAME 0,N↔GO L4
POP2J
;FACE ROTATION.
FROTA: LAC F,OBJ↔NCNT N,F↔MOVMS N
PED E,F↔DAC E,E0↔JUMPE E0,[ ;VERTEX FACE.
PFACE B,F↔PVT V,B↔CALL(ROTOR)↔POP2J]
PCW 0,E↔SKIPN N↔CAMN 0,E↔GO[ ;WIRE OR SHELL FACE.
SETQ(V,{VCW,E,F})↔CALL(ROTOR)↔GO .+1]
L5: SETQ(V,{VCCW,E,F})
CALL(ROTOR)↔CALL(ECCW,E,F)
CAMN 1,E↔POP2J ;END OF WIRE FACE.
LAC E,1↔CAMN E,E0↔POP2J ;END OF NORMAL FACE.
SOJN N,L5↔POP2J ;END OF SHELL FACE.
;EDGE ROTATION.
EROTA: LAC E,OBJ
PVT V,E↔CALL(ROTOR)
NVT V,E↔CALL(ROTOR)
POP2J
;VERTEX ROTATION.
VROTA: LAC V,OBJ
CALL(ROTOR)
POP2J
BEND;1/14/72------------------------------------------------------
SUBR(INTRAN)TRAN -------------------------------------------------
BEGIN INTRAN; INVERT A TRANSFORMATION.
Q ←← 6
LAC 2,ARG1
SLACI XWC(2)↔LAPI XWC+Q↔BLT KZ+Q
;XWC' ← -(XWC*IX + YWC*IY + ZWC*IZ);
LAC 1,XWC+Q↔FMPR 1,IX+Q
LAC YWC+Q↔FMPR IY+Q↔FADR 1,0
LAC ZWC+Q↔FMPR IZ+Q↔FADR 1,0
DACN 1,XWC(2)
;YWC' ← -(XWC*JX + YWC*JY + ZWC*JZ);
LAC 1,XWC+Q↔FMPR 1,JX+Q
LAC YWC+Q↔FMPR JY+Q↔FADR 1,0
LAC ZWC+Q↔FMPR JZ+Q↔FADR 1,0
DACN 1,YWC(2)
;ZWC' ← -(XWC*KX + YWC*KY + ZWC*KZ);
LAC 1,XWC+Q↔FMPR 1,KX+Q
LAC YWC+Q↔FMPR KY+Q↔FADR 1,0
LAC ZWC+Q↔FMPR KZ+Q↔FADR 1,0
DACN 1,ZWC(2)
;TRANSPOSE ROTATION MATRIX.
DAC JX+Q,IY(2)
DAC KX+Q,IZ(2)
DAC IY+Q,JX(2)
DAC KY+Q,JZ(2)
DAC IZ+Q,KX(2)
DAC JZ+Q,KY(2)
LAC 1,2↔POP1J
BEND INTRAN; BGB 18 MARCH 1973 -----------------------------------
END
EUCLID-EOF.