perm filename OCCULT.NEW[GEM,BGB] blob sn#026243 filedate 1973-03-25 generic text, type T, neo UTF8
00100	TITLE OCCULT  -  A HIDDEN LINE ELIMINATOR  -  FEBRUARY 1973.
00200	
00300	;OCCULT IS DEPENDENT ON THE WING AND EULER PRIMITIVES.
00400	
00500		EXTERN MKB,MKF,MKE,MKV
00600		EXTERN KLB,KLF,KLE,KLV
00700		EXTERN WING,LINKED
00800		EXTERN ECW,ECCW,OTHER
00900		EXTERN BODY,FCW,FCCW,VCW,VCCW
01000		EXTERN MKEV,MKFE,ESPLIT,KLEV,KLFE
01100		EXTERN INVERT
01200	
01300	;LINK NAMES RELEVANT ONLY TO OCCULT.
01400	
01500		DEFINE PUF (Q,E)<CDR Q,8(E)>	;PVT'S UBER/UNDER FACE.
01600		DEFINE PUF.(Q,E)<DAP Q,8(E)>
01700		DEFINE NUF (Q,E)<CAR Q,8(E)>	;NVT'S UBER/UNDER FACE.
01800		DEFINE NUF.(Q,E)<DIP Q,8(E)>
01900		DEFINE TJOINT(Q,V)<CAR Q,2(V)>	;TJOINT RING.
02000		DEFINE TJOIN.(Q,V)<DIP Q,2(V)>
02100	
02200	;DIAGONOSTICS.
02300	
02400		WORLD:0
02500		EXTERN EDPY,VDPY
02600		EXTERN DPYSET,DPYBUF,DPYOUT,DPYBRT
02700		DMODE:-1
02800	
     

00100	SUBR(VERIFY)NAME,ARGCNT ------------------------------------------
00200	BEGIN VERIFY; DIAGONOSTIC DISPLAY FOR VERIFYING CORRECTNESS.
00300	
00400		OUTCHR[" "]
00500		SETZ 1,↔LAC 0,ARG2↔OUTSTR
00700	
00800		CALL(DPYSET,DPYBUF)
00900		LACI 16,-3(17)
01000		LAC  ARG1↔SUB 16,0↔MOVNS↔DIP 0,16
01100		JUMPE 0,L3
01200	L1:	CDR 1,(16)↔JUMPE 1,L2			;GET AN ARGUMENT.
01300		LAC 0,(1)			       ;GET ITS TYPE BITS.
01400		TLNE(FBIT)↔GO[CALL(FDPY,1)↔GO L2]
01500		TLNE(EBIT)↔GO[CALL(EDPY,1)↔GO L2]
01600		TLNE(VBIT)↔GO[CALL(VDPY,1)↔GO L2]
01700	L2:	AOBJN 16,L1
01800		CALL(DPYOUT,[2])
01900	L3:	SETZ↔SKIPN RUNFLG↔GO[INCHRW↔CAIN 175↔SETOM RUNFLG↔POP2J]
02000		INCHRS↔POP2J↔SETZM RUNFLG↔GO L3
02100		RUNFLG:0
02200	BEND;2/24/73------------------------------------------------------
     

00100	FDPY:;------------------------------------------------------------
00200	BEGIN FDPY
00300		EXTERN AIVECT,AVECT
00400		LAC 1,ARG1↔DAC 1,F
00500		PED 1,1↔DAC 1,E0↔DAC 1,E
00600		CALL(DPYBRT,[3])
00700		CALL(VCW,E,F)
00800		XDC 0,1↔FIXX↔YDC 1,1↔FIXX 1,↔CALL(AIVECT,0,1)
00900	L:	CALL(VCCW,E,F)
01000		XDC 0,1↔FIXX↔YDC 1,1↔FIXX 1,↔CALL(AVECT,0,1)
01100		SETQ(E,{ECCW,E,F})
01200		CAME 1,E0↔GO L↔CALL(DPYBRT,[2])↔POP1J
01300		DECLARE{F,E,E0}
01400	BEND;2/10/73------------------------------------------------------
01500	
01600	DPYALL:;----------------------------------------------------------
01700	BEGIN DPYALL
01800		EXTERN AIVECT,AVECT
01810		SKIPN DMODE↔POP0J
01900		CALL(DPYSET,DPYBUF)
02000		LAC 1,WORLD↔DAC 1,B
02100	L1:	LAC 1,B#↔CCW 1,1↔DAC 1,B
02200		TEST 1,BBIT↔GO[CALL(DPYOUT,[1])↔POP0J]
02300		DAC 1,E#↔SETZM CNT#
02400	L2:	LAC 1,E↔PED 1,1↔DAC 1,E↔AOS CNT
02500		TEST 1,EBIT↔GO L1
02600		TEST 1,POTENT↔GO L2
02700		PVT 2,1↔NVT 3,1
02800		XDC 0,3↔FIXX↔PUSH P,
02900		YDC 0,3↔FIXX↔PUSH P,
03000		XDC 0,2↔FIXX↔PUSH P,
03100		YDC 0,2↔FIXX↔PUSH P,
03200		CALL(AIVECT)
03300		CALL(AVECT)
03400		GO L2
03500	BEND;2/10/73------------------------------------------------------
     

