perm filename EULER[GEM,BGB]4 blob sn#041568 filedate 1973-05-08 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00023 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00004 00002	TITLE EULER  -  EULER  PRIMITIVES  -  JULY 1972.
C00006 00003	SUBR(INVERT)------------------------------------------------------
C00008 00004	VNEW ← MKEV(F,V).  "E" COMMAND.
C00010 00005	ENEW ← MKFE(V1,F,V2)		"J" COMMAND.
C00013 00006	CDR V2'S TAIL REPLACING F'S WITH FNEW.
C00015 00007	VNEW ← ESPLIT(E)		"M" COMMAND.
C00017 00008	F ← KLFE(ENEW)		"K" COMMAND.
C00019 00009	E ← KLEV(VNEW)		"K" COMMAND.
C00022 00010	 V ← KLVE(E) - KILL E & NVT(E) RETURNING PVT(E).
C00024 00011	BNEW ← MKCOPY(B).
C00025 00012	MKCOPY CONTINUED
C00028 00013	L5:	SETZ↔LAC 1,BNEW↔SKIPA E,ARG1
C00029 00014	ENEW ← GLUEE(F1,V1,F2,V2)  -  LIKE TWO MKEV(F,V)'S BACK TO BACK.
C00030 00015	.				GLUEE MANDALA
C00032 00016	SUBR(GLUE)F1,F2---------------------------------------------------
C00035 00017	SUBR(SWEEP)FACE,FLAG----------------------------------------------
C00038 00018	SWEEP2:FACE,FLAG-------------------------------------------------
C00041 00019	SUBR(ROTCOM)FACE--------------------------------------------------
C00043 00020	SUBR(PYRAMID)FACE OR VERTEX---------------------------------------
C00045 00021	SUBR(REMOVF)FACE-------------------------------------------------
C00047 00022	SUBR(FVDUAL)BODY-------------------------------------------------
C00049 00023	SUBR(MKCUBE)DX,DY,DZ --------------------------------------------
C00050 ENDMK
C⊗;
TITLE EULER  -  EULER  PRIMITIVES  -  JULY 1972.
	
COMMENT /
These primitives preserve the Euler Equation F-E+V = 2*B-2*H;

	INVERT(E);			"|" COMMAND.
	EVERT(B);			"¬" COMMAND.
	VNEW ← MKEV(F,V);		"E" COMMAND.
	ENEW ← MKFE(V1,F,V2);		"J" COMMAND.
	VNEW ← ESPLIT(E);		"M" COMMAND.
	   F ← KLFE(ENEW);		"K" COMMAND.
	   E ← KLEV(VNEW);		"K" COMMAND.
	   V ← KLVE(ENEW);     	        "αK" COMMAND.
	BNEW ← MKCOPY(B);		"C" COMMAND.
	ENEW ← GLUEE(F1,V1,F2,V2);	"J" COMMAND.
/

;THE EULER PRIMITVES ARE DEPENDENT ON THE WING OPERATIONS.
	EXTERN MKNODE,KLNODE
	EXTERN MKB,MKF,MKE,MKV
	EXTERN KLB,KLF,KLE,KLV,WING
	EXTERN WING,LINKED
	EXTERN ECW,ECCW,OTHER,OTHER.
	EXTERN BGET,FCW,FCCW,VCW,VCCW
	EXTERN BATT,BDET

;BIT FOR MARKING EDGES OF A WASP FACE'S WAIST.
	↓WASP←←1B5
SUBR(INVERT)------------------------------------------------------
BEGIN INVERT
	LAC 1,ARG1
	MOVSS 1(1)↔MOVSS 3(1)↔MOVSS 4(1)↔MOVSS 5(1)
	MOVNS -3(1)↔MOVNS -2(1)↔MOVNS -1(1)
	POP1J
BEND;1/14/73------------------------------------------------------

;EVERT(B) - TURN BODY INSIDE OUT.
SUBR(EVERT)BODY --------------------------------------------------
BEGIN EVERT; TURN SOMETHING INSIDE OUT.
	ACCUMULATORS{B,E}
	CDR B,ARG1
	TEST B,BBIT↔POP1J
	LAC E,B
L1:	PED E,E
	TEST E,EBIT↔GO L3
	MOVSS 1(E)
	MOVS  4(E)↔MOVS 1,5(E)
	DAC 1,4(E)↔DAC 5(E)
	GO L1

;PARTS OF THIS BODY.
L3:	SON 1,B↔JUMPE 1,POP1J.
L4:	PUSH P,1↔CALL(EVERT,1)
	POP P,1↔LAC B,ARG1
	BRO 1,1↔SON 0,B
	CAME 0,1↔GO L4↔POP1J
BEND;1/14/73------------------------------------------------------
;VNEW ← MKEV(F,V).  "E" COMMAND.
SUBR(MKEV)--------------------------------------------------------
BEGIN	MKEV
	ACCUMULATORS {VNEW,B,F,V,ENEW,E1,E2}

;CHECK FOR BAD ARGUMENTS.
	CDR VNEW,ARG1;FOR BAD RETURNS.
	LAC V,ARG1↔TEST(V,VBIT)↔POP2J
	LAC F,ARG2↔TEST(F,FBIT)↔POP2J

