perm filename EULER[GEM,BGB]1 blob sn#030934 filedate 1973-03-27 generic text, type T, neo UTF8
00100	TITLE EULER  -  EULER  PRIMITIVES  -  JULY 1972.
00200		
00300	COMMENT /
00400	These primitives preserve the Euler Equation F-E+V = 2*B-2*H;
00500	
00600		INVERT(E);			"|" COMMAND.
00700		EVERT(B);			"¬" COMMAND.
00800		VNEW ← MKEV(F,V);		"E" COMMAND.
00900		ENEW ← MKFE(V1,F,V2);		"J" COMMAND.
01000		VNEW ← ESPLIT(E);		"M" COMMAND.
01100		   F ← KLFE(ENEW);		"K" COMMAND.
01200		   E ← KLEV(VNEW);		"K" COMMAND.
01300		   V ← KLVE(ENEW);     	        "αK" COMMAND.
01400		BNEW ← MKCOPY(B);		"C" COMMAND.
01500		ENEW ← GLUEE(F1,V1,F2,V2);	"J" COMMAND.
01600	/
01700	
01800	;THE EULER PRIMITVES ARE DEPENDENT ON THE WING OPERATIONS.
01900		EXTERN MKNODE,KLNODE
02000		EXTERN MKB,MKF,MKE,MKV
02100		EXTERN KLB,KLF,KLE,KLV,WING
02200		EXTERN WING,LINKED
02300		EXTERN ECW,ECCW,OTHER,OTHER.
02400		EXTERN BGET,FCW,FCCW,VCW,VCCW
02450		EXTERN BATT,BDET
02500	
02600	;BIT FOR MARKING EDGES OF A WASP FACE'S WAIST.
02700		↓WASP←←1B5
     

00100	SUBR(INVERT)------------------------------------------------------
00200	BEGIN INVERT
00300		LAC 1,ARG1
00400		MOVSS 1(1)↔MOVSS 3(1)↔MOVSS 4(1)↔MOVSS 5(1)
00500		MOVNS -3(1)↔MOVNS -2(1)↔MOVNS -1(1)
00600		POP1J
00700	BEND;1/14/73------------------------------------------------------
00800	
00900	;EVERT(B) - TURN BODY INSIDE OUT.
01000	SUBR(EVERT)BODY --------------------------------------------------
01100	BEGIN EVERT; TURN SOMETHING INSIDE OUT.
01200		ACCUMULATORS{B,E}
01300		CDR B,ARG1
01400		TEST B,BBIT↔POP1J
01500		LAC E,B
01600	L1:	PED E,E
01700		TEST E,EBIT↔GO L3
01800		MOVSS 1(E)
01900		MOVS  4(E)↔MOVS 1,5(E)
02000		DAC 1,4(E)↔DAC 5(E)
02100		GO L1
02200	
02300	;PARTS OF THIS BODY.
02400	L3:	SON 1,B↔JUMPE 1,POP1J.
02500	L4:	PUSH P,1↔CALL(EVERT,1)
02700		POP P,1↔LAC B,ARG1
02800		BRO 1,1↔SON 0,B
02900		CAME 0,1↔GO L4↔POP1J
03000	BEND;1/14/73------------------------------------------------------
     

00100	;VNEW ← MKEV(F,V).  "E" COMMAND.
00200	SUBR(MKEV)--------------------------------------------------------
00300	BEGIN	MKEV
00400		ACCUMULATORS {VNEW,B,F,V,ENEW,E1,E2}
00500	
00600	;CHECK FOR BAD ARGUMENTS.
00700		CDR VNEW,ARG1;FOR BAD RETURNS.
00800		LAC V,ARG1↔TEST(V,VBIT)↔POP2J
00900		LAC F,ARG2↔TEST(F,FBIT)↔POP2J
01000	
01100	;CREATE A NEW EDGE AND VERTEX.
01200		SETQ(B,{BGET,V})
01300		SETQ(VNEW,{MKV,B})
01400		SLACI XWC(V)↔LAPI XWC(VNEW)↔BLT ZWC(VNEW)
01450		LAC 1(V)↔DAC 1(VNEW)
01500		SETQ(ENEW,{MKE,B})
01600	
01700	;MAKE FACE AND VERTEX LINKS.
01800		PED. 	ENEW,VNEW
01900		NFACE.	F,ENEW
02000		PFACE.	F,ENEW
02100		NVT.	VNEW,ENEW
02200		PVT.	V,ENEW
02300	
02400	;CHECK FOR VERTEX BODY CASE.
02500		PED E1,F↔JUMPE E1,[
02600		PED. ENEW,F↔PED. ENEW,V
02700		PCW. ENEW,ENEW↔NCCW. ENEW,ENEW↔GO .+1]
02800	
02900	;LOWER WINGS POINT AT SELF.
03000		NCW. ENEW,ENEW
03100		PCCW. ENEW,ENEW
03200	
03300	;GET THE UPPER WINGS.
03400		PED E1,V↔LAC E2,E1
03500		NFACE 0,E1↔PFACE 1,E1
03600		CAMN 0,1↔GO L2
03700	L1:	LAC E1,E2
03800		SETQ(E2,{ECW,E1,V})
03900		CALL(FCW,E1,V)
04000		CAME 1,F↔GO L1
04100	
04200	;TIE ENEW TO ITS UPPER WINGS.
04300	L2:	PCW. E1,ENEW↔NCCW. E2,ENEW
04400		PVT 0,E1↔CAME 0,V↔GO[PCCW. ENEW,E1↔GO .+2]↔NCCW. ENEW,E1
04500		PVT 0,E2↔CAME 0,V↔GO[NCW.  ENEW,E2↔GO .+2]↔PCW.  ENEW,E2
04600		LAC 1,VNEW↔POP2J
04700		LIT
04800	BEND;1/14/73------------------------------------------------------
     