00100	SUBR(OCCULT)WORLD ---------------------------------------------
00200		TDCA 1,1
00300		SETO 1,
00400		DAC 1,DMODE
00500	SUBR(ESCAN)WORLD ----------------------------------------------
00600	BEGIN ESCAN; BGB - 10 FEBRUARY 1973.
00700		ACCUMULATORS{E1,E2}
00800	
00900	;COMPARE EACH FOLDED EDGE WITH ALL THE OTHERS,
01000	;WHEN TWO EDGES CROSS MAKE A TJOINT.
01100	
01200		LAC 1,ARG1↔DAC 1,WORLD↔PED E1,1
01300	;	DAC 17,SAVE17#↔LAC 17,[IOWD =1800,DPYBUF+200]
01400		GO L1+2
01500	L1:	LAC E1,EDG1↔POTEN E1,E1
01600		DAC E1,EDG1↔JUMPE E1,[SKIPN DMODE↔POP1J
01700		CALL(DPYSET,DPYBUF)↔CALL(DPYOUT,[2])
01800	;	LAC 17,SAVE17
01900		POP1J]
02000		TEST E1,POTENT↔GO L1↔SKIPA E2,E1
02100	L2:	LAC E2,EDG2↔POTEN E2,E2↔DAC E2,EDG2↔JUMPE E2,L1
02200		TEST E2,POTENT↔GO L2
02300		CALL(COMPEE,EDG1,EDG2)
02400		JUMPLE 1,L2
02500		SETCM 1↔TRNE 441↔GO L2
02600		CALL(MKTJ,EDG1,EDG2)
02700		GO L2
02800	
02900	DECLARE{EDG1,EDG2}
03000	BEND;2/10/73------------------------------------------------------
     

00100	SUBR(MKTJ)FOLD,EDGE ---------------------------------------------
00200	BEGIN MKTJ; MAKE T-JOINT - BGB - 14 FEBRUARY 1973.
00300	
00400	;COMPUTE ZPP AT CROSSING: (XCROSS,YCROSS).
00500		LAC ARG2↔DAC FOLD
00600		LAC ARG1↔DAC EDGE
00700		SETQ(ZFOLD,{ZDEDGE,FOLD})
00800		SETQ(ZEDGE,{ZDEDGE,EDGE})
00900	
01000	;SWAP 'EM WHEN ZPP(JUT)>ZPP(JOT).
01100		LAC FOLD
01200		CAMLE 1,ZFOLD↔EXCH EDGE↔DAC FOLD
01300		SETQ(JUT,{EBREAK,EDGE})
01310		LAC EDGE↔TJOIN. 0,1
01400	
01500	;HIDE EDGES UNDER FOLD'S FACES.
01600		LAC 1,FOLD
01700		PFACE 0,1↔DAC FACE1
01800		NFACE 0,1↔DAC FACE2
01900	
02000	;ORIENT EDGE AND EJUT WITH RESPECT TO FOLD.
02100		SETQ(V,{OTHER,EDGE,JUT})
02200		LAC 1,JUT↔PED 1,1↔DAC 1,EJUT
02300		CALL(QFEV,FACE1,FOLD,V)
02400		JUMPG 1,[LAC EDGE↔EXCH EJUT↔DAC EDGE↔GO .+1]
02500	
02600	;CALL EHIDE.
02700		PUSH P,FACE1↔PUSH P,EJUT↔PUSH P,JUT↔PUSH P,FOLD
02800		CALL(EHIDE,FACE2,EDGE,JUT,FOLD)
02900		CALL(EHIDE)
03000		POP2J
03100	DECLARE{FOLD,EDGE,EJUT,JOT,JUT,FACE1,FACE2,V}
03200	DECLARE{ZFOLD,ZEDGE}
03300	BEND;2/14/73------------------------------------------------------
     

