perm filename EULER[GEM,BGB]5 blob sn#054446 filedate 1973-08-08 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00025 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001	   VALID 00023 PAGES
C00003 00002	TITLE EULER  -  EULER  PRIMITIVES  -  JULY 1972.
C00005 00003	SUBR(INVERT)
C00007 00004	SUBR(MKEV,FACE,VERTEX)
C00009 00005	SUBR(MKFE,VERT1,FACE,VERT2)
C00012 00006		MKFE - CONTINUED.
C00014 00007	SUBR(ESPLIT)
C00016 00008	SUBR(KLFE)
C00018 00009	SUBR(KLEV)
C00021 00010	SUBR(KLVE)
C00023 00011	SUBR(MKCOPY)
C00025 00012	  (MKCOPY continued)
C00027 00013	L5:	SETZ↔LAC 1,BNEW↔SKIPA E,ARG1
C00028 00014	SUBR(GLUEE)
C00029 00015	.				GLUEE MANDALA
C00031 00016	SUBR(GLUE)F1,F2
C00034 00017	SUBR(SWEEP,FACE0,FLAG)
C00037 00018	SUBR(SWEEP2,FACE0,FLAG)
C00040 00019	SUBR(ROTCOM,FACE0)	ROTATION SWEEP COMPLETION.
C00042 00020	SUBR(PYRAMID,FV)	MAKE PYRAMID.
C00044 00021	SUBR(REMOVF,FACE)
C00046 00022	SUBR(FVDUAL,BODY)
C00048 00023	SUBR(MKCUBE,DX,DY,DZ)
C00049 00024	SUBR(MKCYLN,RADIUS,N,DZ)
C00051 00025	SUBR(MKBALL,RADIUS,M,N)
C00053 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)
COMMENT ⊗-----------------------------------------------------------
⊗
	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
ENDR;1/14/73(BGB)---------------------------------------------------

SUBR(EVERT,BODY)	;TURN BODY INSIDE OUT.
COMMENT ⊗-----------------------------------------------------------
⊗
	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
ENDR;1/14/73(BGB)---------------------------------------------------
SUBR(MKEV,FACE,VERTEX)
COMMENT ⊗-----------------------------------------------------------
⊗
	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
ENDR;1/14/73(BGB)-----------------------------------------------------
SUBR(MKFE,VERT1,FACE,VERT2)
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			.
	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})
	LAC 4(F)↔DAC 4(FNEW)
	LAC 5(F)↔DAC 5(FNEW)
	SLACI AA(F)↔LAPI AA(FNEW)↔BLT CC(FNEW)
;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#
	;MKFE - CONTINUED.
;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
ENDR;1/14/73(BGB)----------------------------------------------------
SUBR(ESPLIT)
COMMENT ⊗-----------------------------------------------------------
⊗
	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

ENDR;1/14/73(BGB)-----------------------------------------------------
SUBR(KLFE)
COMMENT ⊗-----------------------------------------------------------
⊗
	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

ENDR;1/14/73(BGB)----------------------------------------------------
SUBR(KLEV)
COMMENT .-----------------------------------------------------------
                 \  pvt  /	KLEV MANDALA
                  \     /
            nccw   \   /   pcw
                    \ /
                  V  ⊗
                     |
                ENEW |
                     | nvt
                VNEW ⊗
                     | pvt
                   E |
                     |
                     ⊗
                    / \
             ncw   /   \   pccw
                  /     \
                 /  nvt  \					.
	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
ENDR;1/14/73(BGB)----------------------------------------------------
SUBR(KLVE)
COMMENT .-----------------------------------------------------------
V ← KLVE(E) - KILL E & NVT(E) RETURNING PVT(E)
            E2    \     /   E1
            nccw   \   /   pcw
                    \ /
                pvt  ⊗  V2
                     |
                     |  E
                     |
                nvt  ⊗  V1
                    / \
             ncw   /   \   pccw
             E3   /     \    E4.
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
ENDR;1/14/73(BGB)-----------------------------------------------------
SUBR(MKCOPY)
COMMENT ⊗-----------------------------------------------------------
⊗
	ACCUMULATORS{B,F,E,V,BNEW,Q,A}
	EXTERN MKFRAME
	LAC B,ARG1

;DETECT AND COPY 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
	TEST B,FBIT↔POP1J	;GOOD ENOUGH FOR NEW

;COPY FACE INTO A NEW BODY.
DOFACE:	DAC B,OLDF↔PED E,B
	SETQ(B,{BGET,OLDF})	;BODY OF THE GIVEN FACE.
	SETQ(BNEW,{MKB,B})
	FRAME Q,B↔SKIPE Q↔GO[	;COPY BODY FRAME, IF ANY.
	  CALL(MKFRAME)↔FRAME. 1,BNEW
	  SLACI XWC(Q)↔LAPI XWC(1)↔BLT KZ(1)
	  GO .+1]
	SETQ(FACE,{MKF,BNEW})
	SETQ(V,{MKV,BNEW})↔DAC V,V0
	SETQ(A,{VCW,E,OLDF})↔DAC A,A0