00100	;ENEW ← MKFE(V1,F,V2);		"J" COMMAND.
00200	SUBR(MKFE)--------------------------------------------------------
00300	BEGIN	MKFE
00400		ACCUMULATORS{V1,F,V2,FNEW,ENEW,E,E0,B,V}
00500	
00600	;FETCH THE ARGUMENTS.
00700		CDR V1,ARG3
00800		CDR  F,ARG2
00900		CDR V2,ARG1
01000	
01100	;DO THE CREATIONS.
01200		SETQ(B,{BGET,F})
01300		SETQ(FNEW,{MKF,B})
01400		SETQ(ENEW,{MKE,B})
01500	
01600	;LINK ENEW.
01700		PED. ENEW,F↔	PED. ENEW,FNEW
01800		PFACE. F,ENEW↔	NFACE. FNEW,ENEW
01900		PVT. V1,ENEW↔ 	NVT. V2,ENEW
02000	
02100	;GET THE UPPER WINGS.
02200		PED E,V1↔LAC E0,E↔MOVS 1(E)↔CAME 1(E)
02300		GO[L1: LAC E0,E↔ SETQ(E,{ECW,E0,V1})
02400		CALL(FCW,E0,V1)↔CAME 1,F↔GO L1↔GO .+1]
02500		DAC E0,E1#↔DAC E,E2#
02600	
02700	;GET THE LOWER WINGS.
02800		PED E,V2↔LAC E0,E↔MOVS 1(E)↔CAME 1(E)
02900		GO[L2: LAC E0,E↔ SETQ(E,{ECW,E0,V2})
03000		CALL(FCW,E0,V2)↔CAME 1,F↔GO L2↔GO .+1]
03100		DAC E0,E3#↔DAC E,E4#
03200	
03300	COMMENT .   					MKFE MANDALA
03400		        o--------o       o--------o
03500		        |   E2    \     /   E1    |
03600		        |   nccw   \   /   pcw    |
03700		        |           \ /		  |
03800		        |       pvt  ⊗  V1        |
03900		        |            |		  |
04000		        |     FNEW   ENEW    F    |
04100		        |            |		  |
04200		        |       nvt  ⊗  V2	  |
04300			|           / \		  |
04400		        |    ncw   /   \   pccw   |
04500		        |    E3   /     \    E4   |
04600		        o--------o       o--------o
04700	
04800	-----------------------------------------------------------------.
     

00100	;CDR V2'S TAIL REPLACING F'S WITH FNEW.
00200		LAC E,E3↔LAC V,V2
00300	L3:	MOVS 1,1(E)↔CAME 1,1(E)↔GO L4
00400		PFACE. FNEW,E
00450		SETQ(V,{OTHER,E,V})
00500		SETQ(E,{ECCW,E,V})↔GO L3
00600	
00700	;CCW FROM V1 REPLACING F'S WITH FNEW.
00800	L4:	LAC E0,E↔LAC E,E2↔SETZM A#↔CAMN E0,E2↔GO L6
00900	L5:	TESTZ E,WASP↔JSR WASPS
01000		NFACE 0,E
01100		CAME F,0
01200		GO[PFACE. FNEW,E↔GO .+2]
01300		   NFACE. FNEW,E
01400		CAME E,E0
01500		GO[DAC E,A↔SETQ(E,{ECCW,E,FNEW})↔GO L5]
01600	
01700	;LINK THE WINGS.
01800	L6:	CALL(WING,E1,ENEW)
01900		CALL(WING,E2,ENEW)
02000		CALL(WING,E3,ENEW)
02100		CALL(WING,E4,ENEW)
02200	L7:	LAC 1,ENEW↔POP3J
02300	
02400	WASPS:	0
02500	
02600		PCW  1,E↔CAMN 1,A↔GO W1
02700		PCCW 1,E↔CAME 1,A↔GO W2
02800	
02900	W1: 	SETZM A↔MARKZ E,WASP
03000		PFACE. FNEW,E↔SETQ(E,{ECCW,E,FNEW})
03100		TESTZ E,WASP↔GO W1↔GO @WASPS
03200	
03300	W2:	SETZM A↔MARKZ E,WASP
03400		NFACE. FNEW,E↔SETQ(E,{ECCW,E,FNEW})
03500		TESTZ E,WASP↔GO W2↔GO @WASPS
03600	
03700		LIT
03800	BEND;1/14/73------------------------------------------------------
     

00100	;VNEW ← ESPLIT(E);		"M" COMMAND.
00200	SUBR(ESPLIT)------------------------------------------------------
00300	BEGIN	ESPLIT
00400		ACCUMULATORS{VNEW,ENEW,B,E,V}
00500	
00600	;CHECK FOR BAD ARGUMENTS.
00700		CDR VNEW,ARG1
00800		LAC E,VNEW
00900		TEST E,EBIT↔GO L1
01000		PVT V,E
01100	
01200	;CREATE A NEW EDGE AND VERTEX.
01300		CCW B,E
01400		SETQ(VNEW,{MKV,B})
01500		SETQ(ENEW,{MKE,B})
01600		SLACI AA(E)↔LAPI AA(ENEW)↔BLT CC(ENEW)
01700	
01800	;PLACE VNEW BETWEEN E AND ENEW.
01900		PED 0,V↔CAMN 0,E↔PED. ENEW,V
02000		PED. ENEW,VNEW
02100		PVT 0,E↔PVT. 0,ENEW
02200		PVT. VNEW,E
02300		NVT. VNEW,ENEW
02400		PFACE 0,E↔PFACE. 0,ENEW
02500		NFACE 0,E↔NFACE. 0,ENEW
02600	
02700	;NEW UPPER WINGS ARE LIKE THE OLDE;
02800		PCW 0,E↔CALL(WING,0,ENEW)
02900		NCCW 0,E↔CALL(WING,0,ENEW)
03000	
03100	;EDGES POINT AT EACH OTHER ACROSS VNEW.
03200		NCCW. ENEW,E↔PCW.  ENEW,E
03300		NCW.  E,ENEW↔PCCW. E,ENEW
03400	L1:	LAC 1,VNEW↔POP1J
03500	
03600	BEND;1/14/73------------------------------------------------------ 
     

