perm filename XBIN.SAI[GEM,BGB] blob
sn#028614 filedate 1973-03-25 generic text, type T, neo UTF8
00100 ENTRY DUMMY;
00200 BEGIN "BIN"
00300 REQUIRE "ABBREV" SOURCE_FILE;
00400 REQUIRE "GEOMES" SOURCE_FILE;
00500 DEFINE β="COMMENT";
00600
00700 XSUBR FACOEF(ITG B,FLG);
00800
00900 REAL A,B,C,K,X,Y,Z;
01000
01100 DEFINE SUR(V)="(MEMORY[V]LAND '100000000000)";
01200 SUBR SUR.(ITG V);
01300 MEMORY[V]←MEMORY[V]LOR '100000000000;
01400
01500 DEFINE OK(V)="(MEMORY[V]LAND '200000000000)";
01600 SUBR OK.(ITG V);
01700 MEMORY[V]←MEMORY[V]LOR '200000000000;
01800
01900 α THE Q FACE IS A FACE THAT INTERSECTS SOME FACE, EDGE OR VERTEX;
02000 DEFINE QFACE="SERIAL";
02100 DEFINE QFACE.="SERIA.";
02200 DEFINE NQFACE(E)="CAR(E-1)",PQFACE(E)="CDR(E)",
02300 NQFACE.(F,E)="DIP(F,E-1)", PQFACE.(F,E)="DAP(F,E)";
02400 ISUBR OTHERQF(ITG E,F);
02500 RETURN(IF F=PQFACE(E) THEN NQFACE(E) ELSE PQFACE(E));
02600
02700 α JOIN ALTERNATES;
02800 DEFINE JALT(A1,A2)=
02900 "S⊂ MOVE 11,A1;MOVE 12,A2;HRLM 11,6(12);HRLM 12,6(11);⊃";
03000 SUBR JALTV(ITG V1,V2);
03100 S⊂
03200 MOVE 11,V1;MOVE 12,V2;
03300 HRLM 11,6(12);HRLM 12,6(11);
03400 MOVE 13,-3(11);MOVEM 13,-3(12);
03500 MOVE 13,-2(11);MOVEM 13,-2(12);
03600 MOVE 13,-1(11);MOVEM 13,-1(12);
03700 END;
03800
03900 DEFINE ALT2(V)="CDR(V+6)",ALT2.(U,V)="DAP(U,V+6)";
00100 α AD HOC, BOOTSTRAP, PROTO-TYPE WORLD DIRECTORY;
00200
00300 EXTERNAL INTEGER WPTR;
00400 EXTERNAL STRING WORLDNAME;
00500 EXTERNAL STRING ARRAY NAME[1:50];
00600 EXTERNAL INTEGER ARRAY ENTITY[1:50];
00700 EXTERNAL INTEGER ARRAY FILE[1:50];
00800 EXTERNAL INTEGER ARRAY DSKBLK[1:50];
00900 EXTERNAL INTEGER ARRAY PART#[1:50];
01000 EXTERNAL INTEGER ARRAY COPAR#[1:50];
01100
01200 α DIAGONOSTIC DISPLAY ROUTINES;
01300
01400 XSUBR DPYF(ITG F);
01500 XSUBR DPYE(ITG E);
01600 XSUBR DPYV(ITG V);
01700 XSUBR DPYALL;
01800 XSUBR OSTR(STRING S);
01900 EXTERNAL STRING PROCEDURE ISTR (ITG Q);
02000 SAFE EXTERNAL INTEGER ARRAY DPYBUF[1:200];
02100 XSUBR DPYSET (ITG ARRAY DPYBUF);
02200 DEFINE !="DPYSET(DPYBUF)",$="&"",""&",$$="&"")"" ";
02300
02400 XSUBR DPYSUB(ITG X);
00100 α TEST WHETHER LOCUS (X,Y,Z) IS WITHIN FACE F;
00200 BSUBR WITHIN (ITG F);
00300 BEGIN "WITHIN"
00400 ITG E,E0,V,I,FLG;
00500 REAL DX1,DY1,DZ1,DX2,DY2,DZ2;
00600 REAL Q1,Q2;
00700 α SELECT LARGEST FACE COEFFICIENT;
00800 I ← (IF ABS(A)>ABS(B) THEN
00900 (IF ABS(A)>ABS(C) THEN 0 ELSE 2) ELSE
01000 (IF ABS(B)>ABS(C) THEN 1 ELSE 2));
01100 α EDGE LOOP INITIALIZATION;
01200 FLG ← FALSE;
01300 E ← E0 ← PED(F); V ← VCW(E,F);
01400 DX2 ← XWC(V)-X; DY2 ← YWC(V)-Y; DZ2 ← ZWC(V)-Z;
01500 DO BEGIN "ELOOP"
01600 DX1←DX2; DY1←DY2; DZ1←DZ2;
01700 V ← VCCW(E,F); E ← ECCW(E,F);
01800 DX2 ← XWC(V)-X; DY2 ← YWC(V)-Y; DZ2 ← ZWC(V)-Z;
01900 α COMPUTE A COMPONENT OF THE CROSS-PRODUCT AND LOOK FOR SIGN CHANGE;
02000 Q1←Q2; Q2 ← CASE I OF
02100 ((DY2*DZ1-DY1*DZ2),(DX1*DZ2-DX2*DZ1),(DX2*DY1-DY2*DX1));
02200 IF FLG ∧ (Q1⊗Q2)<0 THEN RETURN(FALSE);FLG←TRUE;
02300 END "ELOOP" UNTIL E=E0;
02400 RETURN(TRUE);
02500 END "WITHIN";
00100 α COMPARE FACE-EDGE;
00200 SUBR COMPFE (ITG F,E);
00300 BEGIN "COMPFE"
00400 ITG V,V1,V2,EE;
00500 REAL X1,Y1,Z1,Q1;
00600 REAL X2,Y2,Z2,Q2;
00700 REAL S,DX,DY,DZ,K;
00800
00900 α PICKUP THE ENDS OF THE EDGE;
01000 V1←NVT(E); V2←PVT(E);
01100 IF QFACE(V1)=F ∨ QFACE(V2)=F THEN RETURN;
01200 X1←XWC(V1); Y1←YWC(V1); Z1←ZWC(V1);
01300 X2←XWC(V2); Y2←YWC(V2); Z2←ZWC(V2);
01400
01500 α COMPUTE DIRECTED DISTANCE FROM FACE;
01600 A←AA(F); B←BB(F); C←CC(F);
01700 Q1 ← A*X1 + B*Y1 + C*Z1;
01800 Q2 ← A*X2 + B*Y2 + C*Z2;
01900 K ← KK(F);
02000 IF (Q1>K ∧ Q2>K) ∨ (Q1<K ∧ Q2<K) ∨ ABS(Q2-Q1)<1@-6 THEN RETURN;
02100 S ← (K-Q1)/(Q2-Q1);
02200 X ← X1+S*(X2-X1); Y ← Y1+S*(Y2-Y1); Z ← Z1+S*(Z2-Z1);
02300 IF 0≤S ∧ S≤1 ∧ WITHIN(F) THEN ELSE RETURN;
02400 IF Q1<K THEN INVERT(E);
02500
02600 α CREATE PIERCING POINT;
02700 V ← ESPLIT(E);
02800 SUR.(V);PED.(E,V);QFACE.(F,V);
02900 DACR(X,V-3); DACR(Y,V-2); DACR(Z,V-1);
03000
03100 α β DPYSUB(0):β !:β DPYF(F):β DPYE(E):β DPYV(V):β OSTR("COMPFE");
03200 END "COMPFE";
03300
03400 COMMENT
03500 V2 ← PVT ⊗ Q2 < K ABOVE F,
03600 | ENEW
03700 ____|_____________________
03800 / | /
03900 / ⊗ V FACE F /
04000 /_________________________/
04100 |
04200 | E
04300 V1 ← NVT ⊗ Q1 > K BELOW-F;
00100 α GET TO THE OTHER PIERCING VERTEX OF TWO FACES;
00200 ISUBR OTHERV(ITG F,V1);
00300 BEGIN "OTHERV"
00400 ITG F1,F2,E,E0,V2;
00500 F2 ← F;
00600 F1 ← QFACE(V1);
00700 α OUTSTR(9&"OTHERV "&CVS(F1)&" "&CVS(V1)&" "&CVS(F2)&↓);
00800
00900 α F1 PIERCES F2 AT V2;
01000 E←E0←PED(F1);
01100 DO IF F2=QFACE(V2←VCCW(E,F1)) THEN RETURN(V2)
01200 UNTIL E0=(E←ECCW(E,F1));
01300
01400 α F2 PIERCES F1 AT V2;
01500 E←E0←PED(F2);
01600 DO IF F1=QFACE(V2←VCCW(E,F2))∧(V1≠V2) THEN RETURN(V2)
01700 UNTIL E0=(E←ECCW(E,F2));
01800
01900 FATAL("OTHERV");
02000 END "OTHERV";
02100
02200 COMMENT - OTHER PIERCING VERTEX MANDALA:
02300
02400 α F1 PIERCES F2 AT V2 CASE. α F2 PIERCES F1 AT V2 CASE.
02500 ______________ ________
02600 | | | |
02700 | F2 | | F2 |
02800 ______|......... | ______|........|_____
02900 | ↓ . | | ↓ ↓ |
03000 | F1 ⊗V1 ⊗V2 | | F1 ⊗V1 ⊗V2 |
03100 |_______________↑ | |_____________________|
03200 | | | |
03300 |______________| |________| ;
00100 REQUIRE "SAITRG" SOURCE_FILE;
00200
00300 α DISTANCE BETWEEN TWO VERTICES;
00400 RSUBR DISTANCE (ITG V1,V2);
00500 RETURN(SQRT((XWC(V1)-XWC(V2))↑2
00600 +(YWC(V1)-YWC(V2))↑2
00700 +(ZWC(V1)-ZWC(V2))↑2));
00800
00900 α COMPUTE THE ANGLE OF SOLID INTERIOR AT SURFACE POINT V;
01000 RSUBR ANGLSI (ITG V);
01100 BEGIN "ANGLSI"
01200 ITG E,F1,F2,V1,V2;
01300 REAL L1,L2,L3,ANG,Q;
01400
01500 E ← PED(V);
01600 F1 ← FCCW(E,V); V1←OTHERV(F1,V);
01700 F2 ← FCW(E,V); V2←OTHERV(F2,V);
01800
01900 L1 ← DISTANCE(V1,V);
02000 L2 ← DISTANCE(V2,V);
02100 L3 ← DISTANCE(V1,V2);
02200
02300 ANG ← ACOS((L1*L1 + L2*L2 - L3*L3)/(2*L1*L2));
02400 Q ← XWC(V2)*AA(F1) + YWC(V2)*BB(F1) + ZWC(V2)*CC(F1);
02500 IF Q<KK(F1) THEN ANG ← 2*π - ANG;
02600 β !;β DPYV(V);β OSTR("ANGLSI = "&CVS(180*ANG/π));
02700 RETURN(ANG);
02800 END "ANGLSI";
00100 α GET NEXT DOMAIN VERTEX CCW ABOUT F FROM E. & V;
00200 ITG FNEXT,ENEXT;
00300 ISUBR VNEXT(ITG F,E.,V);
00400 BEGIN "VNEXT"
00500 β OUTSTR("VNEXT ");
00600
00700 α INTERIOR TO INTERIOR;
00800 ENEXT ← ALT(E.);
00900 β IF ¬SUR(V) THEN OUTSTR(" INTERIOR TO INTERIOR."&↓);
01000 IF ¬SUR(V) THEN
01100 RETURN(VCCW(ENEXT←ECCW(ENEXT,F),F));
01200
01300 α SURFACE TO INTERIOR;
01400 FNEXT ← QFACE(V);
01500 β IF FNEXT≠F ∧ ENEXT=0 THEN OUTSTR(" SURFACE TO INTERIOR."&↓);
01600 IF FNEXT≠F ∧ ENEXT=0 THEN
01700 RETURN(OTHER(ENEXT←PED(V),V));
01800
01900 α INTERIOR TO SURFACE;
02000 ENEXT ← 0;
02100 β IF FNEXT≠F THEN OUTSTR(" INTERIOR TO SURFACE."&↓);
02200 IF FNEXT≠F THEN RETURN(OTHERV(F,V));
02300
02400 α SURFACE TO SURFACE;
02500 β OUTSTR(" SURFACE TO SURFACE."&↓);
02600 FNEXT ← OTHERQF(E.,F);
02700 FNEXT ← OTHER(PED(V),FNEXT);
02800 RETURN(OTHERV(FNEXT,V));
02900 END "VNEXT";
00100 SUBR FACECOMPLETION(ITG F.);
00200 BEGIN "FACECO"
00300 ITG V0,U,V,V.,E,E.,F;
00400
00500 α GET THE FIRST EDGE AND ITS FRIENDS;
00600 E. ← PED(F.);
00700 V0 ← ALT(VCW(E.,F.));
00800 V ← ALT(VCCW(E.,F.));
00900 F ← IF (E←ALT(E.)) THEN OTHER(E,ALT(OTHER(E.,F.)))ELSE
01000 IF F.=PFACE(E.) THEN PQFACE(E.) ELSE NQFACE(E.);
01100 JALT(F,F.);
01200 β DPYSUB(0);β !;β DPYE(E.);β DPYV(V);β OSTR("FIRST EDGE.");
01300
01400 α F. PERIMETER FOLLOWING LOOP;
01500 WHILE TRUE DO
01600 BEGIN "PERIMETER LOOP"
01700 IF V=V0 THEN RETURN;
01800 U←V; V←VNEXT(F,E.,V);
01900 V. ← VCCW(E.←ECCW(E.,F.),F.);
00100 α MAKE SPUR;
00200 IF ALT(V)=0 THEN
00300 BEGIN "SPUR"
00400 V.←MKEV(F.,ALT(U));
00500 JALTV(V,V.);
00600 E.←PED(V.);
00700 β DPYSUB(0);
00800 β !;β DPYE(E.);
00900 β DPYV(V.);
01000 β OSTR("MAKE SPUR");
01100 IF ENEXT THEN JALT(ENEXT,E.) ELSE
01200 ⊂ NQFACE.(FNEXT,E.);PQFACE.(F,E.);⊃;
01300 END "SPUR" ELSE
01400
01500 α SPLIT FACE;
01600 IF V.≠ALT(V) THEN
01700 IF LINKED(ALT(V),F.) THEN
01800 BEGIN
01900 E.←MKFE(ALT(U),F.,ALT(V));
02000 β !;β DPYE(E.);
02100 β DPYV(ALT(U));
02200 β DPYV(ALT(V));
02300 β OSTR("SPLIT FACE");
02400 IF ENEXT THEN JALT(ENEXT,E.) ELSE
02500 ⊂ NQFACE.(FNEXT,E.);PQFACE.(F,E.);⊃;
02600 END ELSE
02700 BEGIN "MAKE WASP FACE"
02800 ITG F2.,U.;
02900 V. ← ALT(V); U. ← ALT(U);
03000 F2. ← PFACE(F.);
03100 WHILE ¬LINKED(F2.,V.) DO
03200 IF FTYPE(F2.) THEN F2.←PFACE(F.)
03300 ELSE FATAL("WASP LINK F2. NOT FOUND !");
03400 E. ← GLUEE(F.,U.,F2.,V.);
03500 IF ENEXT THEN JALT(ENEXT,E.) ELSE
03600 ⊂ PQFACE.(FNEXT,E.);NQFACE.(F,E.);⊃;
03700 END;
03800 END "PERIMETER LOOP";
03900 END "FACECO";
00100 α MAKE A BODY OF INTERSECTION;
00200 ISUBR MKBIN (ITG V0);
00300 BEGIN "MKBIN"
00400 ITG B,F,F.,E,E.,V,V.;
00500
00600 α CREATE A GEOMED BODY;
00700 B ← MKBFV;
00800 RINGIN(B,WORLD,#ALBODY);
00900 INCREM(WPTR);
01000 ENTITY[WPTR]←PART#[WPTR]←COPAR#[WPTR]←B;
01100 PNAME.(WPTR,B);
01200
01300 E←SERIAL(B); NAME[WPTR]←"B"&CVS(E);
01400
01500 LOCOR.(MKLOCOR,B);
01600
01700 α MAKE FIRST EDGE OF THE LAMINA;
01800 V.←PVT(B);JALTV(V0,V.);
01900 β DPYSUB(0);β !;β DPYV(V.);β OSTR("MKBIN ENTRY");
02000 E←PED(V0);
02100 F←FCCW(E,V0);F.←PFACE(B);JALT(F,F.);
02200 V←VCCW(E,F);
02300 V.←MKEV(F.,V.);JALTV(V,V.);
02400 E.←PED(V.);JALT(E,E.);
02500
02600 β DPYSUB(0);β !;β DPYE(E.);β DPYV(V.);
02700 β OSTR("FIRST EDGE");
00100 α LAMINA FOLLOWING LOOP;
00200 WHILE TRUE DO
00300 BEGIN "LAMINA"
00400 V←VNEXT(F,E.,V);
00500 IF V=V0 THEN
00600 BEGIN
00700 E.←MKFE(ALT(V0),F.,V.);
00800
00900 β DPYSUB(0);β !;β DPYE(E.);β DPYV(V);β OSTR("NEW E.");
01000
01100 IF ENEXT THEN JALT(ENEXT,E.) ELSE
01200 ⊂ PQFACE.(FNEXT,E.);NQFACE.(F,E.);⊃;
01300 F.←NFACE(E.);
01400 DONE;
01500 END;
01600 V.←MKEV(F.,V.);JALTV(V,V.);E.←PED(V.);
01700 IF ENEXT THEN JALT(ENEXT,E.) ELSE
01800 ⊂ PQFACE.(F,E.);NQFACE.(FNEXT,E.);⊃;
01900
02000 β DPYSUB(0);β !;β DPYE(E.);β DPYV(V.);β OSTR("NEW E. & V.");
02100
02200 END "LAMINA";
02300 EVERT(B); α SIGH;
02400
02500 α COMPLETE ALL THE FACES OF THE BODY;
02600 WHILE FTYPE(F.) DO
02700 ⊂ FACECOMPLETION(F.);F.←PFACE(F.);⊃;
02800 RETURN(B);
02900 END "MKBIN";
00100 α KILL ALL THE SURV OF A BODY;
00200 SUBR KLSURV (ITG B);
00300 BEGIN "KLSURV"
00400 ITG V,U,E;
00500 β OUTSTR("KLSURV ");
00600 V←PVT(B);
00700 DO IF SUR(V) THEN ⊂ U←PVT(V);E←KLEV(V);V←U; ⊃
00800 ELSE V←PVT(V) UNTIL BTYPE(V);
00900 END "KLSURV";
01000
01100 α BLESS ALL THE SURV OF A LOOP;
01200 SUBR OKSURV (ITG V);
01300 BEGIN "OKSURV"
01400 ITG U,F;
01500 β OUTSTR("OKSURV ");
01600 F ← PFACE(PED(V));
01700 WHILE TRUE DO ⊂
01800 OK.(V);
01900 U←V; V ← OTHERV(F,U);
02000 IF OK(V) THEN RETURN;
02100 F ← (IF QFACE(U)=QFACE(V) THEN OTHER(PED(V),F)
02200 ELSE OTHER(PED(V),QFACE(U)));⊃;
02300 END "OKSURV";
02400
02500 α GET AN UNBLESSED SURV OF A BODY OR RETURN ZERO;
02600 ISUBR GETSURV (ITG B);
02700 BEGIN "GETSURV"
02800 ITG V;
02900 β OUTSTR("GETSURV ");
03000 V←B;
03100 WHILE VTYPE(V←PVT(V)) DO
03200 IF SUR(V)∧ ¬OK(V) THEN RETURN(V);
03300 RETURN(0);
03400 END "GETSURV";
00100 α DETECT A ONE-FACE HOLE;
00200 BOOLEAN SUBR HOLEDETECTOR (ITG V);
00300 BEGIN "HOLEDETECTOR"
00400 XISUBR PYRAMID (ITG F);
00500 REAL X,Y,Z,ANGLE;
00600 ITG V0,U,F,QF,N;
00700 V0←V;
00800 α FIRST TIME AROUND - LOOK FOR DIFFERENT Q-FACES;
00900 F ← PFACE(PED(V));
01000 QF← QFACE(V);
01100 β !;β DPYF(QF);β DPYV(V);β OSTR("HOLE DETECTOR");
01200 DO BEGIN
01300 U←V; V←OTHERV(F,U);
01400 IF QFACE(V)≠QF THEN RETURN(FALSE);
01500 F ← OTHER(PED(V),F);
01600 END UNTIL (V=V0);
01700
01800 α SECOND TIME AROUND - TAKE SUM OF INTERIOR SOLID ANGLES;
01900 F ← PFACE(PED(V));
02000 ANGLE←X←Y←Z←0; N←0;
02100 DO BEGIN
02200 V ← OTHERV(F,V);
02300 F ← OTHER(PED(V),F);
02400 X←X+XWC(V); Y←Y+YWC(V); Z←Z+ZWC(V); INCREM(N);
02500 ANGLE ← ANGLE + ANGLSI(V);
02600 END UNTIL (V=V0);
02700
02800 α DISTINGUISH SOLID HOLES FROM EMPTY HOLES;
02900 IF ABS((N-2)*π - ANGLE) ≤ 0.001 THEN RETURN(FALSE);
03000 U ← PYRAMID(QF);
03100 XWC(U)←X/N; YWC(U)←Y/N; ZWC(U)←Z/N;
03200
03300 β DPYSUB(0);β !;β DPYV(U);β OSTR("PYRAMID");
03400 RETURN(TRUE);
03500 END "HOLEDETECTOR";
00100 α PYRAMID A FACE THAT WOULD HAVE HAD A HOLE;
00200 BOOLEAN SUBR MKHOLE (ITG B1,B2);
00300 BEGIN "MKHOLE"
00400 ITG V;
00500 LABEL L;
00600 β OUTSTR("MKHOLE ");
00700 L: V ← GETSURV(B1);
00800 IF V=0 THEN
00900 V ← GETSURV(B2);
01000 IF V=0 THEN RETURN(FALSE); α AIN`T NO FACE HOLE;
01100
01200 IF HOLEDETECTOR(V) THEN
01300 ⊂ KLSURV(B1); KLSURV(B2); RETURN(TRUE); ⊃;
01400
01500 OKSURV(V); GO L;
01600 END "MKHOLE";
00100 α BODY INTERSECTION - OCTOBER 1972;
00200 INTERNAL ISUBR BIN (ITG B1,B2);
00300 BEGIN "BIN"
00400 LABEL L;
00500 ITG B,B0,F,E,V;
00600
00700 α INITIALIZATION;
00800 IF BTYPE(B1)∧BTYPE(B2) THEN ELSE RETURN(B1);
00900 L: FACOEF(B1,0);FACOEF(B2,0);B0←WORLD;
01000 β OSTR("BIN ENTRY");
01010 V←B1; WHILE VTYPE(V←PVT(V)) DO ZPP(V)←0;
01020 V←B2; WHILE VTYPE(V←PVT(V)) DO ZPP(V)←0;
01030
01100
01200 α COMPARE ONE'S EDGES WITH THE OTHER'S FACES;
01300
01400 E←B1; WHILE ETYPE(E←PED(E)) DO ⊂
01500 F←B2; WHILE FTYPE(F←PFACE(F)) DO COMPFE(F,E);⊃;
01600
01700 E←B2; WHILE ETYPE(E←PED(E)) DO ⊂
01800 F←B1; WHILE FTYPE(F←PFACE(F)) DO COMPFE(F,E);⊃;
01900
02000 α PYRAMID FACES THAT WOULD HAVE HOLES - AND BACKTRACK;
02100 IF MKHOLE(B1,B2) THEN GO L;
02200
02300 α FIND A SURV THAT HAS NO ALTERNATE & AND CALL MKBIN;
02400
02500 V←B1; WHILE VTYPE(V←NVT(V)) DO
02600 IF SUR(V)∧ALT(V)=0 THEN
02700 ⊂ B←MKBIN(V);ATTACH(B,B0);B0←B;V←B1;
02800 E←B;WHILE ETYPE(E←PED(E)) DO ALT.(0,E);⊃;
02900
03000 V←B2; WHILE VTYPE(V←NVT(V)) DO
03100 IF SUR(V)∧ALT(V)=0 THEN
03200 ⊂ B←MKBIN(V);ATTACH(B,B0);B0←B;V←B2;
03300 E←B;WHILE ETYPE(E←PED(E)) DO ALT.(0,E);⊃;
03400
03500 α ZERO ALL THE ALT LINKS;
03600 E←B1;WHILE ETYPE(E←PED(E)) DO ALT.(0,E);KLBFEV(B1);
03700 E←B2;WHILE ETYPE(E←PED(E)) DO ALT.(0,E);KLBFEV(B2);
03800 β !;β OSTR("BIN EXIT");
03900 RETURN(B0);OUTSTR(↓&"*");
04000 END "BIN";
04100
04200 INTERNAL ISUBR BUN (ITG B1,B2);
04300 ⊂ ITG B;EVERT(B1);EVERT(B2);B←BIN(B1,B2);EVERT(B);
04400 RETURN(B);⊃;
04500 INTERNAL ISUBR BSUB(ITG B1,B2);
04600 ⊂ ITG B;EVERT(B2);B←BIN(B1,B2);RETURN(B);⊃;
04700
04800 END "BIN";