00100	SUBR(EHIDE)FACE,EDGE,VERTEX,FOLD----------------------------------
00200	BEGIN EHIDE; EDGE HIDE - BGB - 14 FEBRUARY 1973.
00300	
00400		LAC 1,ARG3↔DAC 1,EDGE↔TEST 1,POTENT↔POP4J
00500		LAC 1,ARG4↔DAC 1,FACE↔TEST 1,POTENT↔POP4J
00600		SKIPE DMODE↔GO[CALL(VERIFY,[ASCII/EHIDE/],[4])↔GO .+1]
00700		LAC 1,FACE↔SKIPN 2,ARG1↔PED 2,1↔DAC 2,EDG0↔DAC 2,EDG1
00800		LAC ARG2↔DAC V1↔SETQ(V2,{OTHER,EDGE,V1})
00900	
01000	;QMASK←(IF V2=NVT(E) THEN 200 ELSE 100).
01100		LACI 200↔LAC 1,EDGE↔NVT 1,1
01200		CAME 1,V2↔LACI 100↔DAC QMASK
01210		SKIPE ARG1↔GO L2
01300	
01400	;COMPARE EDGE WITH FACE.
01500	L1:	CALL(COMPEE,EDGE,EDG1)
01600		JUMPLE 1,L2			;DISJOINT.
01700		TDNE 1,QMASK↔GO L3		;V2 TOUCHING EDG1.
01800		TRNN 1,1↔GO L2			;CROSSING.
01900	
02000	;CROSSING - CONTINUE INTO NEXT FACE OR MAKE A TJOINT.
02100	L4:	CALL(OTHER,EDG1,FACE)
02200		TEST 1,POTENT
02300		GO[CALL(MKTJ,EDG1,EDGE)↔POP4J]
02400		DAC 1,FACE↔LAC EDG1↔DAC EDG0
02500	
02600	;DISJOINT - CONTINUE ON THIS FACE OR HIDE EDGE.
02700	L2:	SETQ(EDG1,{ECCW,EDG1,FACE})
02800		CAME 1,EDG0↔GO L1
02900		LAC 1,EDGE↔MARKZ 1,POTENT	        ;HIDE THIS EDGE.
03000		CALL(DPYALL)
03100		CALL(VHIDE,FACE,V2)↔POP4J	  ;HIDE ALL ITS FRIENDS.
03200	
03300	;TOUCHING.
03400	L3:	;OUTSTR[ASCIZ/TOUCH /]
03500		LAC 1,EDGE↔MARKZ 1,POTENT
03600		CALL(DPYALL)↔POP4J
03700	
03800	DECLARE{FACE,EDG0,EDG1,EDGE,V1,V2,QMASK}
03900	BEND;2/14/73------------------------------------------------------
     

00100	SUBR(VHIDE)FACE,VERTEX -----------------------------------------
00200	BEGIN VHIDE; HIDE VERTEX V UNDER FACE F.
00300	;VHIDE IS CALLED RECURSIVELY FROM EHIDE SO TEMPORARY CELLS FOR
00400	;V0 AND Z-FACE ARE KEPT IN THE LEFT HALF OF ARG1 AND ARG2.
00500		ACCUMULATORS{V,E,E0}
00510		SKIPE DMODE↔GO[CALL(VERIFY,[ASCII/VHIDE/],[2])↔GO .+1]
01000		CDR V,ARG1↔TEST V,POTENT↔POP2J
01200		MARKZ V,POTENT
01300		CDR ARG2↔CALL(ZDEPTH,0,V)↔HLLM 1,ARG2	;Z FACE LEVEL.
01400	L1:	CDR V,ARG1↔LAC 0,ZPP(V)↔CAML 0,ARG2↔GO L4
01500	L2:	CDR V,ARG1↔PED E,V↔DAC E,E0
01600	L3:	TEST E,POTENT↔GO[
01700		SETQ(E,{ECCW,E,V})↔CAME E,E0↔GO L3↔GO L4]
01800		CDR ARG2↔CALL(EHIDE,0,E,V,[0])↔GO L2
01900	L4:	CDR V,ARG1
02000		POP2J
02200	LIT
02300	BEND;2/14/73------------------------------------------------------
     