L0:	SLACI XWC(A)↔LAPI XWC(V)↔BLT ZWC(V)	;COPY VERTEX LOCUS.
	SETQ(A,{VCCW,E,OLDF})			;ADVANCE A VERTEX.
	SETQ(E,{ECCW,E,OLDF})
	CAMN A,A0↔GO[				;TEST FOR END.
	CALL(MKFE,V0,FACE,V)↔LAC 1,FACE↔POP1J]	;MAKE LAST EDGE.
	PUSHP A↔PUSHP E
	SETQ(V,{MKEV,FACE,V})
	POPP E↔POPP A
	GO L0
DECLARE{OLDF,A0,V0,FACE}
  ;(MKCOPY continued)
;MAKE A NEW BODY NODE
DOBODY:	SETQ(BNEW,{MKB,B})
	FRAME Q,B↔SKIPE Q		;COPY BODY FRAME, IF ANY
	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
ENDR;1/14/73(BGB)----------------------------------------------------
SUBR(GLUEE)
COMMENT ⊗-----------------------------------------------------------
ENEW ← GLUEE(F1,V1,F2,V2)  -  LIKE TWO MKEV(F,V)'S BACK TO BACK.
⊗
	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
ENDR;1/14/73(BGB)----------------------------------------------------
SUBR(GLUE)F1,F2
COMMENT ⊗-----------------------------------------------------------
⊗
	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}
ENDR;2/10/73(BGB)----------------------------------------------------
SUBR(SWEEP,FACE0,FLAG)
COMMENT .-----------------------------------------------------------
         	U2 o----------o U1	FACE SWEEP MANDALA
		  / \        / \
	         /   \ FNEW /   \
	        /     \____/     \
	       /     v2    v1	  \
              /         F          \.
;TEST FOR VALID ARGUMENT.
	LAC 1,FACE0↔DAC 1,F↔TEST 1,FBIT↔POP2J
	PED 2,1↔DAC 2,E↔SKIPN 2↔POP2J
	TEST 2,EBIT↔POP2J
	NIP 0,FLAG↔DAC 0,CURFLG↔HRRES FLAG	;SET CURVE FLAG.

;TEST FOR SPECIAL CASES.
	PCW 3,2↔CAMN 3,2↔JCALL 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
	PED 2,1↔SLACI (NSHARP)↔SKIPE CURFLG↔ORM (2)	;SET NSHARP FOR CURVES

;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)↔SKIPN CURFLG↔GO .+2
	   PED 2,1↔MARK 2,NSHARP↔GO .+2]	;SET NSHARP FOR CURVES
	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}
ENDR SWEEP;2/7/73(BGB)-----------------------------------------------
DECLARE{CURFLG}
SUBR(SWEEP2,FACE0,FLAG)
COMMENT .	⊗	⊗-------⊗		⊗-------⊗
	      + |	|	|		|	|
	PED(F)	|	|	|		|	|PED(F)'
	      - |	|	|		|	|
		⊗	⊗	⊗	    V1→ ⊗-------⊗ ←V2
	      + |	|	|		|	|
		|	| FNEW	| F below	|	|
	      - |	|	|		|	|
		⊗	⊗	⊗		⊗ FNEW 	⊗
	      + |	|	|		|	|
		|	|	|		|	|
	      - |	|	|		|	|
		⊗	⊗-------⊗		⊗-------⊗	.
	NIP 1,ARG1↔DAC CURFLG↔HRRES ARG1	;SET CURVE FLAG.
;COUNT THE EDGES IN THE WIRE.
	LAC 3,FACE0↔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.
	PED 1,1
	SLACI (NSHARP)↔SKIPE CURFLG↔ORM (1)	;SET NSHARP FOR CURVES
;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})
	SLACI (NSHARP)↔SKIPE CURFLG↔ORM (1)	;SET NSHARP FOR CURVES
	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})
	SLACI (NSHARP)↔SKIPE CURFLG↔ORM (1)	;SET NSHARP FOR CURVES
	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
DECLARE{FACE,FNEW,NN,V1,V2,E}
ENDR SWEEP2;2/7/73(BGB)----------------------------------------------
SUBR(ROTCOM,FACE0)	;ROTATION SWEEP COMPLETION.
COMMENT .-----------------------------------------------------------
	⊗---⊗---⊗----⊗---⊗
	|      GAP	 |	← POLE CAP
	|       ↓ 	 |
	⊗-----⊗←←←←⊗-----⊗	← ARTIC CIRCLE
       PED(F)→|    |
	      |    |
	  V1' ⊗←←←←⊗ V2'
	      | F  |
	      |    |
        ⊗-----⊗    ⊗-----⊗	← ANTARTIC CIRCLE.
