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