00100	;COMPARE EDGE-EDGE.
00200		INTERN XCROSS,YCROSS,ZCROSS,EPSLON,CEECNT
00300		XCROSS: 0↔YCROSS: 0↔ZCROSS: 0
00400		XCRUX: 0↔YCRUX: 0
00500		EPSLON: 0.01↔CEECNT: 0
00600	COMMENT/
00700		-1 EDGES ARE DISJOINT.
00800		 0 EDGES E1 AND E2 ARE IDENTICAL.
00900		+Q EDGES INTERSECT IN SOME MANNER.
01000		+1 EDGES CROSS OR TOUCH EACH OTHER.
01100		441 EDGE CROSS EACH OTHER.
01200	
01300		+110 PVT(E1) IS JOINED TO PVT(E2).
01400		+120 PVT(E1) IS JOINED TO NVT(E2).
01500		+210 NVT(E1) IS JOINED TO PVT(E2).
01600		+220 NVT(E1) IS JOINED TO NVT(E2).
01700	
01800		+401 E1 crosses E2's line.
01900		+201 NVT(E1) within ε of E2's line.
02000		+101 PVT(E1) within ε of E2's line.
02100	
02200		+ 41 E2 crosses E1's line.
02300		+ 21 NVT(E2) within ε of E1's line.
02400		+ 11 PVT(E2) within ε of E1's line.
02500	/
02600	SUBR(COMPEE)EDG1,EDG2---------------------------------------------
02700	BEGIN COMPEE
02800		ACCUMULATORS{Q1,Q2,E1,E2,V1,V2,U1,U2}
03200		AOS CEECNT
03300		SETZ 1,↔LAC E1,ARG2↔LAC E2,ARG1
03400		CAMN E1,E2↔POP2J; IDENTITY CASE.
03500	
03600	;FETCH ENDPOINTS - RING'A'AROUND TJOINTS TO GET THE JOT.
03700		PVT V1,E1↔NVT V2,E1
03800		PVT U1,E2↔NVT U2,E2
04300	
04400	;TEST FOR EDGES ALREADY HAVINGS A VERTEX OR TJOINT IN COMMON.
04450		TJOINT 0,V1
04500		NIM 1,110↔CAMN V1,U1↔POP2J↔CAMN 0,E2↔POP2J
04550		TJOINT 0,U2
04600		NIM 1,120↔CAMN V1,U2↔POP2J↔CAMN 0,E1↔POP2J
04650		TJOINT 0,V2
04700		NIM 1,210↔CAMN V2,U1↔POP2J↔CAMN 0,E2↔POP2J
04750		TJOINT 0,U1
04800		NIM 1,220↔CAMN V2,U2↔POP2J↔CAMN 0,E1↔POP2J
     

00001		LO1←←0 ↔ HI1←←1 ↔ LO2←←2 ↔ HI2←←3
00101	
00201	;TEST FOR X-SPAN NOT OVERLAPPING.
00301		LAC LO1,XPP(V1)↔LAC HI1,XPP(V2)↔CAMG HI1,LO1↔EXCH HI1,LO1
00401		LAC LO2,XPP(U1)↔LAC HI2,XPP(U2)↔CAMG HI2,LO2↔EXCH HI2,LO2
00501		CAMG LO1,HI2↔GO .+4↔FSBR LO1,HI2↔CAMLE LO1,EPSLON↔GO L0
00601		CAMG LO2,HI1↔GO .+4↔FSBR LO2,HI1↔CAMLE LO2,EPSLON↔GO L0
00701	
00801	;TEST FOR Y-SPAN NOT OVERLAPPING.
00901		LAC LO1,YPP(V1)↔LAC HI1,YPP(V2)↔CAMG HI1,LO1↔EXCH HI1,LO1
01001		LAC LO2,YPP(U1)↔LAC HI2,YPP(U2)↔CAMG HI2,LO2↔EXCH HI2,LO2
01101		CAMG LO1,HI2↔GO .+4↔FSBR LO1,HI2↔CAMLE LO1,EPSLON↔GO L0
01201		CAMG LO2,HI1↔GO .+4↔FSBR LO2,HI1↔CAMLE LO2,EPSLON↔GO[L0:
01301		SETO 1,↔POP2J]
01401	
04900		SETZ 1,
     