00100	;F ← KLFE(ENEW);		"K" COMMAND.
00200	SUBR(KLFE)--------------------------------------------------------
00300	BEGIN	KLFE
00400		ACCUMULATORS{ENEW,FNEW,V1,V2,E1,E2,E3,E4,E,F,B}
00500	
00600	;PICK THINGS UP.
00700		CDR ENEW,ARG1
00800		PFACE F,ENEW↔	NFACE FNEW,ENEW
00900		PVT V1,ENEW↔	NVT V2,ENEW
01000	
01100	;GET THE WINGS.
01200		PCW  E1,ENEW
01300		NCCW E2,ENEW
01400		NCW  E3,ENEW
01500		PCCW E4,ENEW
01600	
01700	;GET RID OF ENEW APPEARANCES IN F & V.
01800		PED 0,V1↔ CAMN 0,ENEW↔ PED. E1,V1
01900		PED 0,V2↔ CAMN 0,ENEW↔ PED. E3,V2
02000		PED 0,F ↔ CAMN 0,ENEW↔ PED. E3,F
02100	
02200	;GET RID OF FNEW APPEARANCES
02300		LAC E,E2
02400	L1:	PFACE 0,E↔CAMN 0,FNEW↔GO[PFACE. F,E↔GO L2]
02500		NFACE 0,E↔CAMN 0,FNEW↔GO[NFACE. F,E↔GO L2]
02600		FATAL(KLFE)
02700	L2:	CAME E,E3↔GO[SETQ(E,{ECCW,E,F})↔GO L1]
02800	
02900	;LINK WINGS TOGETHER ABOUT F.
03000		CALL(WING,E2,E1)
03100		CALL(WING,E4,E3)
03200	
03300	;GET RID OF FNEW AND ENEW.
03400		CCW B,ENEW
03500		CALL(KLF,B,FNEW)
03600		CALL(KLE,B,ENEW)
03700		LAC 1,F↔POP1J
03800	
03900	BEND;1/14/73------------------------------------------------------
     

00100	;E ← KLEV(VNEW);		"K" COMMAND.
00200	SUBR(KLEV)--------------------------------------------------------
00300	BEGIN	KLEV
00400		ACCUMULATORS{E,ENEW,V,VNEW,F,B}
00500		CDR VNEW,ARG1↔PED ENEW,VNEW
00600		SETQ(E,{ECCW,ENEW,VNEW})
00700		CAMN E,ENEW↔GO[SETQ(V,{OTHER,ENEW,VNEW})	;EAT WIRE.
00800		SETQ(E,{ECCW,ENEW,V})↔NCW. E,E↔PCCW. E,E↔GO L1]
00900		CALL(ECCW,E,VNEW)↔CAME 1,ENEW
01000		GO[CALL(KLFE,1)↔GO KLEV]
01100	
01200	;ORIENT EDGES AS IN MANDALA.
01300		NVT 0,ENEW↔CAMN 0,VNEW↔GO .+3↔CALL(INVERT,ENEW)
01400		PVT 0,E↔CAMN 0,VNEW↔GO .+3↔CALL(INVERT,E)
01500	;TIE E TO ITS NEW VERTEX.
01600		PVT V,ENEW↔ PVT. V,E
01700	;MAKE E'S UPPER WINGS LIKE ENEW'S.
01800		PCW 0,ENEW↔CALL(WING,0,E)
01900		NCCW 0,ENEW↔CALL(WING,0,E)
02000	
02100	;ELIMINATE OCCURENCES OF ENEW IN F & V.
02200	L1:	PED 0,V↔ CAMN 0,ENEW↔ PED. E,V
02300		PFACE F,E↔ PED 0,F↔ CAMN 0,ENEW↔ PED. E,F
02400		NFACE F,E↔ PED 0,F↔ CAMN 0,ENEW↔ PED. E,F
02500	;PURGE 'EM.
02600		CCW B,ENEW
02700		CALL(KLV,B,VNEW)
02800		CALL(KLE,B,ENEW)
02900		LAC 1,E↔SLAC 1(1)↔CAMN 1(1)↔NVT 1,1
02950		POP1J↔LIT
03000	COMMENT .        \  pvt  /	KLEV MANDALA
03100	                  \     /
03200	            nccw   \   /   pcw
03300	                    \ /
03400	                  V  ⊗
03500	                     |
03600	                ENEW |
03700	                     | nvt
03800	                VNEW ⊗
03900	                     | pvt
04000	                   E |
04100	                     |
04200	                     ⊗
04300	                    / \
04400	             ncw   /   \   pccw
04500	                  /     \
04600	                 /  nvt  \					.
04700	BEND;1/14/73------------------------------------------------------
     