;CREATE A NEW EDGE AND VERTEX.
	SETQ(B,{BGET,V})
	SETQ(VNEW,{MKV,B})
	SLACI XWC(V)↔LAPI XWC(VNEW)↔BLT ZWC(VNEW)
	LAC 1(V)↔DAC 1(VNEW)
	SETQ(ENEW,{MKE,B})

;MAKE FACE AND VERTEX LINKS.
	PED. 	ENEW,VNEW
	NFACE.	F,ENEW
	PFACE.	F,ENEW
	NVT.	VNEW,ENEW
	PVT.	V,ENEW

;CHECK FOR VERTEX BODY CASE.
	PED E1,F↔JUMPE E1,[
	PED. ENEW,F↔PED. ENEW,V
	PCW. ENEW,ENEW↔NCCW. ENEW,ENEW↔GO .+1]

;LOWER WINGS POINT AT SELF.
	NCW. ENEW,ENEW
	PCCW. ENEW,ENEW

;GET THE UPPER WINGS.
	PED E1,V↔LAC E2,E1
	NFACE 0,E1↔PFACE 1,E1
	CAMN 0,1↔GO L2
L1:	LAC E1,E2
	SETQ(E2,{ECW,E1,V})
	CALL(FCW,E1,V)
	CAME 1,F↔GO L1

;TIE ENEW TO ITS UPPER WINGS.
L2:	PCW. E1,ENEW↔NCCW. E2,ENEW
	PVT 0,E1↔CAME 0,V↔GO[PCCW. ENEW,E1↔GO .+2]↔NCCW. ENEW,E1
	PVT 0,E2↔CAME 0,V↔GO[NCW.  ENEW,E2↔GO .+2]↔PCW.  ENEW,E2
	LAC 1,VNEW↔POP2J
	LIT
BEND;1/14/73------------------------------------------------------
;ENEW ← MKFE(V1,F,V2);		"J" COMMAND.
SUBR(MKFE)--------------------------------------------------------
BEGIN	MKFE
	ACCUMULATORS{V1,F,V2,FNEW,ENEW,E,E0,B,V}

;FETCH THE ARGUMENTS.
	CDR V1,ARG3
	CDR  F,ARG2
	CDR V2,ARG1

;DO THE CREATIONS.
	SETQ(B,{BGET,F})
	SETQ(FNEW,{MKF,B})
	SETQ(ENEW,{MKE,B})

;LINK ENEW.
	PED. ENEW,F↔	PED. ENEW,FNEW
	PFACE. F,ENEW↔	NFACE. FNEW,ENEW
	PVT. V1,ENEW↔ 	NVT. V2,ENEW

;GET THE UPPER WINGS.
	PED E,V1↔LAC E0,E↔MOVS 1(E)↔CAME 1(E)
	GO[L1: LAC E0,E↔ SETQ(E,{ECW,E0,V1})
	CALL(FCW,E0,V1)↔CAME 1,F↔GO L1↔GO .+1]
	DAC E0,E1#↔DAC E,E2#

;GET THE LOWER WINGS.
	PED E,V2↔LAC E0,E↔MOVS 1(E)↔CAME 1(E)
	GO[L2: LAC E0,E↔ SETQ(E,{ECW,E0,V2})
	CALL(FCW,E0,V2)↔CAME 1,F↔GO L2↔GO .+1]
	DAC E0,E3#↔DAC E,E4#

COMMENT .   					MKFE MANDALA
	        o--------o       o--------o
	        |   E2    \     /   E1    |
	        |   nccw   \   /   pcw    |
	        |           \ /		  |
	        |       pvt  ⊗  V1        |
	        |            |		  |
	        |     FNEW   ENEW    F    |
	        |            |		  |
	        |       nvt  ⊗  V2	  |
		|           / \		  |
	        |    ncw   /   \   pccw   |
	        |    E3   /     \    E4   |
	        o--------o       o--------o

-----------------------------------------------------------------.
;CDR V2'S TAIL REPLACING F'S WITH FNEW.
	LAC E,E3↔LAC V,V2
L3:	MOVS 1,1(E)↔CAME 1,1(E)↔GO L4
	PFACE. FNEW,E
	SETQ(V,{OTHER,E,V})
	SETQ(E,{ECCW,E,V})↔GO L3

;CCW FROM V1 REPLACING F'S WITH FNEW.
L4:	LAC E0,E↔LAC E,E2↔SETZM A#↔CAMN E0,E2↔GO L6
L5:	TESTZ E,WASP↔JSR WASPS
	NFACE 0,E
	CAME F,0
	GO[PFACE. FNEW,E↔GO .+2]
	   NFACE. FNEW,E
	CAME E,E0
	GO[DAC E,A↔SETQ(E,{ECCW,E,FNEW})↔GO L5]

;LINK THE WINGS.
L6:	CALL(WING,E1,ENEW)
	CALL(WING,E2,ENEW)
	CALL(WING,E3,ENEW)
	CALL(WING,E4,ENEW)
L7:	LAC 1,ENEW↔POP3J

WASPS:	0

	PCW  1,E↔CAMN 1,A↔GO W1
	PCCW 1,E↔CAME 1,A↔GO W2

W1: 	SETZM A↔MARKZ E,WASP
	PFACE. FNEW,E↔SETQ(E,{ECCW,E,FNEW})
	TESTZ E,WASP↔GO W1↔GO @WASPS