00100	;COMPARE E1 AND U1.
00200		LAC Q1,CC(E1)
00300		LAC BB(E1)↔FMPR YPP(U1)↔FADR Q1,0
00400		LAC AA(E1)↔FMPR XPP(U1)↔FADR Q1,0
00500		LACM Q1↔CAMG EPSLON↔TRO 1,10; U1 TOUCHES E1'S LINE.
00600	
00700	;COMPARE E1 AND U2.
00800		LAC Q2,CC(E1)
00900		LAC BB(E1)↔FMPR YPP(U2)↔FADR Q2,0
01000		LAC AA(E1)↔FMPR XPP(U2)↔FADR Q2,0
01100		LACM Q2↔CAMG EPSLON↔TRO 1,20; U2 TOUCHES E1'S LINE.
01200	
01300	;EXIT WHEN U1 AND U2 ARE CLEAR OF E1 ON THE SAME SIDE.
01400		XOR Q1,Q2↔JUMPGE Q1,[TRNE 1,30↔GO .+2↔SETO 1,↔POP2J]
01500		TRO 1,40   ;E1 CROSSES E2'S LINE.
01600		
01700	;COMPARE E2 AND V1.
01800		LAC Q1,CC(E2)
01900		LAC BB(E2)↔FMPR YPP(V1)↔FADR Q1,0
02000		LAC AA(E2)↔FMPR XPP(V1)↔FADR Q1,0
02100		LACM Q1↔CAMG EPSLON↔TRO 1,100; V1 TOUCHES E2'S LINE.
02200	
02300	;COMPARE E2 AND V2.
02400		LAC Q2,CC(E2)
02500		LAC BB(E2)↔FMPR YPP(V2)↔FADR Q2,0
02600		LAC AA(E2)↔FMPR XPP(V2)↔FADR Q2,0
02700		LACM Q2↔CAMG EPSLON↔TRO 1,200; V2 TOUCHES E2'S LINE.
02800	
02900	;EXIT WHEN V1 AND V2 ARE CLEAR OF E2 ON THE SAME SIDE.
03000		XOR Q1,Q2↔JUMPGE Q1,[TRNE 1,300↔GO .+2↔SETO 1,↔POP2J]
03100		TRO 1,400   ;E2 CROSSES E1'S LINE.
03200	
03300	;SOLVE FOR CROSSING LOCUS.
03400		DAC 1,AC1
03500		LAC AA(E1)↔FMPR BB(E2)
03600		LAC 1,AA(E2)↔FMPR 1,BB(E1)↔FSBR 0,1↔DAC TT#
03700		LAC BB(E1)↔FMPR CC(E2)
03800		LAC 1,BB(E2)↔FMPR 1,CC(E1)↔FSBR 0,1↔FDVR 0,TT↔DAC XCROSS
03900		LAC CC(E1)↔FMPR AA(E2)
04000		LAC 1,CC(E2)↔FMPR 1,AA(E1)↔FSBR 0,1↔FDVR 0,TT↔DAC YCROSS
04100		LAC XCROSS↔FMPR[3.5]↔DAC XCRUX
04200		LAC YCROSS↔FMPR[3.5]↔DAC YCRUX
04300		LAC 1,AC1↔TRO 1,1↔POP2J
04400	BEND;2/10/73------------------------------------------------------
     

