perm filename EULER[GEM,BGB]2 blob
sn#036847 filedate 1973-04-24 generic text, type T, neo UTF8
COMMENT ⊗ VALID 00022 PAGES
RECORD PAGE DESCRIPTION
00001 00001
00004 00002 TITLE EULER - EULER PRIMITIVES - JULY 1972.
00006 00003 SUBR(INVERT)------------------------------------------------------
00008 00004 VNEW ← MKEV(F,V). "E" COMMAND.
00010 00005 ENEW ← MKFE(V1,F,V2) "J" COMMAND.
00013 00006 CDR V2'S TAIL REPLACING F'S WITH FNEW.
00015 00007 VNEW ← ESPLIT(E) "M" COMMAND.
00017 00008 F ← KLFE(ENEW) "K" COMMAND.
00019 00009 E ← KLEV(VNEW) "K" COMMAND.
00022 00010 V ← KLVE(E) - KILL E & NVT(E) RETURNING PVT(E).
00024 00011 BNEW ← MKCOPY(B).
00026 00012 L5: SETZ↔LAC 1,BNEW↔SKIPA E,ARG1
00027 00013 ENEW ← GLUEE(F1,V1,F2,V2) - LIKE TWO MKEV(F,V)'S BACK TO BACK.
00028 00014 . GLUEE MANDALA
00030 00015 SUBR(GLUE)F1,F2---------------------------------------------------
00033 00016 SUBR(SWEEP)FACE,FLAG----------------------------------------------
00036 00017 SWEEP2:FACE,FLAG-------------------------------------------------
00039 00018 SUBR(ROTCOM)FACE--------------------------------------------------
00041 00019 SUBR(PYRAMID)FACE OR VERTEX---------------------------------------
00043 00020 SUBR(REMOVF)FACE-------------------------------------------------
00045 00021 SUBR(FVDUAL)BODY-------------------------------------------------
00047 00022 SUBR(MKCUBE)DX,DY,DZ --------------------------------------------
00048 ENDMK
⊗;
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↔LACM 1,(B)↔SKIPE 1↔TLNE 1,(1B9)↔GO[
CALL(MKNODE,[0])↔SLACI XWC(B)↔LAPI XWC(1)↔BLT KZ(1)↔POP1J]
TEST B,BBIT↔POP1J↔SETQ(BNEW,{MKB,B})
FRAME Q,B↔SKIPE Q↔GO[CALL(MKFRAME)↔FRAME. 1,BNEW
SLACI XWC(Q)↔LAPI XWC(1)↔BLT KZ(1)↔GO .+1]
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 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
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.