W2:	SETZM A↔MARKZ E,WASP
	NFACE. FNEW,E↔SETQ(E,{ECCW,E,FNEW})
	TESTZ E,WASP↔GO W2↔GO @WASPS

	LIT
BEND;1/14/73------------------------------------------------------
;VNEW ← ESPLIT(E);		"M" COMMAND.
SUBR(ESPLIT)------------------------------------------------------
BEGIN	ESPLIT
	ACCUMULATORS{VNEW,ENEW,B,E,V}

;CHECK FOR BAD ARGUMENTS.
	CDR VNEW,ARG1
	LAC E,VNEW
	TEST E,EBIT↔GO L1
	PVT V,E

;CREATE A NEW EDGE AND VERTEX.
	CCW B,E
	SETQ(VNEW,{MKV,B})
	SETQ(ENEW,{MKE,B})
	SLACI AA(E)↔LAPI AA(ENEW)↔BLT CC(ENEW)

;PLACE VNEW BETWEEN E AND ENEW.
	PED 0,V↔CAMN 0,E↔PED. ENEW,V
	PED. ENEW,VNEW
	PVT 0,E↔PVT. 0,ENEW
	PVT. VNEW,E
	NVT. VNEW,ENEW
	PFACE 0,E↔PFACE. 0,ENEW
	NFACE 0,E↔NFACE. 0,ENEW

;NEW UPPER WINGS ARE LIKE THE OLDE;
	PCW 0,E↔CALL(WING,0,ENEW)
	NCCW 0,E↔CALL(WING,0,ENEW)

;EDGES POINT AT EACH OTHER ACROSS VNEW.
	NCCW. ENEW,E↔PCW.  ENEW,E
	NCW.  E,ENEW↔PCCW. E,ENEW
L1:	LAC 1,VNEW↔POP1J

BEND;1/14/73------------------------------------------------------ 
;F ← KLFE(ENEW);		"K" COMMAND.
SUBR(KLFE)--------------------------------------------------------
BEGIN	KLFE
	ACCUMULATORS{ENEW,FNEW,V1,V2,E1,E2,E3,E4,E,F,B}

;PICK THINGS UP.
	CDR ENEW,ARG1
	PFACE F,ENEW↔	NFACE FNEW,ENEW
	PVT V1,ENEW↔	NVT V2,ENEW

;GET THE WINGS.
	PCW  E1,ENEW
	NCCW E2,ENEW
	NCW  E3,ENEW
	PCCW E4,ENEW

;GET RID OF ENEW APPEARANCES IN F & V.
	PED 0,V1↔ CAMN 0,ENEW↔ PED. E1,V1
	PED 0,V2↔ CAMN 0,ENEW↔ PED. E3,V2
	PED 0,F ↔ CAMN 0,ENEW↔ PED. E3,F

;GET RID OF FNEW APPEARANCES
	LAC E,E2
L1:	PFACE 0,E↔CAMN 0,FNEW↔GO[PFACE. F,E↔GO L2]
	NFACE 0,E↔CAMN 0,FNEW↔GO[NFACE. F,E↔GO L2]
	FATAL(KLFE)
L2:	CAME E,E3↔GO[SETQ(E,{ECCW,E,F})↔GO L1]

;LINK WINGS TOGETHER ABOUT F.
	CALL(WING,E2,E1)
	CALL(WING,E4,E3)

;GET RID OF FNEW AND ENEW.
	CCW B,ENEW
	CALL(KLF,B,FNEW)
	CALL(KLE,B,ENEW)
	LAC 1,F↔POP1J

BEND;1/14/73------------------------------------------------------
;E ← KLEV(VNEW);		"K" COMMAND.
SUBR(KLEV)--------------------------------------------------------
BEGIN	KLEV
	ACCUMULATORS{E,ENEW,V,VNEW,F,B}
	CDR VNEW,ARG1↔PED ENEW,VNEW
	SETQ(E,{ECCW,ENEW,VNEW})
	CAMN E,ENEW↔GO[SETQ(V,{OTHER,ENEW,VNEW})	;EAT WIRE.
	SETQ(E,{ECCW,ENEW,V})↔NCW. E,E↔PCCW. E,E↔GO L1]
	CALL(ECCW,E,VNEW)↔CAME 1,ENEW
	GO[CALL(KLFE,1)↔GO KLEV]

;ORIENT EDGES AS IN MANDALA.
	NVT 0,ENEW↔CAMN 0,VNEW↔GO .+3↔CALL(INVERT,ENEW)
	PVT 0,E↔CAMN 0,VNEW↔GO .+3↔CALL(INVERT,E)
;TIE E TO ITS NEW VERTEX.
	PVT V,ENEW↔ PVT. V,E
;MAKE E'S UPPER WINGS LIKE ENEW'S.
	PCW 0,ENEW↔CALL(WING,0,E)
	NCCW 0,ENEW↔CALL(WING,0,E)

;ELIMINATE OCCURENCES OF ENEW IN F & V.
L1:	PED 0,V↔ CAMN 0,ENEW↔ PED. E,V
	PFACE F,E↔ PED 0,F↔ CAMN 0,ENEW↔ PED. E,F
	NFACE F,E↔ PED 0,F↔ CAMN 0,ENEW↔ PED. E,F