00100	; V ← KLVE(E) - KILL E & NVT(E) RETURNING PVT(E).
00200	SUBR(KLVE)--------------------------------------------------------
00300	BEGIN KLVE
00400		ACCUMULATORS{A,E,E1,E2,E3,E4,V1,V2,S12}
00500	
00600	;PICK THINGS UP.
00700		CDR E,ARG1↔NVT V1,E↔PVT V2,E
00800		PCW E1,E↔NCCW E2,E↔NCW E3,E↔PCCW E4,E
00900	
01000	;REPLACE FACE-VERTEX PED'S THAT MIGHT CONTAIN E.
01100		PFACE 1,E↔PED 0,1↔CAMN 0,E↔PED. E1,1
01200		NFACE 1,E↔PED 0,1↔CAMN 0,E↔PED. E2,1
01300		PED 0,V2↔CAMN 0,E↔PED. E2,V2
01400	
01500	;REPLACE V1 WITH V2.
01600		LAC A,E3
01700	L1:	PVT 1,A↔CAME 1,V1↔GO[NVT. V2,A↔GO .+2]↔PVT. V2,A
01800	  	SETQ(A,{ECCW,A,V2})
01900		CAME A,E↔GO L1
02000	
02100	;SPLICE WINGS TOGETHER.
02200		CALL(WING,E1,E4)
02300		CALL(WING,E2,E3)
02400	
02500	;BURN THE GARBAGE.
02600		CCW A,E
02700		CALL(KLE,A,E)
02800		CALL(KLV,A,V1)
02900		LAC 1,V2
03000		POP1J
03100		LIT
03200	BEND;1/14/73------------------------------------------------------
03300	COMMENT .  KLVE MANDALA
03400	            E2    \     /   E1
03500	            nccw   \   /   pcw
03600	                    \ /
03700	                pvt  ⊗  V2
03800	                     |
03900	                     |  E
04000	                     |
04100	                nvt  ⊗  V1
04200	                    / \
04300	             ncw   /   \   pccw
04400	             E3   /     \    E4.
     

00100	;BNEW ← MKCOPY(B).
00200	SUBR(MKCOPY)------------------------------------------------------
00300	BEGIN MKCOPY
00400		ACCUMULATORS{B,F,E,V,BNEW,Q,A}
00500		EXTERN MKFRAME
00600		LAC B,ARG1↔LACM 1,(B)↔SKIPE 1↔TLNE 1,(1B9)↔GO[
00800		CALL(MKNODE,[0])↔SLACI XWC(B)↔LAPI XWC(1)↔BLT KZ(1)↔POP1J]
01000		TEST B,BBIT↔POP1J↔SETQ(BNEW,{MKB,B})
01100		FRAME Q,B↔SKIPE Q↔GO[CALL(MKFRAME)↔FRAME. 1,BNEW
01200		SLACI XWC(Q)↔LAPI XWC(1)↔BLT KZ(1)↔GO .+1]
01300		LAC B,ARG1↔LAC F,B↔LAC E,B↔LAC V,B
01400	
01500	;FOR ALL THE EDGES OF THE BODY.
01600	L1:	PED E,E↔TEST E,EBIT↔GO L2
01700		SETQ(Q,{MKE,BNEW})↔ALT. Q,E↔GO L1
01800	
01900	;FOR ALL THE FACES OF THE BODY.
02000	L2:	PFACE F,F↔TEST F,FBIT↔GO L3
02100		SETQ(Q,{MKF,BNEW})↔ALT. Q,F
02200		PED A,F↔ALT A,A↔PED. A,Q
02300		LAC QQ(F)↔DAC QQ(Q)↔GO L2
02400	
02500	;FOR ALL THE VERTICES OF THE BODY.
02600	L3:	PVT V,V↔TEST V,VBIT↔GO L4
02700		SETQ(Q,{MKV,BNEW})↔ALT. Q,V
02800		PED A,V↔ALT A,A↔PED. A,Q
02900		SLACI XWC(V)↔LAPI XWC(Q)↔BLT ZWC(Q)↔GO L3
03000	
03100	;FOR ALL THE EDGES OF THE BODY.
03200	L4:	PED E,E↔TEST E,EBIT↔GO L5
03300		ALT Q,E
03400		PVT V,E↔  ALT V,V↔PVT. V,Q
03500		NVT V,E↔  ALT V,V↔NVT. V,Q
03600		PFACE F,E↔ALT F,F↔PFACE. F,Q
03700		NFACE F,E↔ALT F,F↔NFACE. F,Q
03800		NCW A,E↔  ALT A,A↔NCW. A,Q
03900		PCW A,E↔  ALT A,A↔PCW. A,Q
04000		NCCW A,E↔ ALT A,A↔NCCW. A,Q
04100		PCCW A,E↔ ALT A,A↔PCCW. A,Q↔GO L4
     

00100	L5:	SETZ↔LAC 1,BNEW↔SKIPA E,ARG1
00200	L6:	ALT. 0,E↔PED E,E↔CAME E,ARG1↔GO L6
00300	;PARTS OF THIS BODY.
00400		LAC B,ARG1↔TESTZ B,BDPBIT↔POP1J
00500		SON Q,B↔JUMPE Q,POP1J.
00600	L7:	PUSH P,Q↔PUSH P,BNEW↔CALL(MKCOPY,Q)
00800		LAC BNEW,(P)↔CALL(BATT,1,BNEW)
00900		POP P,BNEW↔POP P,Q↔LAC B,ARG1
01000		BRO Q,Q↔SON 0,B↔CAME 0,Q↔GO L7
01100		LAC 1,BNEW↔POP1J
01200	BEND;1/14/73------------------------------------------------------
     

