perm filename EUCLID.OLD[GEM,BGB] blob
sn#030953 filedate 1973-03-25 generic text, type T, neo UTF8
00100 TITLE EUCLID - EUCLIDEAN TRANSFORMATIONS - JULY 1972.
00200 COMMENT /
00300
00400 MKTRAN(REFRAME,OPAXCNT, DELTA); MAKE EUCLIDEAN TRANSFORMATION.
00500 NORM(LOCOR);
00600 ORTHO(LOCOR);
00700 *CRUX
00800 *ROTOR
00900 ROTTRN
01000 TRANSLATE (Q,R);
01100 ROTATE (Q,R);
01200 /
01300
01400 EXTERN ECW,ECCW,OTHER
01500 EXTERN BGET,FCW,FCCW,VCW,VCCW
01600
01700 SUBR(NORM)LOCOR---------------------------------------------------
01800 BEGIN NORM; NORMALIZE AN ORIENTATION MATRIX.
01900 ;ACCUMULATORS.
02000 ; 05 06 07 IX IY IZ
02100 ; 10 11 12 JX JY JZ
02200 ; 13 14 15 KX KY KZ
02300 ;PICK'EM UP.
02400 SAVAC(15)↔LACI 5↔HRL ARG1↔BLT 15
02500 ; R ← SQRT(A↑2+B↑2+C↑2); A←A/R; B←B/R; C←C/R;
02600 FOR Q IN (5,10,13){
02700 LACM 1,Q↔CAMG 1,[1.0E-8]↔SETZB 1,Q↔FMPR 1,1
02800 LACM 1+Q↔CAMG 0,[1.0E-8]↔SETZB 1+Q↔FMPR↔FADR 1,0
02900 LACM 2+Q↔CAMG 0,[1.0E-8]↔SETZB 2+Q↔FMPR↔FADR 1,0
03000 CAMN 1,[1.0]↔GO .+6
03100 CALL(SQRT,1)
03200 FDVR Q,1↔FDVR Q+1,1↔FDVR Q+2,1}
03300 ;PUT'EM DOWN.
03400 CDR ARG1↔LAC 1,0↔LIPI 5↔BLT 8(1)
03500 GETAC(15)↔POP1J↔VAR
03600 BEND;1/14/72------------------------------------------------------
00100 ;ORTHOGONIZE AN ORIENTATION MATRIX.
00200 ;IT IS ASSUMED THAT THE ROW VECTORS ARE UNIT VECTORS.
00300 SUBR(ORTHO)LOCOR--------------------------------------------------
00400 BEGIN ORTHO
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 ;PLACE THE MATRIX INTO THE FIRST NINE ACCUMULATORS.
01000 L0: LAC R,ARG1↔SLACI Q,IX(R)↔BLT Q,KZ
01100
01200 ;DOT EACH ROW VECTOR INTO THE NEXT ROW.
01300 FMPR IX,JX↔FMPR IY,JY↔FMPR IZ,JZ
01350 FADR IX,IY↔FADR IX,IZ
01400 FMPR JX,KX↔FMPR JY,KY↔FMPR JZ,KZ
01450 FADR JX,JY↔FADR JX,JZ
01500 FMPR KX,IX(R)↔FMPR KY,IY(R)↔FMPR KZ,IZ(R)
01550 FADR KX,KY↔FADR KX,KZ
01600
01700 ;TAKE ABSOLUTE VALUES AND FIND THE WORST TOTAL COSINE.
01800 MOVMS IX↔MOVMS JX↔MOVMS KX
01900 LAC Q,KX↔FADR KX,JX↔FADR JX,IX↔FADR Q,IX
02000 EXCH Q,JX↔SETZM SIGN#
02100 LACI 1,IX(R)↔LACI 2,JX(R)↔LACI 3,KX(R) ;GET ROW POINTERS.
02200 CAML Q,IX↔GO .+4
02300 EXCH 2,1↔EXCH Q,IX↔SETCMM SIGN ;GET 2 BIGGER THAN 1.
02400 CAML KX,Q↔GO .+4
02500 EXCH 3,2↔EXCH KX,Q↔SETCMM SIGN ;GET 3 BIGGER THAN 2.
02600 CAMG KX,[0.00001]↔GO L1 ;GOOD ENUF FOR GOVERNMENT WORK.
02700
02800 ;STRAIGHTEN UP THE WORST VECTOR.
02900 LAC A,Y(1)↔FMPR A,Z(2)
03000 LAC B,Y(2)↔FMPR B,Z(1)↔FSBR A,B↔DAC A,X(3)
03050 LACM A,A↔CAMG A,[1.0E-8]↔SETZM X(3)
03100 LAC A,X(2)↔FMPR A,Z(1)
03200 LAC B,X(1)↔FMPR B,Z(2)↔FSBR A,B↔DAC A,Y(3)
03210 LACM A,A↔CAMG A,[1.0E-8]↔SETZM Y(3)
03300 LAC A,X(1)↔FMPR A,Y(2)
03400 LAC B,X(2)↔FMPR B,Y(1)↔FSBR A,B↔DAC A,Z(3)
03410 LACM A,A↔CAMG A,[1.0E-8]↔SETZM Z(3)
03500 SKIPE SIGN↔GO[MOVNS X(3)↔MOVNS Y(3)↔MOVNS Z(3)↔GO .+1]
03600 SKIPN FLG↔GO L1↔SETZM FLG↔GO L0
03700 L1: GETAC(15)↔POP1J
03800 LIT
03900 BEND;1/14/72------------------------------------------------------
00100 ;MATRIX CROSS PRODUCT. S cross Q → R.
00200 ;CLOBBERS 0,1 AND EXPECTS ARGUMENTS IN AC S,Q & R.
00300 ;92 words - 550 useconds.
00400 CRUX: 0
00500 BEGIN CRUX
00600 ACCUMULATORS{S,Q,R}
00700 DEFINE ADR(I,J)<3*I+J-4>
00800 FOR I←1,3{
00900 FOR J←1,3{
01000 LAC ADR(I,1)(S)↔FMPR ADR(1,J)(Q)↔LAC 1,
01100 LAC ADR(I,2)(S)↔FMPR ADR(2,J)(Q)↔FADR 1,
01200 LAC ADR(I,3)(S)↔FMPR ADR(3,J)(Q)↔FADR 1,
01300 DAC 1,ADR(I,J)(R)
01400 }}↔GO@CRUX
01500 BEND;1/14/72------------------------------------------------------
01600
01700 SUBR(SQRT)--------------------------------------------------------
01800 BEGIN SQRT;MODIFIED OLDE LIB40 SQUARE ROOT - BGB.
01900 A←0 ↔ B←1 ↔ C←2
02000 LACM B,ARG1↔JUMPE B,POP1J.↔PUSH P,2
02100
02200 ;LET X=F*(2↑2B) WHERE 0.25<F<1.00 THEN SQRT(X)=SQRT(F)*(2↑B).
02300 ASHC B,-=27↔SUBI B,201 ;GET EXPONENT IN B, FRACTION IN C.
02400 ROT B,-1 ;CUT EXP IN HALF, SAVE ODD BIT
02500 DAP B,L↔LSH B,-=35 ;USE THAT ODD BIT.
02600 ASH C,-10↔FSC C,177(B) ;0.25 < FRACTION < 1.00
02700
02800 ;LINEAR APPROXIMATION TO SQRT(F).
02900 DAC C,A
03000 FMP C,[0.8125↔0.578125](B)
03100 FAD C,[0.302734↔0.421875](B)
03200
03300 ;TWO ITERATIONS OF NEWTON'S METHOD.
03400 LAC B,A
03500 FDV B,C↔FAD C,B↔FSC C,-1
03600 FDV A,C↔FADR A,C
03700 L: FSC A,0↔LAC 1,A↔POP P,2
03800 POP1J↔LIT
03900 BEND;28/12/72-----------------------------------------------------
04000
04100 SUBR(DISTAN)V1,V2-------------------------------------------------
04200 BEGIN DISTAN;DISTANCE BETWEEN TWO VERTICES - BGB - 10 FEB 1973.
04300 LAC 1,ARG1↔LAC 2,ARG2
04400 LAC XWC(1)↔FSBR XWC(2)↔FMPR↔DAC 3
04500 LAC YWC(1)↔FSBR YWC(2)↔FMPR↔FADRM 3
04600 LAC ZWC(1)↔FSBR ZWC(2)↔FMPR↔FADR 3
04700 CALL(SQRT,0)↔POP2J
04800 BEND;2/10/73------------------------------------------------------
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 HALFPI: 201622077325 ;PI/2
03000 LIT
03100 BEND;-------------------------------------------------------------
00100 SUBR(ROTTRN)REF,TRN,AXIS,DELTA------------------------------------
00200 BEGIN ROTTRN;SETUP A ROTATION TRANSFROMATION MATRIX IN TRN.
00300 ;WITH RESPECT TO THE FRAME OF REFERENCE REF.
00400 ;ABOUT AXIS 0-X, 1-X, 2-Y, 3-Z BY DELTA RADIANS.
00500 ACCUMULATORS{S,Q,R,REF,TRN,AXIS}
00600
00700 ;SET TRN LOCUS TO REF LOCUS AND CLEAR TRN ORIENTATION.
00800 LAC REF,ARG4↔LAC TRN,ARG3
00900 SLACI XWC(REF)↔LAPI XWC(TRN)↔BLT ZWC(TRN)
01000 SETZM IX(TRN)
01100 SLACI IX(TRN)↔LAPI IY(TRN)↔BLT KZ(TRN)
01200
01300 ;PLACE SINE(DELTA) AND COSINE(DELTA) INTO TRN'S ORIENTATION.
01400 SETZM SINE#↔LAC 1,[1.0]
01500 CAR AXIS,ARG2↔SKIPN AXIS
01600 GO[SETQ(SINE,{SIN,ARG1})↔CALL(COS,ARG1)↔GO .+1]
01700 LAC TRN,ARG3
01800 DAC 1,IX(TRN)↔DAC 1,JY(TRN)↔DAC 1,KZ(TRN) ;COS ON DIAGONAL.
01900
02000 ;3D ROTATION MATRIX ABOUT AN AXIS - OR IDENTITY MATRIX.
02100 LAC 0,[1.0]↔LAC 1,SINE#
02200 CDR AXIS,ARG2↔SOSGE AXIS↔AOS AXIS
02300 LSH AXIS,2↔GO .+1(AXIS)
02400 DAC IX(TRN)↔DAC 1,KY(TRN)↔DACN 1,JZ(TRN)↔GO L ;CCW ABOUT I.
02500 DAC JY(TRN)↔DAC 1,IZ(TRN)↔DACN 1,KX(TRN)↔GO L ;CCW ABOUT J.
02600 DAC KZ(TRN)↔DAC 1,JX(TRN)↔DACN 1,IY(TRN)↔L: ;CCW ABOUT K.
02700
02800 ;(TRANSPOSE(REF)CROSS(TRN CROSS REF)) → TRN.
02900 ;BRING 'EM FROM THE REFRAM AND HIT 'EM WITH THE DEL.
03000 LAC TRN,ARG3↔LAC REF,ARG4
03100 SLACI IX(REF)↔LAPI IX+REF↔BLT KZ+REF ;A TERRIBLE PUN ON REF.
03200 LAC S,ARG3↔LAC Q,ARG4↔LACI R,TMP↔JSR CRUX
03300
03400 ;DILATION/REFLECTION.
03500 L1: CAR 0,ARG2↔JUMPE L4 ;AXIS SELECT BITS.
03600 LAC 1,ARG1 ;DELTA DILATION.
03700 TRNN 4↔GO L2↔FMPRM 1,IX(R)↔FMPRM 1,IY(R)↔FMPRM 1,IZ(R)
03800 L2: TRNN 1↔GO L3↔FMPRM 1,JX(R)↔FMPRM 1,JY(R)↔FMPRM 1,JZ(R)
03900 L3: TRNN 2↔GO L4↔FMPRM 1,KX(R)↔FMPRM 1,KY(R)↔FMPRM 1,KZ(R)
04000
04100 ;TRANSPOSE THE REFRAME AND MAP'EM BACK FROM WHERE THEY CAME.
04200 L4: EXCH 6,10↔EXCH 7,13↔EXCH 12,14
04300 LACI S,5↔LACI Q,TMP↔LAC R,ARG3↔JSR CRUX
04350 CAR 0,ARG2↔JUMPN .+3
04400 CALL(NORM,ARG3)
04500 LAC 1,ARG3↔POP4J
04600 TMP: BLOCK 9
04700 BEND;1/14/72------------------------------------------------------
00100 ;TRANSLATE(OBJECT,TRAN).
00200 SUBR(TRANSLATE)---------------------------------------------------
00300 BEGIN TRANSL
00400 DEFINE TRAN.{FADRM X,XWC(V)↔FADRM Y,YWC(V)↔FADRM Z,ZWC(V)}
00500 Q←←1
00600 ACCUMULATORS{B,F,E,V,X,Y,Z,N,R,E0}
00700 CDR R,ARG1
00800 LAC X,XWC(R)↔LAC Y,YWC(R)↔LAC Z,ZWC(R)
00900 LAC Q,ARG2↔LAC(Q)
01000 TLNE(BBIT)↔GO BTRAN
01100 TLNE(FBIT)↔GO FTRAN
01200 TLNE(EBIT)↔GO ETRAN
01300 TLNE(VBIT)↔GO VTRAN
01400 LOCOR V,Q↔TRAN.↔POP2J;CAMERA CASE.
01500
01600 ;BODY TRANSLATION.
01700 BTRAN: LAC B,Q↔TESTZ B,BDVBIT↔GO L2 ;DON'T MOVE VERTICES.
01750 LAC V,B↔SLACI(VBIT) ;1ST VERTEX.
01800 L1: PVT V,V↔TDNN(V)↔GO L2 ;SKIP WHEN VERTEX.
01900 TRAN.↔GO L1 ;TRANSLATE A VERTEX OF THE BODY.
02000 L2: LOCOR V,B↔SKIPN V↔GO L3 ;BODY LOCUS.
02100 TESTZ B,BDLBIT↔GO L3 ;DON'T MOVE LOCOR.
02200 TRAN.
02300
02400 ;PARTS OF THIS BODY.
02500 L3: TESTZ B,BDPBIT↔POP2J ;DON'T MOVE PARTS.
02550 SON N,B↔JUMPE N,POP2J.
02600 L4: PUSH P,N
02700 CALL(TRANSLATE,N,R)
02800 POP P,N↔LAC B,ARG2
02900 BRO N,N↔SON 0,B
03000 CAME 0,N↔GO L4↔POP2J
00100 ;FACE TRANSLATION.
00200 FTRAN: LAC F,Q↔NCNT N,F↔MOVMS N
00300 PED E,F↔DAC E,E0↔JUMPE E0,[
00400 PFACE B,F↔PVT V,B↔TRAN.↔POP2J] ;VERTEX FACE.
00500
00600 PCW 0,E↔SKIPN N↔CAMN 0,E↔GO[ ;TEST FOR WIRE OR SHELL FACE.
00700 SETQ(V,{VCW,E,F})↔TRAN.↔GO .+1] ;WIRE OR SHELL'S 1ST VERTEX.
00800
00900 L5: SETQ(V,{VCCW,E,F})
01000 TRAN.↔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.
01200
01300 ;EDGE TRANSLATION.
01400 ETRAN: LAC E,Q
01500 PVT V,E↔TRAN.
01600 NVT V,E↔TRAN.
01700 POP2J
01800
01900 ;VERTEX TRANSLATION.
02000 VTRAN: LAC V,Q
02100 TRAN.
02200 POP2J
02300 BEND;1/14/72------------------------------------------------------
00100 ;ROTATION'S INNER MOST SUBROUTINE---------------------------------
00200 ;EXPECTS ARGUMENTS IN V AND TRN, CLOBBERS 0,1,X,Y,Z.
00300 ; 36 words - 200 useconds.
00302 ;
00304 ; X ← XWC(V) - XX;
00306 ; Y ← YWC(V) - YY;
00308 ; Z ← ZWC(V) - ZZ;
00309 ;
00310 ; X ← IX*X + IY+Y + IZ*Z + XX;
00312 ; X ← JX*X + JY+Y + JZ*Z + XX;
00314 ; X ← KX*X + KY+Y + KZ*Z + XX;
00316 ;
00400 ROTOR: 0
00500 BEGIN ROTOR
00600 ACCUMULATORS{B,F,E,V,X,Y,Z,TRN}
00700
00800 LAC X,XWC(V)↔FSBR X,XWC(TRN);
00900 LAC Y,YWC(V)↔FSBR Y,YWC(TRN);
01000 LAC Z,ZWC(V)↔FSBR Z,ZWC(TRN);
01100
01200 DEFINE ROTAT $(Q){
01300 LAC 0,X↔ FMPR 0,Q$X(TRN)
01400 LAC 1,Y↔ FMPR 1,Q$Y(TRN)↔ FADR 0,1
01500 LAC 1,Z↔ FMPR 1,Q$Z(TRN)↔ FADR 0,1}
01600
01700 ROTAT(I)↔ FADR XWC(TRN)↔ DAC XWC(V)
01800 ROTAT(J)↔ FADR YWC(TRN)↔ DAC YWC(V)
01900 ROTAT(K)↔ FADR ZWC(TRN)↔ DAC ZWC(V)
02000
02100 GO @ROTOR
02200 BEND;1/14/72------------------------------------------------------
00100 SUBR(ROTATE)OBJECT,TRAN-------------------------------------------
00200 BEGIN ROTATE
00300 ACCUMULATORS{B,F,E,V,X,Y,Z,TRN,N,OBJ,E0}
00400
00500 ;DISTINGUISH PURE TRANSLATIONS.
00600 CDR TRN,ARG1
00700 LAC IX(TRN)↔IOR IY(TRN)↔IOR IZ(TRN)↔JUMPE TRANSL
00800
00900 ;BRANCH ON TYPE OF OBJECT.
01000 LAC OBJ,ARG2↔LAC(OBJ)
01100 TLNE(BBIT)↔GO BROTA
01200 TLNE(FBIT)↔GO FROTA
01300 TLNE(EBIT)↔GO EROTA
01400 TLNE(VBIT)↔GO VROTA
01500
01600 ;CAMERA CASE.
01700 LOCOR V,OBJ↔JSR ROTOR
01800 PUSH P,XWC(TRN)↔PUSH P,YWC(TRN)↔PUSH P,ZWC(TRN)
01900 SETZM XWC(TRN)↔SETZM YWC(TRN)↔SETZM ZWC(TRN)
02000 PUSH P,V
02100 REPEAT 3,{ADDI V,3↔JSR ROTOR↔}
02200 PUSHJ P,NORM↔ADD P,[XWD 1,1]↔PUSHJ P,ORTHO
02300 POP P,ZWC(TRN)↔POP P,YWC(TRN)↔POP P,XWC(TRN)
02400 POP2J
00100 ;BODY ROTATION.
00200 BROTA: LAC B,OBJ↔TESTZ B,BDVBIT↔GO L2 ;DON'T MOVE VERTICES.
00202 LAC V,B ;1ST VERTEX.
00400 L1: PVT V,V↔SLACI(VBIT)↔TDNN(V)↔GO L2 ;SKIP WHEN VERTEX.
00500 JSR ROTOR↔GO L1 ;ROTATE VERTEX.
00510
00600 L2: TESTZ B,BDLBIT↔GO L3 ;DON'T MOVE LOCOR.
00602 LOCOR V,B↔SKIPN V↔GO L3 ;BODY LOCUS.
00700 JSR ROTOR
00800 PUSH P,XWC(TRN)↔PUSH P,YWC(TRN)↔PUSH P,ZWC(TRN)
00900 SETZM XWC(TRN)↔SETZM YWC(TRN)↔SETZM ZWC(TRN)
01000 PUSH P,V
01100 REPEAT 3,{ADDI V,3↔JSR ROTOR↔}
01200 PUSHJ P,NORM↔ADD P,[XWD 1,1]↔PUSHJ P,ORTHO
01300 POP P,ZWC(TRN)↔POP P,YWC(TRN)↔POP P,XWC(TRN)
01400
01500 ;PARTS OF THIS BODY.
01600 L3: TESTZ B,BDPBIT↔POP2J ;DON'T MOVE PARTS.
01602 SON N,B↔JUMPE N,POP2J.
01700 L4: PUSH P,N
01800 CALL(ROTATE,N,TRN)
01900 POP P,N↔LAC B,ARG2
02000 BRO N,N↔SON 0,B
02100 CAME 0,N↔GO L4↔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↔JSR ROTOR↔POP2J]
00500
00600 PCW 0,E↔SKIPN N↔CAMN 0,E↔GO[ ;WIRE OR SHELL FACE.
00700 SETQ(V,{VCW,E,F})↔JSR ROTOR↔GO .+1]
00800
00900 L5: SETQ(V,{VCCW,E,F})
01000 JSR 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.
03300 ;EDGE ROTATION.
03400 EROTA: LAC E,OBJ
03500 PVT V,E↔JSR ROTOR
03600 NVT V,E↔JSR ROTOR
03700 POP2J
03800
03900 ;VERTEX ROTATION.
04000 VROTA: LAC V,OBJ
04100 JSR ROTOR
04200 POP2J
04300 BEND;1/14/72------------------------------------------------------
00100 ;MAKE EUCLIDEAN TRANSFORMATION MATRIX.
00200 ;OP = 0-TRANSLATION, 1-ROTATION, 2-DILATION, 3-REFLECTION.
00300 ;AXIS = 0-X, 1-X, 2-Y, 3-Z.
00400 ;AXECNT = 0 & 1 for AXIS, 2 for ¬AXIS, 3 for all AXES.
00500
00600 ;TRAN ← MKTRAN(REFRAM,OPAXCNT,DELTA).
00700 SUBR(MKTRAN)REFRAM,OPAXCNT,DELTA----------------------------------
00800 BEGIN MKTRAN
00900 ACCUMULATORS{TRN,REF,DELTA,OP,AXIS}
01000 EXTERN MKNODE
01100
01200 ;CREATE A NODE FOR THE TRANSFORMATION MATRIX.
01300 SETQ(TRN,{MKNODE,[0]})
01400 SKIPN REF,ARG3↔LACI REF,REFRAME
01500 LAC DELTA,ARG1
01600
01700 ;UNPACK OPCODE.
01800 LAC 0,ARG2
01900 LDB OP,[POINT 2,0,29]
02000 LDB AXIS,[POINT 2,0,32]
02100
02200 ;TRANSLATION.
02300 JUMPN OP,L1
02400 GO@[TI↔TI↔TJ↔TK](AXIS)
02500 FOR @' Qε{IJK}{
02600 T'Q: LAC Q'X(REF)↔FMPR DELTA↔DAC XWC(TRN)
02700 LAC Q'Y(REF)↔FMPR DELTA↔DAC YWC(TRN)
02800 LAC Q'Z(REF)↔FMPR DELTA↔DAC ZWC(TRN)
02900 LAC 1,TRN↔POP3J}
03000
03010 ;SETUP DILATION AXIS SELECT BITS 4-X,1-Y,2-Z IN LEFT HALF OF AXIS.
03100 L1: CAIN OP,1↔GO L2
03400 LAC ARG2↔ANDI 3 ;AXIS COUNT.
03500 LAC 1,[4↔4↔1↔2](AXIS) ;AXIS SELECT BIT.
03600 CAIN 2↔TRC 1,7 ;NOT AXIS
03700 CAIN 3↔TRO 1,7 ;ALL AXES.
03800 DIP 1,AXIS
03850
03900 L2: CALL(ROTTRN,REF,TRN,AXIS,DELTA)
04000 POP3J
04100 BLOCK 3↔REFRAME:1.↔0↔0↔ 0↔1.↔0↔ 0↔0↔1.
04200 BEND;1/15/72------------------------------------------------------
04300
04400 END
04500 EUCLID-EOF.