;PURGE 'EM.
	CCW B,ENEW
	CALL(KLV,B,VNEW)
	CALL(KLE,B,ENEW)
	LAC 1,E↔SLAC 1(1)↔CAMN 1(1)↔NVT 1,1
	POP1J↔LIT
COMMENT .        \  pvt  /	KLEV MANDALA
                  \     /
            nccw   \   /   pcw
                    \ /
                  V  ⊗
                     |
                ENEW |
                     | nvt
                VNEW ⊗
                     | pvt
                   E |
                     |
                     ⊗
                    / \
             ncw   /   \   pccw
                  /     \
                 /  nvt  \					.
BEND;1/14/73------------------------------------------------------
; V ← KLVE(E) - KILL E & NVT(E) RETURNING PVT(E).
SUBR(KLVE)--------------------------------------------------------
BEGIN KLVE
	ACCUMULATORS{A,E,E1,E2,E3,E4,V1,V2,S12}

;PICK THINGS UP.
	CDR E,ARG1↔NVT V1,E↔PVT V2,E
	PCW E1,E↔NCCW E2,E↔NCW E3,E↔PCCW E4,E

;REPLACE FACE-VERTEX PED'S THAT MIGHT CONTAIN E.
	PFACE 1,E↔PED 0,1↔CAMN 0,E↔PED. E1,1
	NFACE 1,E↔PED 0,1↔CAMN 0,E↔PED. E2,1
	PED 0,V2↔CAMN 0,E↔PED. E2,V2

;REPLACE V1 WITH V2.
	LAC A,E3
L1:	PVT 1,A↔CAME 1,V1↔GO[NVT. V2,A↔GO .+2]↔PVT. V2,A
  	SETQ(A,{ECCW,A,V2})
	CAME A,E↔GO L1

;SPLICE WINGS TOGETHER.
	CALL(WING,E1,E4)
	CALL(WING,E2,E3)

;BURN THE GARBAGE.
	CCW A,E
	CALL(KLE,A,E)
	CALL(KLV,A,V1)
	LAC 1,V2
	POP1J
	LIT
BEND;1/14/73------------------------------------------------------
COMMENT .  KLVE MANDALA
            E2    \     /   E1
            nccw   \   /   pcw
                    \ /
                pvt  ⊗  V2
                     |
                     |  E
                     |
                nvt  ⊗  V1
                    / \
             ncw   /   \   pccw
             E3   /     \    E4.
;BNEW ← MKCOPY(B).
SUBR(MKCOPY)------------------------------------------------------
BEGIN MKCOPY
	ACCUMULATORS{B,F,E,V,BNEW,Q,A}
	EXTERN MKFRAME
	LAC B,ARG1
;DETECT FRAME NODES
	LACM 1,(B)		;GET ABS(TYPE(NODE))
	SKIPE 1↔TLNE 1,(1B9)	;IF ZERO OR BIT 9, THEN FLOATING
	GO[ CALL(MKNODE,[0])	;COPY FRAME NODE AND RETURN IT
	    SLACI XWC(B)
	    LAPI XWC(1)
	    BLT KZ(1)
	    POP1J]
;IF IT ISN'T BODY, RETURN
	TESTZ B,BBIT↔GO DOBODY
	POP1J			;GOOD ENOUGH FOR NEW
;MKCOPY CONTINUED
;MAKE A NEW BODY NODE
DOBODY:	SETQ(BNEW,{MKB,B})
;COPY BODY FRAME, IF ANY
	FRAME Q,B↔SKIPE Q
	GO[ CALL(MKFRAME)
	    FRAME. 1,BNEW
	    SLACI XWC(Q)
	    LAPI XWC(1)
	    BLT KZ(1)
	    GO .+1]
;COPY THRU BODY'S FACE RING
	LAC B,ARG1↔LAC F,B↔LAC E,B↔LAC V,B
;FOR ALL THE EDGES OF THE BODY.
L1:	PED E,E↔TEST E,EBIT↔GO L2
	SETQ(Q,{MKE,BNEW})↔ALT. Q,E↔GO L1

;FOR ALL THE FACES OF THE BODY.
L2:	PFACE F,F↔TEST F,FBIT↔GO L3
	SETQ(Q,{MKF,BNEW})↔ALT. Q,F
	PED A,F↔ALT A,A↔PED. A,Q
	LAC QQ(F)↔DAC QQ(Q)↔GO L2

;FOR ALL THE VERTICES OF THE BODY.
L3:	PVT V,V↔TEST V,VBIT↔GO L4
	SETQ(Q,{MKV,BNEW})↔ALT. Q,V
	PED A,V↔ALT A,A↔PED. A,Q
	SLACI XWC(V)↔LAPI XWC(Q)↔BLT ZWC(Q)↔GO L3

;FOR ALL THE EDGES OF THE BODY.
L4:	PED E,E↔TEST E,EBIT↔GO L5
	ALT Q,E
	PVT V,E↔  ALT V,V↔PVT. V,Q
	NVT V,E↔  ALT V,V↔NVT. V,Q
	PFACE F,E↔ALT F,F↔PFACE. F,Q
	NFACE F,E↔ALT F,F↔NFACE. F,Q
	NCW A,E↔  ALT A,A↔NCW. A,Q
	PCW A,E↔  ALT A,A↔PCW. A,Q
	NCCW A,E↔ ALT A,A↔NCCW. A,Q
	PCCW A,E↔ ALT A,A↔PCCW. A,Q↔GO L4