00100	;ENEW ← GLUEE(F1,V1,F2,V2)  -  LIKE TWO MKEV(F,V)'S BACK TO BACK.
00200	SUBR(GLUEE)-------------------------------------------------------
00300	BEGIN GLUEE
00400		Q←1
00500		ACCUMULATORS{F1,V1,F2,V2,B,E,E1,E2,E3,E4}
00600		CDR F1,ARG4↔CDR V1,ARG3
00700		CDR F2,ARG2↔CDR V2,ARG1
00800	;BODY SPLICING.
00900		PED E,F1↔CCW B,E
01000		PED E,F2
01100	
01200	;REPLACE F2 WITH F1.
01300		PED E,F2↔DAC E,E0#
01400	L1:	PFACE Q,E↔CAMN Q,F2↔PFACE. F1,E
01500	        NFACE Q,E↔CAMN Q,F2↔NFACE. F1,E
01600		SETQ(E,{ECCW,E,F1})
01700		CAME E,E0↔GO L1
01800		CALL(KLF,B,F2)
01900		
     

00100	COMMENT .				GLUEE MANDALA
00200	
00300		|	|	|
00400		|      +V2	|
00500		|     / | \     |
00505		|    /  |  \    |
00600	NCCW	| E2/   |   \E1 |	PCW
00606	       	|  /    |    \  |
00700		| /  F2 |  F2 \ |
00800		o______ | ______o
00900			|		HOWEVER,
01000		  WASP	| ENEW		GLUEE RETURN'S ENEW INVERTED
01100		o______ | ______o
01200		|\      |      /|
01300		| \  F1 |  F1 / |
01400		|  \    |    /  |
01500	NCW	| E3\   |   /E4 |	PCCW
01600		|    \  |  /    |
01700		|     \ | /     |
01800		|      -V1	|
01900		|	|	|
02000	        |	|	|				.
02100	;EDGE CREATION
02200		SETQ(E,{MKE,B})
02300		MARK E,WASP
02400		NFACE. F1,E↔PFACE. F1,E
02500		NVT. V1,E↔PVT. V2,E
02600	
02700	;MAKE WINGS
02800		SETQ(E1,{ECW,V2,F1})↔PCW.  E1,E
02900		SETQ(E2,{ECW,E1,V2})↔NCCW. E2,E
03000		SETQ(E3,{ECW,V1,F1})↔NCW.  E3,E
03100		SETQ(E4,{ECW,E3,V1})↔PCCW. E4,E
03200	
03300		PVT Q,E1↔CAME Q,V2↔GO[PCCW. E,E1↔GO .+2]↔NCCW. E,E1
03400		PVT Q,E2↔CAME Q,V2↔GO[NCW.  E,E2↔GO .+2]↔PCW.  E,E2
03500		PVT Q,E3↔CAME Q,V1↔GO[PCCW. E,E3↔GO .+2]↔NCCW. E,E3
03600		PVT Q,E4↔CAME Q,V1↔GO[NCW.  E,E4↔GO .+2]↔PCW.  E,E4
03700	
03800	;MARK WASP WAIST ON POTENTIAL SPUR STARTING AT V1.
03900		CAME E1,E2↔GO L2
04000		MARK E1,WASP↔PVT V1,E1↔PED E1,V1
04100		MOVS Q,1(E1)↔CAMN Q,1(E1)↔GO .-5
04200	
04300	L2:	LAC Q,E↔CALL(INVERT,Q)↔POP4J
04400		LIT
04500	BEND;1/14/73------------------------------------------------------
     

00100	SUBR(GLUE)F1,F2---------------------------------------------------
00200	BEGIN GLUEFF;GLUE TWO FACES TOGETHER - BGB 10 FEBRUARY 1973.
00300		EXTERN DISTAN
00400	;ARGUMENTS MUST BE FACES WITH THE SAME NUMBER OF VERTICES.
00500		LAC 1,ARG1↔DAC 1,F1↔TEST 1,FBIT↔POP2J
00600		LAC 1,ARG2↔DAC 1,F2↔TEST 1,FBIT↔POP2J
00700		LAC 1,F1↔PED 2,1↔DAC 2,E↔DAC 2,E0↔LACI 10,1
00800	L1:	SETQ(E,{ECCW,E,F1})↔CAME 1,E0↔AOJA 10,L1↔DAC 10,NN
00900		LAC 1,F2↔PED 2,1↔DAC 2,E↔DAC 2,E0↔SOS 10
01000	L2:	SETQ(E,{ECCW,E,F2})↔CAME 1,E0↔SOJA 10,L2↔SKIPE 10↔POP2J
01100	
01200	;FIND V2 CLOSEST TO V1.
01300		LAC 1,F1↔PED 2,1↔SETQ(V1,{VCW,2,1})
01400		HRLOI 377777↔DAC MIN
01500		SETZM LIST1↔SETZM LIST2
01600	L3:	SETQ(V,{VCW,E,F2})
01700		CALL(DISTAN,V,V1)
01800		CAMGE 1,MIN↔GO[DAC 1,MIN↔LAC V↔DAC V2↔GO .+1]
01900		LAC 1,E↔LAC LIST1↔DAP -1(1)↔DAC 1,LIST1
02000		LAC 1,V↔LAC LIST2↔DAP -1(1)↔DAC 1,LIST2
02100		SETQ(E,{ECCW,E,F2})
02200		CAME 1,E0↔GO L3
02300		CALL(GLUEE,F1,V1,F2,V2)
02400		CALL(INVERT,1)
02500	
02600	;CLOSE UP THE GAP.
02700		SOS NN
02800	L4:	PCCW 0,1↔PUSH P,0↔PCW 0,1↔PUSH P,0
02900		SETQ(V2,{OTHER,V2})↔SETQ(V1,{OTHER,V1})
03000		CALL(MKFE,V2,F1,V1)↔SOSLE NN↔GO L4
03100	
03200	;NOW KILL ALL THOSE EDGES.
03300	L5:	SKIPN 1,LIST1↔GO L6↔CDR 0,-1(1)↔DAC 0,LIST1
03400		CALL(KLFE,1)↔GO L5
03500	L6:	SKIPN 1,LIST2↔GO L7↔CDR 0,-1(1)↔DAC 0,LIST2
03600		CALL(KLEV,1)↔GO L6
03700	
03800	L7:	LAC 1,F1↔PED 1,1↔CCW 1,1
03900		POP2J
04000	DECLARE{F1,F2,V,V1,V2,NN,E,E0,MIN,LIST1,LIST2}
04100	BEND;2/10/73------------------------------------------------------
     