00100	SUBR(ZDEDGE)EDGE -------------------------------------------------
00200	BEGIN ZDEDGE; SOLVE FOR ZDEPTHS AT THE CROSSING(XCROSS,YCROSS).
00300	;Z←((Z2-Z1)*(XCROSS-X1)/(X2-X1))+Z1
00400		ACCUMULATORS{E,V1,V2}
00500		
00600		LAC E,ARG1
00700		PVT V1,E↔NVT V2,E
00800		LACM 0,AA(E)↔LACM 1,BB(E)↔CAMGE 1,0↔GO L
00900	
01000	;WHEN DX ≥ DY:
01100		LAC 1,ZPP(V2)↔FSBR 1,ZPP(V1)
01200		LAC 0,XCROSS↔ FSBR 0,XPP(V1)↔FMPR 1,0
01300		LAC 0,XPP(V2)↔FSBR 0,XPP(V1)↔FDVR 1,0
01400		FADR 1,ZPP(V1)↔DAC 1,ZCROSS↔POP1J
01500	
01600	;WHEN DY > DX:
01700	L:	LAC 1,ZPP(V2)↔FSBR 1,ZPP(V1)
01800		LAC 0,YCROSS↔ FSBR 0,YPP(V1)↔FMPR 1,0
01900		LAC 0,YPP(V2)↔FSBR 0,YPP(V1)↔FDVR 1,0
02000		FADR 1,ZPP(V1)↔DAC 1,ZCROSS↔POP1J
02100	BEND;2/10/73------------------------------------------------------
     

00100	SUBR(EBREAK)EDGE -------------------------------------------------
00200	BEGIN EBREAK;EBREAK(EDGE) IS LIKE ESPLIT.
00300		ACCUMULATORS{B,E,V,Q,R,ENEW,VNEW,PV,NV}
00400	
00500	;GET ZDEPTH AT CROSSING.
00600		CALL(ZDEDGE,ARG1)
00700	;CREATE A NEW EDGE AND A NEW VERTEX.
00800		CDR E,ARG1↔PVT V,E↔PBODY B,E
00900		SETQ(VNEW,{MKV,B})↔MARK VNEW,TMPBIT+POTENT
01000		TJOIN. VNEW,VNEW
01100		LAC XCROSS↔DAC XPP(VNEW)↔LAC XCRUX↔XDC. 0,VNEW
01200		LAC YCROSS↔DAC YPP(VNEW)↔LAC YCRUX↔YDC. 0,VNEW
01300		LAC ZCROSS↔DAC ZPP(VNEW)
01400		SETQ(ENEW,{MKE,B})↔MARK ENEW,POTENT
01500	
01600	;COPY EDGE COEFFICIENTS.
01700		SLACI AA(E)↔LAPI AA(ENEW)↔BLT CC(ENEW)
01800	;PLACE EDGE AT END OF POTENT EDGE LIST.
01900		LAC 1,WORLD↔NED 2,1↔NED. ENEW,1↔POTEN. ENEW,2
02000	;PLACE VNEW BETWEEN E AND ENEW.
02100		PED 0,V↔CAMN 0,E↔PED. ENEW,V
02200		PED. ENEW,VNEW↔PVT PV,E↔PVT. PV,ENEW
02300		PVT. VNEW,E↔NVT. VNEW,ENEW
02400		PFACE 0,E↔PFACE. 0,ENEW
02500		NFACE 0,E↔NFACE. 0,ENEW
02600	;NEW UPPER WINGS ARE LIKE THE OLDE;
02700		PCW 0,E↔CALL(WING,0,ENEW)
02800		NCCW 0,E↔CALL(WING,0,ENEW)
02900	;EDGES POINT AT EACH OTHER ACROSS VNEW.
03000		NCCW. ENEW,E↔PCW.  ENEW,E
03100		NCW.  E,ENEW↔PCCW. E,ENEW
03200		LAC 1,VNEW↔POP1J
03300	BEND;2/10/73------------------------------------------------------
     