L5:	SETZ↔LAC 1,BNEW↔SKIPA E,ARG1
L6:	ALT. 0,E↔PED E,E↔CAME E,ARG1↔GO L6
;PARTS OF THIS BODY.
	LAC B,ARG1↔TESTZ B,BDPBIT↔POP1J
	SON Q,B↔JUMPE Q,POP1J.
L7:	PUSH P,Q↔PUSH P,BNEW↔CALL(MKCOPY,Q)
	LAC BNEW,(P)↔CALL(BATT,1,BNEW)
	POP P,BNEW↔POP P,Q↔LAC B,ARG1
	BRO Q,Q↔SON 0,B↔CAME 0,Q↔GO L7
	LAC 1,BNEW↔POP1J
BEND;1/14/73------------------------------------------------------
;ENEW ← GLUEE(F1,V1,F2,V2)  -  LIKE TWO MKEV(F,V)'S BACK TO BACK.
SUBR(GLUEE)-------------------------------------------------------
BEGIN GLUEE
	Q←1
	ACCUMULATORS{F1,V1,F2,V2,B,E,E1,E2,E3,E4}
	CDR F1,ARG4↔CDR V1,ARG3
	CDR F2,ARG2↔CDR V2,ARG1
;BODY SPLICING.
	PED E,F1↔CCW B,E
	PED E,F2

;REPLACE F2 WITH F1.
	PED E,F2↔DAC E,E0#
L1:	PFACE Q,E↔CAMN Q,F2↔PFACE. F1,E
        NFACE Q,E↔CAMN Q,F2↔NFACE. F1,E
	SETQ(E,{ECCW,E,F1})
	CAME E,E0↔GO L1
	CALL(KLF,B,F2)
	
COMMENT .				GLUEE MANDALA

	|	|	|
	|      +V2	|
	|     / | \     |
	|    /  |  \    |
NCCW	| E2/   |   \E1 |	PCW
       	|  /    |    \  |
	| /  F2 |  F2 \ |
	o______ | ______o
		|		HOWEVER,
	  WASP	| ENEW		GLUEE RETURN'S ENEW INVERTED
	o______ | ______o
	|\      |      /|
	| \  F1 |  F1 / |
	|  \    |    /  |
NCW	| E3\   |   /E4 |	PCCW
	|    \  |  /    |
	|     \ | /     |
	|      -V1	|
	|	|	|
        |	|	|				.
;EDGE CREATION
	SETQ(E,{MKE,B})
	MARK E,WASP
	NFACE. F1,E↔PFACE. F1,E
	NVT. V1,E↔PVT. V2,E

;MAKE WINGS
	SETQ(E1,{ECW,V2,F1})↔PCW.  E1,E
	SETQ(E2,{ECW,E1,V2})↔NCCW. E2,E
	SETQ(E3,{ECW,V1,F1})↔NCW.  E3,E
	SETQ(E4,{ECW,E3,V1})↔PCCW. E4,E

	PVT Q,E1↔CAME Q,V2↔GO[PCCW. E,E1↔GO .+2]↔NCCW. E,E1
	PVT Q,E2↔CAME Q,V2↔GO[NCW.  E,E2↔GO .+2]↔PCW.  E,E2
	PVT Q,E3↔CAME Q,V1↔GO[PCCW. E,E3↔GO .+2]↔NCCW. E,E3
	PVT Q,E4↔CAME Q,V1↔GO[NCW.  E,E4↔GO .+2]↔PCW.  E,E4

;MARK WASP WAIST ON POTENTIAL SPUR STARTING AT V1.
	CAME E1,E2↔GO L2
	MARK E1,WASP↔PVT V1,E1↔PED E1,V1
	MOVS Q,1(E1)↔CAMN Q,1(E1)↔GO .-5

L2:	LAC Q,E↔CALL(INVERT,Q)↔POP4J
	LIT
BEND;1/14/73------------------------------------------------------
SUBR(GLUE)F1,F2---------------------------------------------------
BEGIN GLUEFF;GLUE TWO FACES TOGETHER - BGB 10 FEBRUARY 1973.
	EXTERN DISTAN
;ARGUMENTS MUST BE FACES WITH THE SAME NUMBER OF VERTICES.
	LAC 1,ARG1↔DAC 1,F1↔TEST 1,FBIT↔POP2J
	LAC 1,ARG2↔DAC 1,F2↔TEST 1,FBIT↔POP2J
	LAC 1,F1↔PED 2,1↔DAC 2,E↔DAC 2,E0↔LACI 10,1
L1:	SETQ(E,{ECCW,E,F1})↔CAME 1,E0↔AOJA 10,L1↔DAC 10,NN
	LAC 1,F2↔PED 2,1↔DAC 2,E↔DAC 2,E0↔SOS 10
L2:	SETQ(E,{ECCW,E,F2})↔CAME 1,E0↔SOJA 10,L2↔SKIPE 10↔POP2J

;FIND V2 CLOSEST TO V1.
	LAC 1,F1↔PED 2,1↔SETQ(V1,{VCW,2,1})
	HRLOI 377777↔DAC MIN
	SETZM LIST1↔SETZM LIST2