00100	SUBR(SWEEP)FACE,FLAG----------------------------------------------
00200	BEGIN SWEEP
00300	
00400	;TEST FOR VALID ARGUMENT.
00500		LAC 1,ARG2↔DAC 1,F↔TEST 1,FBIT↔POP2J
00600		PED 2,1↔DAC 2,E↔SKIPN 2↔POP2J
00700		TEST 2,EBIT↔POP2J
00800	
00900	;TEST FOR SPECIAL CASES.
01000		PCW 3,2↔CAMN 3,2↔GO SWEEP2		;WIRE SWEEP CASE.
01100		SETZM E0↔NCNT 0,1↔DACM NN
01200		SKIPE↔SETZM ARG1
01300	
01400	;MAKE FIRST SPOKE.
01500		CALL(VCW,E,F)↔DAC 1,U0↔DAC 1,U1
01600		CALL(MKEV,F,U0)↔DAC 1,V0↔DAC 1,V1
01700	
01800	;COPY FACE PERIMETER LOOP.
01900	L1:	SETQ(U2,{VCCW,E,F})		;ADVANCE ALONG RIM.
02000		SETQ(E,{ECCW,E,F})
02100		LAC 1,U2↔CAME 1,U0		;MAKE NEXT SPOKE.
02200		GO[CALL(MKEV,F,U2)↔GO .+2]
02300		LAC 1,V0↔DAC 1,V2
02400		CALL(MKFE,V1,F,V2)		;CONNECT SPOKES.
02500		SKIPN E0↔DAC 1,E0		;NEW FIRST EDGE.
02600	
02700	;SPLIT NEW FACE TO MAKE PRISMOIDS.
02800		NFACE 0,1
02900		SKIPGE ARG1↔GO[CALL(MKFE,V1,0,U2)↔GO .+3] ;CW -1.
03000		SKIPLE ARG1↔GO[CALL(MKFE,U1,0,V2)↔GO .+1] ;CCW +1.
03100	
03200	;TEST FOR END OF COPY LOOP.
03300		LAC V2↔DAC V1
03400		LAC U2↔DAC U1
03500		SOSN NN↔GO .+3
03600		CAME U0↔GO L1		;EXIT WHEN NN=0 OR U2=U0
03700	;EXIT.
03800		LAC 0,E0↔LAC 1,F
03900		PED. 0,1↔POP2J
04000	
04100	DECLARE{F,E,E0,U0,U1,U2,V0,V1,V2,NN}
04200	COMMENT .	U2 o----------o U1	FACE SWEEP MANDALA
04300			  / \        / \
04400		         /   \ FNEW /   \
04500		        /     \____/     \
04600		       /     v2    v1	  \
04700	              /         F          \.
04800	BEND;2/7/73-------------------------------------------------------
     

00100	SWEEP2:;FACE,FLAG-------------------------------------------------
00200	BEGIN SWEEP2;WIRE FACE SWEEP - BGB - 7 FEB 1973.
00300	
00400	;COUNT THE EDGES IN THE WIRE.
00500		LAC 3,ARG2↔DAC 3,FACE		;FACE
00600		PED 1,3↔LACI 0,1		;EDGE & NCNT.
00700		LAC 2,1↔NCW 1,1
00800		CAME 1,2↔AOJA 0,.-3		;COUNT THE EDGES.
00900	
01000	;MAKE "BOTTOM" EDGE.
01100		DAC 1,E				;LAST EDGE.
01200		NCNT. 0,3↔DAC NN
01300		NVT 1,1				;LAST VERTEX OF THE WIRE.
01400		SETQ(V2,{MKEV,FACE,1})		;BOTTOM EDGE.
01500	
01600	;COPY THE WIRE.
01700	L1:	SETQ(V2,{MKEV,FACE,V2})
01800		LAC 3,E↔PVT 2,3↔DAC 2,V1
01900		SLACI XWC(2)↔LAPI XWC(1)↔BLT ZWC(1)
02000		PCW 2,3↔DAC 2,E↔CAME 2,3↔GO L1
02100	
02200	;CLOSE THE TOP.
02300		SETQ(E,{MKFE,V1,FACE,V2})
02400		NFACE 1,1↔DAC 1,FNEW
02500		SOSG NN↔GO L3
02600	
02700	;FOLLOW DOWN BOTH SIDES.
02800	L2:	CALL(ECCW,E,FNEW)↔SETQ(V1,{OTHER,1,V1})
02900		CALL(ECW,E,FNEW)↔SETQ(V2,{OTHER,1,V2})
03000		SETQ(E,{MKFE,V2,FNEW,V1})
03100		SOSLE NN↔GO L2
03200	
03300	;UPDATE THE FIRST EDGE OF THE FACE.
03400	L3:	LAC 2,ARG2↔PED 1,2
03500		CALL(ECCW,1,2)↔PED. 1,2
03600		LAC 1,2↔POP2J
03700	
03800	COMMENT .	⊗	⊗-------⊗		⊗-------⊗
03900		      + |	|	|		|	|
04000		PED(F)	|	|	|		|	|PED(F)'
04100		      - |	|	|		|	|
04200			⊗	⊗	⊗	    V1→ ⊗-------⊗ ←V2
04300		      + |	|	|		|	|
04400			|	| FNEW	| F below	|	|
04500		      - |	|	|		|	|
04600			⊗	⊗	⊗		⊗ FNEW 	⊗
04700		      + |	|	|		|	|
04800			|	|	|		|	|
04900		      - |	|	|		|	|
05000			⊗	⊗-------⊗		⊗-------⊗	.
05100	DECLARE{FACE,FNEW,NN,V1,V2,E}
05200	BEND;2/7/73-------------------------------------------------------
     