00100	SUBR(QEV)E,V------------------------------------------------------
00200	BEGIN QEV
00300		ACCUMULATORS{E,V}
00400		LAC V,ARG1
00500		LAC E,ARG2
00600		LAC 1,CC(E)
00700		LAC BB(E)↔FMPR YPP(V)↔FADR 1,0
00800		LAC AA(E)↔FMPR XPP(V)↔FADR 1,0
00900		POP2J
01000	BEND;2/10/73------------------------------------------------------
01100	
01200	SUBR(QFEV)F,E,V --------------------------------------------------
01300	BEGIN QFEV
01400		ACCUMULATORS{E,V}
01500		LAC V,ARG1
01600		LAC E,ARG2
01700		LAC 1,CC(E)
01800		LAC BB(E)↔FMPR YPP(V)↔FADR 1,0
01900		LAC AA(E)↔FMPR XPP(V)↔FADR 1,0
02000		PFACE 0,E↔CAME 0,ARG3↔MOVNS 1
02100		POP3J
02200	BEND;2/10/73------------------------------------------------------
02300	
02400	SUBR(CROSSING)X,Y,E1,E2 ------------------------------------------
02500	BEGIN CROSSING
02600		ACCUMULATORS{TT,XPTR,YPTR,E1,E2}
02700		LAC E2,ARG1
02800		LAC E1,ARG2
02900		LAC YPTR,ARG3
03000		LAC XPTR,ARG4
03100		LAC AA(E1)↔FMPR BB(E2)
03200		LAC 1,AA(E2)↔FMPR 1,BB(E1)↔FSBR 0,1↔DAC TT
03300		LAC BB(E1)↔FMPR CC(E2)
03400		LAC 1,BB(E2)↔FMPR 1,CC(E1)↔FSBR 0,1↔FDVR 0,TT↔DAC(XPTR)
03500		LAC CC(E1)↔FMPR AA(E2)
03600		LAC 1,CC(E2)↔FMPR 1,AA(E1)↔FSBR 0,1↔FDVR 0,TT↔DAC(YPTR)
03700		POP4J
03800	BEND;2/10/73------------------------------------------------------
     

00100	SUBR(ZDEPTH)FACE,VERTEX ------------------------------------------
00200	BEGIN ZDEPTH
00300		ACCUMULATORS{F,V}
00400		LAC V,ARG1
00500		LAC F,ARG2
00600		LAC 1,KK(F)
00700		LAC AA(F)↔FMPR XPP(V)↔FSBR 1,0
00800		LAC BB(F)↔FMPR YPP(V)↔FSBR 1,0
00900		FDVR 1,CC(F)
01000		POP2J
01100	BEND;2/10/73------------------------------------------------------
01200	
01300	SUBR(ZDALT)FACE,XPP,YPP ------------------------------------------
01400	BEGIN ZDALT
01500		ACCUMULATORS{F}
01600		LAC F,ARG3
01700		LAC 1,KK(F)
01800		LAC AA(F)↔FMPR ARG2↔FSBR 1,0
01900		LAC BB(F)↔FMPR ARG1↔FSBR 1,0
02000		FDVR 1,CC(F)
02100		POP3J
02200	BEND;2/10/73------------------------------------------------------
     

00100	SUBR(KLJOTS)WORLD-------------------------------------------------
00200	BEGIN KLJOTS
00300		ACCUMULATORS{B,V}
00400		LAC B,ARG1
00500	L1:	CCW B,B
00600		TEST B,BBIT↔POP1J
00700	;FOR ALL THE VERTICES OF EACH BODY.
00800		LAC V,B
00900	L2:	NVT V,V
01000		TEST V,VBIT↔GO L1
01100		TEST V,TMPBIT↔GO L2
01200		TEST V,JOTBIT↔GO L2
01250		NVT V,V↔PUSH P,V↔PUSH P,B
01300		PVT V,V↔CALL(KLEV,V)
01400		POP P,B↔POP P,V↔GO L2+1
01500	BEND;2/16/73------------------------------------------------------
01600	
01700	SUBR(KLJUTS)WORLD-------------------------------------------------
01800	BEGIN KLJUTS
01900		ACCUMULATORS{B,V}
02000		LAC B,ARG1
02100	L1:	CCW B,B
02200		TEST B,BBIT↔POP1J
02300	;FOR ALL THE VERTICES OF EACH BODY.
02400		LAC V,B
02500	L2:	NVT V,V
02600		TEST V,VBIT↔GO L1
02700		TEST V,TMPBIT↔GO L2
02800		TEST V,JUTBIT↔GO L2
02850		NVT V,V↔PUSH P,V↔PUSH P,B
02900		PVT V,V↔CALL(KLEV,V)
03000		POP P,B↔POP P,V↔GO L2+1
03100	BEND;2/16/73------------------------------------------------------
03200	
03300	END