L3:	SETQ(V,{VCW,E,F2})
	CALL(DISTAN,V,V1)
	CAMGE 1,MIN↔GO[DAC 1,MIN↔LAC V↔DAC V2↔GO .+1]
	LAC 1,E↔LAC LIST1↔DAP -1(1)↔DAC 1,LIST1
	LAC 1,V↔LAC LIST2↔DAP -1(1)↔DAC 1,LIST2
	SETQ(E,{ECCW,E,F2})
	CAME 1,E0↔GO L3
	CALL(GLUEE,F1,V1,F2,V2)
	CALL(INVERT,1)

;CLOSE UP THE GAP.
	SOS NN
L4:	PCCW 0,1↔PUSH P,0↔PCW 0,1↔PUSH P,0
	SETQ(V2,{OTHER,V2})↔SETQ(V1,{OTHER,V1})
	CALL(MKFE,V2,F1,V1)↔SOSLE NN↔GO L4

;NOW KILL ALL THOSE EDGES.
L5:	SKIPN 1,LIST1↔GO L6↔CDR 0,-1(1)↔DAC 0,LIST1
	CALL(KLFE,1)↔GO L5
L6:	SKIPN 1,LIST2↔GO L7↔CDR 0,-1(1)↔DAC 0,LIST2
	CALL(KLEV,1)↔GO L6

L7:	LAC 1,F1↔PED 1,1↔CCW 1,1
	POP2J
DECLARE{F1,F2,V,V1,V2,NN,E,E0,MIN,LIST1,LIST2}
BEND;2/10/73------------------------------------------------------
SUBR(SWEEP)FACE,FLAG----------------------------------------------
BEGIN SWEEP

;TEST FOR VALID ARGUMENT.
	LAC 1,ARG2↔DAC 1,F↔TEST 1,FBIT↔POP2J
	PED 2,1↔DAC 2,E↔SKIPN 2↔POP2J
	TEST 2,EBIT↔POP2J

;TEST FOR SPECIAL CASES.
	PCW 3,2↔CAMN 3,2↔GO SWEEP2		;WIRE SWEEP CASE.
	SETZM E0↔NCNT 0,1↔DACM NN
	SKIPE↔SETZM ARG1

;MAKE FIRST SPOKE.
	CALL(VCW,E,F)↔DAC 1,U0↔DAC 1,U1
	CALL(MKEV,F,U0)↔DAC 1,V0↔DAC 1,V1

;COPY FACE PERIMETER LOOP.
L1:	SETQ(U2,{VCCW,E,F})		;ADVANCE ALONG RIM.
	SETQ(E,{ECCW,E,F})
	LAC 1,U2↔CAME 1,U0		;MAKE NEXT SPOKE.
	GO[CALL(MKEV,F,U2)↔GO .+2]
	LAC 1,V0↔DAC 1,V2
	CALL(MKFE,V1,F,V2)		;CONNECT SPOKES.
	SKIPN E0↔DAC 1,E0		;NEW FIRST EDGE.

;SPLIT NEW FACE TO MAKE PRISMOIDS.
	NFACE 0,1
	SKIPGE ARG1↔GO[CALL(MKFE,V1,0,U2)↔GO .+3] ;CW -1.
	SKIPLE ARG1↔GO[CALL(MKFE,U1,0,V2)↔GO .+1] ;CCW +1.

;TEST FOR END OF COPY LOOP.
	LAC V2↔DAC V1
	LAC U2↔DAC U1
	SOSN NN↔GO .+3
	CAME U0↔GO L1		;EXIT WHEN NN=0 OR U2=U0
;EXIT.
	LAC 0,E0↔LAC 1,F
	PED. 0,1↔POP2J

DECLARE{F,E,E0,U0,U1,U2,V0,V1,V2,NN}
COMMENT .	U2 o----------o U1	FACE SWEEP MANDALA
		  / \        / \
	         /   \ FNEW /   \
	        /     \____/     \
	       /     v2    v1	  \
              /         F          \.
BEND;2/7/73-------------------------------------------------------
SWEEP2:;FACE,FLAG-------------------------------------------------
BEGIN SWEEP2;WIRE FACE SWEEP - BGB - 7 FEB 1973.

;COUNT THE EDGES IN THE WIRE.
	LAC 3,ARG2↔DAC 3,FACE		;FACE
	PED 1,3↔LACI 0,1		;EDGE & NCNT.
	LAC 2,1↔NCW 1,1
	CAME 1,2↔AOJA 0,.-3		;COUNT THE EDGES.

;MAKE "BOTTOM" EDGE.
	DAC 1,E				;LAST EDGE.
	NCNT. 0,3↔DAC NN
	NVT 1,1				;LAST VERTEX OF THE WIRE.
	SETQ(V2,{MKEV,FACE,1})		;BOTTOM EDGE.

;COPY THE WIRE.
L1:	SETQ(V2,{MKEV,FACE,V2})
	LAC 3,E↔PVT 2,3↔DAC 2,V1
	SLACI XWC(2)↔LAPI XWC(1)↔BLT ZWC(1)
	PCW 2,3↔DAC 2,E↔CAME 2,3↔GO L1