ACCUMULATORS{F,E,E0,M,N}
	LAC F,FACE0↔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
DECLARE{FACE,EDGE,V1,V2,NN}
ENDR;2/8/73(BGB)-----------------------------------------------------
SUBR(PYRAMID,FV)	;MAKE PYRAMID.
COMMENT ⊗-----------------------------------------------------------
⊗
	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}

ENDR;2/8/73(BGB)------------------------------------------------------
SUBR(REMOVF,FACE)
COMMENT ⊗-----------------------------------------------------------
⊗
	LAC 1,FACE↔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}
ENDR;2/10/73(BGB)----------------------------------------------------
SUBR(FVDUAL,BODY)
COMMENT ⊗-----------------------------------------------------------
⊗
	ACCUMULATORS{B,F,E,V,E0,X,Y,Z,I}
	LAC B,BODY↔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 1(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
ENDR;2/10/73(BGB)----------------------------------------------------
SUBR(MKCUBE,DX,DY,DZ)
COMMENT ⊗-----------------------------------------------------------
⊗
	SETQ(B,{MKB,[0]})
	SETQ(F,{MKF,B})
	SETQ(V,{MKV,B})
	LAC DX↔FSC -1↔DAC XWC(1)
	LAC DY↔FSC -1↔DAC YWC(1)
	LAC DZ↔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}
ENDR MKCUBE;3/16/73(BGB)--------------------------------------------

SUBR(MKCYLN,RADIUS,N,DZ)
COMMENT ⊗-----------------------------------------------------------
⊗
	SETQ(B,{MKB,[0]})		;MAKE SEMINAL BODY.
	SETQ(F,{MKF,B})
	SETQ(V,{MKV,B})↔DAC 1,V0
	LACM DZ↔FSC -1↔DAC ZWC(1)	;PICKUP ARGUMENTS.
	LACM RADIUS↔DAC XWC(1)
	LACM N↔FIXX↔CAIGE 3↔LACI 3
	DAC CNT↔SOS CNT			;NUMBER OF SIDES-1.
	FLOAT↔LAC 1,TWOPI↑
	FDVR 1,0↔DAC 1,DELTA		;DELTA RADIANS.

L1:	SETQ(V,{MKEV,F,V})		;SWEEP WIRE POLYGON.
	CALL(ROTATE↑,V,[0],[0],DELTA)
	SOSLE CNT↔GO L1
	CALL(MKFE,V0,F,V)		;CLOSE WIRE - MAKING LAMINA.
	CALL(SWEEP,F,[0])		;SWEEP FACE INTO SOLID.
	LACN DZ
	CALL(TRANSL↑,F,[0],[0],0)
	LAC 1,B↔POP3J

DECLARE{DELTA,CNT,B,F,V,V0}
ENDR MKCYLN;7/19/73(BGB)----------------------------------------------
SUBR(MKBALL,RADIUS,M,N)
COMMENT ⊗-----------------------------------------------------------
⊗↔	SETQ(B,{MKB,[0]})		;MAKE SEMINAL BODY.
	SETQ(F,{MKF,B})
	SETQ(V,{MKV,B})↔DAC 1,V0
	LACM RADIUS↔DACN YWC(1)

;PICKUP LONGITUDE COUNT.
	LACM M↔FIXX↔CAIGE 2↔LACI 2
	DAC CNT↔SOS CNT			;NUMBER OF LONGITUDES-1.
	FLOAT↔LAC 1,PI↑
	FDVR 1,0↔DAC 1,DELTA↔FSC 1,-1	;DELTA RADIANS.
	CALL(ROTATE↑,V0,[0],[0],1)	;SET OFF FROM POLAR AXIS.

;SWEEP MERIDIAN WIRE FROM ANTARTIC TO ARTIC.
L1:	SETQ(V,{MKEV,F,V})		;SWEEP WIRE POLYGON.
	CALL(ROTATE↑,V,[0],[0],DELTA)
	SOSLE CNT↔GO L1

;PICKUP LATITUDE COUNT.
	LACM N↔FIXX↔CAIGE 3↔LACI 3
	DAC CNT↔SOS CNT			;NUMBER OF LATITUDES-1.
	FLOAT↔LAC 1,TWOPI↑
	FDVR 1,0↔DACN 1,DELTA		;DELTA RADIANS.

;SWEEP MERIDIAN WIRE INTO SHELL EAST TO WEST.
L2:	CALL(SWEEP,F,[0])
	CALL(ROTATE↑,F,[0],DELTA,[0])
	SOSLE CNT↔GO L2↔CALL(ROTCOM,F)	;CLOSE THE SHELL
	LAC 1,B↔POP3J

DECLARE{DELTA,CNT,B,F,V,V0}
ENDR MKBALL;7/19/73(BGB)----------------------------------------------
END
EULER.FAI - EOF.