00100	SUBR(ROTCOM)FACE--------------------------------------------------
00200	BEGIN ROTCOM;SOLID OF ROTATION COMLETION - BGB -8 FEB 1973.
00300		ACCUMULATORS{F,E,E0,M,N}
00400		LAC F,ARG1↔DAC F,FACE↔TEST F,FBIT↔POP1J
00500		NCNT N,F↔DACM N,NN↔SKIPN↔POP1J
00600	
00700	;COUNT THE EDGES IN THIS FACE.
00800		LACI M,1↔PED E,F↔DAC E,E0↔DAC E,EDGE
00900	L1:	SETQ(E,{ECCW,E,F})
01000		CAME E,E0↔AOJA M,L1
01100	
01200	;SKIP AROUND THE NORTH POLE CAP.
01300		ASH M,-1↔SUB M,NN
01400		SETQ(V1,{VCW,EDGE,FACE})
01500		LAC 1,EDGE
01600	L2:	CALL(ECW,1,FACE)↔SOJG M,L2
01700		SETQ(V2,{VCW,1,FACE})
01800		SETQ(EDGE,{MKFE,V2,FACE,V1})	;CLOSE THE TOP OF THE GAP.
01900	
02000	;FOLLOW DOWN THE GAP.
02100	L3:	CALL(ECCW,EDGE,FACE)↔SETQ(V1,{OTHER,1,V1})
02200		CALL(ECW,EDGE,FACE)↔SETQ(V2,{OTHER,1,V2})
02300		SETQ(EDGE,{MKFE,V2,FACE,V1})
02400		SOSLE NN↔GO L3
02500		SETZ↔LAC 1,FACE↔NCNT. 0,1
02600		POP1J
02700	COMMENT .
02800		⊗---⊗---⊗----⊗---⊗
02900		|      GAP	 |	← POLE CAP
03000		|       ↓ 	 |
03100		⊗-----⊗←←←←⊗-----⊗	← ARTIC CIRCLE
03200	       PED(F)→|    |
03300		      |    |
03400		  V1' ⊗←←←←⊗ V2'
03500		      | F  |
03600		      |    |
03700	        ⊗-----⊗    ⊗-----⊗	← ANTARTIC CIRCLE.
03800	
03900	DECLARE{FACE,EDGE,V1,V2,NN}
04000	BEND;2/8/73-------------------------------------------------------
     

00100	SUBR(PYRAMID)FACE OR VERTEX---------------------------------------
00200	BEGIN PYRAMID
00300	
00400		LAC 1,ARG1↔TEST 1,VBIT↔GO L2
00500	;VERTEX ARGUMENT - GIVEN THE PEAK FORM THE BASE.
00600		DAC 1,V
00700		PED 2,1↔DAC 2,E0↔DAC 2,E2
00800		SETQ(V2,{OTHER,E2,V})
00900	L1:	LAC E2↔DAC E1
01000		LAC V2↔DAC V1
01100		SETQ(E2,{ECCW,E1,V})
01200		SETQ(V2,{OTHER,E2,V})
01300		CALL(LINKED,V1,V2)↔JUMPE 1,[	;WHEN NOT LINKED.
01400		CALL(FCCW,E1,V)
01500		CALL(MKFE,V1,1,V2)↔GO .+1]
01600		LAC E2↔CAME E0↔GO L1
01700		LAC 1,ARG1↔POP1J
01800		DECLARE{V,V1,V2,E0,E1,E2}
01900	
02000	;FACE ARGUMENT - GIVEN THE BASE FORM THE PEAK.
02100	L2:	DAC 1,F↔TEST 1,FBIT↔POP1J
02200		SETZM X↔SETZM Y↔SETZM Z↔SETZM N
02300		PED 2,1↔DAC 2,E↔DAC 2,E0
02400		SETQ(V0,{VCW,E0,F})
02500		SETQ(PEAK,{MKEV,F,V0})
02600	L3:	SETQ(V,{VCCW,E,F})
02700		LAC XWC(1)↔FADRM X
02800		LAC YWC(1)↔FADRM Y
02900		LAC ZWC(1)↔FADRM Z
03000		AOS N↔CAMN 1,V0↔GO L4
03100		SETQ(E,{ECCW,E,F})
03200		CALL(MKFE,PEAK,F,V)
03300		GO L3
03400	L4:	LAC 1,PEAK↔LAC 2,N↔FLOAT 2,
03500		LAC X↔FDVR 2↔DAC XWC(1)
03600		LAC Y↔FDVR 2↔DAC YWC(1)
03700		LAC Z↔FDVR 2↔DAC ZWC(1)
03800		POP1J
03900		DECLARE{PEAK,F,E,V0,X,Y,Z,N}
04000	
04100	BEND;2/8/73-------------------------------------------------------
     