;CLOSE THE TOP.
	SETQ(E,{MKFE,V1,FACE,V2})
	NFACE 1,1↔DAC 1,FNEW
	SOSG NN↔GO L3

;FOLLOW DOWN BOTH SIDES.
L2:	CALL(ECCW,E,FNEW)↔SETQ(V1,{OTHER,1,V1})
	CALL(ECW,E,FNEW)↔SETQ(V2,{OTHER,1,V2})
	SETQ(E,{MKFE,V2,FNEW,V1})
	SOSLE NN↔GO L2

;UPDATE THE FIRST EDGE OF THE FACE.
L3:	LAC 2,ARG2↔PED 1,2
	CALL(ECCW,1,2)↔PED. 1,2
	LAC 1,2↔POP2J

COMMENT .	⊗	⊗-------⊗		⊗-------⊗
	      + |	|	|		|	|
	PED(F)	|	|	|		|	|PED(F)'
	      - |	|	|		|	|
		⊗	⊗	⊗	    V1→ ⊗-------⊗ ←V2
	      + |	|	|		|	|
		|	| FNEW	| F below	|	|
	      - |	|	|		|	|
		⊗	⊗	⊗		⊗ FNEW 	⊗
	      + |	|	|		|	|
		|	|	|		|	|
	      - |	|	|		|	|
		⊗	⊗-------⊗		⊗-------⊗	.
DECLARE{FACE,FNEW,NN,V1,V2,E}
BEND;2/7/73-------------------------------------------------------
SUBR(ROTCOM)FACE--------------------------------------------------
BEGIN ROTCOM;SOLID OF ROTATION COMLETION - BGB -8 FEB 1973.
	ACCUMULATORS{F,E,E0,M,N}
	LAC F,ARG1↔DAC F,FACE↔TEST F,FBIT↔POP1J
	NCNT N,F↔DACM N,NN↔SKIPN↔POP1J

;COUNT THE EDGES IN THIS FACE.
	LACI M,1↔PED E,F↔DAC E,E0↔DAC E,EDGE
L1:	SETQ(E,{ECCW,E,F})
	CAME E,E0↔AOJA M,L1

;SKIP AROUND THE NORTH POLE CAP.
	ASH M,-1↔SUB M,NN
	SETQ(V1,{VCW,EDGE,FACE})
	LAC 1,EDGE
L2:	CALL(ECW,1,FACE)↔SOJG M,L2
	SETQ(V2,{VCW,1,FACE})
	SETQ(EDGE,{MKFE,V2,FACE,V1})	;CLOSE THE TOP OF THE GAP.

;FOLLOW DOWN THE GAP.
L3:	CALL(ECCW,EDGE,FACE)↔SETQ(V1,{OTHER,1,V1})
	CALL(ECW,EDGE,FACE)↔SETQ(V2,{OTHER,1,V2})
	SETQ(EDGE,{MKFE,V2,FACE,V1})
	SOSLE NN↔GO L3
	SETZ↔LAC 1,FACE↔NCNT. 0,1
	POP1J
COMMENT .
	⊗---⊗---⊗----⊗---⊗
	|      GAP	 |	← POLE CAP
	|       ↓ 	 |
	⊗-----⊗←←←←⊗-----⊗	← ARTIC CIRCLE
       PED(F)→|    |
	      |    |
	  V1' ⊗←←←←⊗ V2'
	      | F  |
	      |    |
        ⊗-----⊗    ⊗-----⊗	← ANTARTIC CIRCLE.

DECLARE{FACE,EDGE,V1,V2,NN}
BEND;2/8/73-------------------------------------------------------
SUBR(PYRAMID)FACE OR VERTEX---------------------------------------
BEGIN PYRAMID

	LAC 1,ARG1↔TEST 1,VBIT↔GO L2
;VERTEX ARGUMENT - GIVEN THE PEAK FORM THE BASE.
	DAC 1,V
	PED 2,1↔DAC 2,E0↔DAC 2,E2
	SETQ(V2,{OTHER,E2,V})
L1:	LAC E2↔DAC E1
	LAC V2↔DAC V1
	SETQ(E2,{ECCW,E1,V})
	SETQ(V2,{OTHER,E2,V})
	CALL(LINKED,V1,V2)↔JUMPE 1,[	;WHEN NOT LINKED.
	CALL(FCCW,E1,V)
	CALL(MKFE,V1,1,V2)↔GO .+1]
	LAC E2↔CAME E0↔GO L1
	LAC 1,ARG1↔POP1J
	DECLARE{V,V1,V2,E0,E1,E2}

;FACE ARGUMENT - GIVEN THE BASE FORM THE PEAK.
L2:	DAC 1,F↔TEST 1,FBIT↔POP1J
	SETZM X↔SETZM Y↔SETZM Z↔SETZM N
	PED 2,1↔DAC 2,E↔DAC 2,E0
	SETQ(V0,{VCW,E0,F})
	SETQ(PEAK,{MKEV,F,V0})
L3:	SETQ(V,{VCCW,E,F})
	LAC XWC(1)↔FADRM X
	LAC YWC(1)↔FADRM Y
	LAC ZWC(1)↔FADRM Z
	AOS N↔CAMN 1,V0↔GO L4
	SETQ(E,{ECCW,E,F})
	CALL(MKFE,PEAK,F,V)
	GO L3
L4:	LAC 1,PEAK↔LAC 2,N↔FLOAT 2,
	LAC X↔FDVR 2↔DAC XWC(1)
	LAC Y↔FDVR 2↔DAC YWC(1)
	LAC Z↔FDVR 2↔DAC ZWC(1)
	POP1J
	DECLARE{PEAK,F,E,V0,X,Y,Z,N}

BEND;2/8/73-------------------------------------------------------
SUBR(REMOVF)FACE-------------------------------------------------
BEGIN REMOVE; REMOVE A FACE FROM A POLYHEDRON - BGB - 7 FEB 1973.
	LAC 1,ARG1↔TEST 1,FBIT↔POP1J↔DAC 1,F
	PED 2,1↔DAC 2,E
	SETQ(V0,{VCW,E,F})
	SETQ(V,{VCCW,E,F})↔SLACI XWC(1)↔LAPI X↔BLT Z
	SETQ(A,{ECCW,E,F})
	SETQ(F,{KLFE,E})
	LACI 1↔DAC N
L1:	LAC 1,A↔DAC 1,E
	PVT 0,1↔CAMN 0,V↔GO[CALL(INVERT,E)↔GO .+1]
	SETQ(A,{ECCW,A,F})
	SETQ(V,{KLVE,E})
	LAC XWC(1)↔FADRM X
	LAC YWC(1)↔FADRM Y
	LAC ZWC(1)↔FADRM Z↔AOS N
	CAME 1,V0↔GO L1
;PLACE VERTEX AT CENTER OF DECEASED FACE.
	LAC 2,N↔FLOAT 2,
	LAC X↔FDVR 2↔DAC XWC(1)
	LAC Y↔FDVR 2↔DAC YWC(1)
	LAC Z↔FDVR 2↔DAC ZWC(1)
	POP1J
DECLARE{F,E,V,V0,A,X,Y,Z,N}
BEND;2/10/73-----------------------------------------------------
SUBR(FVDUAL)BODY-------------------------------------------------
BEGIN FVDUAL; FACE-VERTEX DUAL - BGB - 20 FEBRUARY 1973.
	ACCUMULATORS{B,F,E,V,E0,X,Y,Z,I}
	LAC B,ARG1↔TEST B,BBIT↔POP1J

;FOR ALL THE FACES OF THE BODY.
	LAC F,B
L1:	PFACE F,F↔TEST F,FBIT↔GO L3
	SETZB X,Y↔SETZB Z,I
	PED E,F↔DAC E,E0

;COMPUTE CENTER OF EACH FACE.
L2:	SETQ(V,{VCCW,E,F})
	SETQ(E,{ECCW,E,F})
	FADR X,XWC(V)↔FADR Y,YWC(V)↔FADR Z,ZWC(V)
	AOS I
	CAME E,E0↔GO L2

;CONVERT FACES INTO VERTICES.
	FLOAT I,↔FDVR X,I↔FDVR Y,I↔FDVR Z,I
	DAC X,XWC(F)↔DAC Y,YWC(F)↔DAC Z,ZWC(F)
	LAC 1(F)↔DAC 3(F)↔SLACI(VBIT)↔DAC(F)
	GO L1

;CONVERT VERTICES INTO FACES.
L3:	LAC V,ARG1↔LACI 1,2↔LAC E,ARG1
L4:	PVT V,V↔TEST V,VBIT↔GO L5
	LAC 3(V)↔DAC 0λV)↔DIP 1,(V)↔GO L4

;TURN ALL THE EDGES OVER AND INSIDE OUT.
L5:	PED E,E↔TEST E,EBIT↔GO L6
	LAC 1(E)↔EXCH 3(E)↔DAC 1(E)
	MOVSS 1(E)
	MOVS 4(E)↔MOVE 1,5(E)
	DAC 1,4(E)↔DAC 5(E)
	GO L5

L6:	LAC B,ARG1↔LAC 1(B)↔EXCH 3(B)↔DAC 1(B)
	POP1J
BEND;2/10/73-----------------------------------------------------
SUBR(MKCUBE)DX,DY,DZ --------------------------------------------
BEGIN MKCUBE; MAKE A CUBE WITH SIDES DX, DY, DZ.

	SETQ(B,{MKB,[0]})
	SETQ(F,{MKF,B})
	SETQ(V,{MKV,B})
	LAC ARG3↔FSC -1↔DAC XWC(1)
	LAC ARG2↔FSC -1↔DAC YWC(1)
	LAC ARG1↔FSC -1↔DAC ZWC(1)
	CALL(MKEV,F,1)↔MOVNS XWC(1)
	CALL(MKEV,F,1)↔MOVNS YWC(1)
	CALL(MKEV,F,1)↔MOVNS XWC(1)
	CALL(MKFE,V,F,1)
	CALL(SWEEP,F,[0])
	LAC 1,B
	NVT 1,1↔MOVNS ZWC(1)
	NVT 1,1↔MOVNS ZWC(1)
	NVT 1,1↔MOVNS ZWC(1)
	NVT 1,1↔MOVNS ZWC(1)
	LAC 1,B↔POP3J
	DECLARE{B,F,V}
BEND MKCUBE; 16 MARCH 1973 --------------------------------------


END
EULER.FAI - EOF.