00100	SUBR(REMOVF)FACE-------------------------------------------------
00200	BEGIN REMOVE; REMOVE A FACE FROM A POLYHEDRON - BGB - 7 FEB 1973.
00300		LAC 1,ARG1↔TEST 1,FBIT↔POP1J↔DAC 1,F
00400		PED 2,1↔DAC 2,E
00500		SETQ(V0,{VCW,E,F})
00600		SETQ(V,{VCCW,E,F})↔SLACI XWC(1)↔LAPI X↔BLT Z
00700		SETQ(A,{ECCW,E,F})
00800		SETQ(F,{KLFE,E})
00900		LACI 1↔DAC N
01000	L1:	LAC 1,A↔DAC 1,E
01100		PVT 0,1↔CAMN 0,V↔GO[CALL(INVERT,E)↔GO .+1]
01200		SETQ(A,{ECCW,A,F})
01300		SETQ(V,{KLVE,E})
01400		LAC XWC(1)↔FADRM X
01500		LAC YWC(1)↔FADRM Y
01600		LAC ZWC(1)↔FADRM Z↔AOS N
01700		CAME 1,V0↔GO L1
01800	;PLACE VERTEX AT CENTER OF DECEASED FACE.
01900		LAC 2,N↔FLOAT 2,
02000		LAC X↔FDVR 2↔DAC XWC(1)
02100		LAC Y↔FDVR 2↔DAC YWC(1)
02200		LAC Z↔FDVR 2↔DAC ZWC(1)
02300		POP1J
02400	DECLARE{F,E,V,V0,A,X,Y,Z,N}
02500	BEND;2/10/73-----------------------------------------------------
     

00100	SUBR(FVDUAL)BODY-------------------------------------------------
00200	BEGIN FVDUAL; FACE-VERTEX DUAL - BGB - 20 FEBRUARY 1973.
00300		ACCUMULATORS{B,F,E,V,E0,X,Y,Z,I}
00400		LAC B,ARG1↔TEST B,BBIT↔POP1J
00500	
00600	;FOR ALL THE FACES OF THE BODY.
00700		LAC F,B
00800	L1:	PFACE F,F↔TEST F,FBIT↔GO L3
00900		SETZB X,Y↔SETZB Z,I
01000		PED E,F↔DAC E,E0
01100	
01200	;COMPUTE CENTER OF EACH FACE.
01300	L2:	SETQ(V,{VCCW,E,F})
01400		SETQ(E,{ECCW,E,F})
01500		FADR X,XWC(V)↔FADR Y,YWC(V)↔FADR Z,ZWC(V)
01600		AOS I
01700		CAME E,E0↔GO L2
01800	
01900	;CONVERT FACES INTO VERTICES.
02000		FLOAT I,↔FDVR X,I↔FDVR Y,I↔FDVR Z,I
02100		DAC X,XWC(F)↔DAC Y,YWC(F)↔DAC Z,ZWC(F)
02200		LAC 1(F)↔DAC 3(F)↔SLACI(VBIT)↔DAC(F)
02300		GO L1
02400	
02500	;CONVERT VERTICES INTO FACES.
02600	L3:	LAC V,ARG1↔LACI 1,2↔LAC E,ARG1
02700	L4:	PVT V,V↔TEST V,VBIT↔GO L5
02800		LAC 3(V)↔DAC 1(V)↔DIP 1,(V)↔GO L4
02900	
03000	;TURN ALL THE EDGES OVER AND INSIDE OUT.
03100	L5:	PED E,E↔TEST E,EBIT↔GO L6
03200		LAC 1(E)↔EXCH 3(E)↔DAC 1(E)
03300		MOVSS 1(E)
03400		MOVS 4(E)↔MOVE 1,5(E)
03500		DAC 1,4(E)↔DAC 5(E)
03600		GO L5
03700	
03800	L6:	LAC B,ARG1↔LAC 1(B)↔EXCH 3(B)↔DAC 1(B)
03900		POP1J
04000	BEND;2/10/73-----------------------------------------------------
     

00100	SUBR(MKCUBE)DX,DY,DZ --------------------------------------------
00200	BEGIN MKCUBE; MAKE A CUBE WITH SIDES DX, DY, DZ.
00300	
00400		SETQ(B,{MKB,[0]})
00500		SETQ(F,{MKF,B})
00600		SETQ(V,{MKV,B})
00700		LAC ARG3↔FSC -1↔DAC XWC(1)
00800		LAC ARG2↔FSC -1↔DAC YWC(1)
00900		LAC ARG1↔FSC -1↔DAC ZWC(1)
01000		CALL(MKEV,F,1)↔MOVNS XWC(1)
01100		CALL(MKEV,F,1)↔MOVNS YWC(1)
01200		CALL(MKEV,F,1)↔MOVNS XWC(1)
01300		CALL(MKFE,V,F,1)
01400		CALL(SWEEP,F,[0])
01500		LAC 1,B
01600		NVT 1,1↔MOVNS ZWC(1)
01700		NVT 1,1↔MOVNS ZWC(1)
01800		NVT 1,1↔MOVNS ZWC(1)
01900		NVT 1,1↔MOVNS ZWC(1)
02000		LAC 1,B↔POP3J
02100		DECLARE{B,F,V}
02200	BEND MKCUBE; 16 MARCH 1973 --------------------------------------
02300	
02400	
02500	END
02600	EULER.FAI - EOF.