perm filename PASH.SAI[NM,BGB] blob
sn#079656 filedate 1973-12-31 generic text, type T, neo UTF8
00100 BEGIN "PASH"
00200
00250 REQUIRE "DPYSUB.HDR[1,PDQ]" SOURCE!FILE;
00275 REQUIRE "BAYSAI.SAI" SOURCE!FILE;
00300 COMMENT DEFINE THRU="STEP 1 UNTIL";
00400 INTEGER I,J,K,L,M,N,NR,BC,NI,NJ,NL,BZ,Z,CHAN,FLAG,NU,NV,BU,BV,II,JJ,NT,
00500 NK,IPRIO,COLOR,ASIZE,POWER,INSIDE,HOLE,LP,LL,ZZ,IN,JN,ZZZ,DAM,RES,
00600 DI,IK,IZ,COLA,COLB,NSK;
00700 STRING SOURCE,SAVE,RESULT,ST,FILE;
00800 REAL AU,AV,V,ROT,DD,DOTT,SV,CV,DQ,DR,PI,RX,RZ,COSA,COSB,SINA,SINB,ACS,
00900 UA,VA,UB,VB,UC,VE,UD,VD,SU,TU,TV,DIFF,DOFF,FF,GG,DS,DW,DZ,DF,FL,FK,
01000 GU,GV,GZ,HZ,U1,W1,U2,W2,DDU,DDV;
01100 SAFE REAL ARRAY P[0:32,1:4,1:3],F[1:32],G[1:32],A[1:3],B[1:3],T[1:3],
01200 PP[0:32,1:4,1:3],QZ[1:3,1:3],TS[1:41,1:41],INF[1:4,1:3],H[1:81,1:8];
01300 SAFE INTEGER ARRAY SI[1:32],SJ[1:32],SL[1:32],MM[1:30],JK[1:4];
01400 REAL ARRAY EDGU[1:9],PQ[1:4,1:5],PR[1:4,1:5],PS[1:4,1:3],
01500 POLV[1:6,1:3];
01550 INTEGER ARRAY DPYBUF[0:3500];
01600 INTERNAL REAL MAG,MAF;
01700 EXTERNAL INTEGER XBITS,XESTRT;
01800 EXTERNAL REAL ACADEMY;
01900 INTERNAL INTEGER KU,KV,KIF;
02000 LABEL START,NEW!I,NEW!J,NEW!K,BAD,FIT,ARRANGE,MISTAKE;
02100 FORTRAN REAL PROCEDURE SIN(REAL V);
02200 FORTRAN REAL PROCEDURE COS(REAL V);
02300 FORTRAN REAL PROCEDURE ACOS(REAL V);
02400 REQUIRE "DATA1.SAI" SOURCE!FILE;
02500 SAFE REAL ARRAY VC[1:41,1:41,1:3],C[1:3],D[1:3],E[1:3],
02600 DU[1:41,1:41,1:3],DV[1:41,1:41,1:3],CUV[1:41,1:41,1:3],
02700 S[1:41,1:41],CUTU[1:41,1:41],V1[1:3],V2[1:3],R[1:4,1:4,1:3],
02800 CUTV[1:41,1:41],Q[1:4,1:4,1:3],HH[1:81,1:8],FACT[1:5],VIEW[1:3];
02900 REAL U,AA,BB,AC,AD,DM;
03000 PRELOAD!WITH 4,2,2,1,1,2,2,4,4,1,1,2,1,1,
03100 3,3,2,2,1,1,4,4,3,3,2,2,1,1,4,4;
03200 SAFE INTEGER ARRAY HV[1:32];
03300 PRELOAD!WITH 1,4,4,3,3,3,3,2,2,4,4,3,3,3,
03400 2,2,3,3,4,4,1,1,2,2,3,3,4,4,1,1;
03500 SAFE INTEGER ARRAY HU[1:32];
03600 PRELOAD!WITH 1, 0,-3, 2,
03700 0, 0, 3,-2,
03800 0, 1,-2, 1,
03900 0, 0,-1, 1;
04000 OWN SAFE INTEGER ARRAY FM[1:4,1:4];
04100 PRELOAD!WITH 0,0,0, 0,0,0, 1,1,1, 0,1,1, 0,0,1,
04200 1,0,0, 0,1,0, 0,1,1, 1,0,1, 0,0,1;
04300 SAFE INTEGER ARRAY FU[1:10,0:2];
04400 PRELOAD!WITH 0,0,0, 1,1,2, 0,1,2, 0,0,1, 1,0,0,
04500 0,1,0, 0,1,2, 1,0,2, 0,0,1, 0,1,0;
04600 SAFE INTEGER ARRAY FV[1:10,0:2];
04700 FORWARD PROCEDURE POINT(REAL U,V; REFERENCE SAFE REAL ARRAY C;INTEGER F,G);
04800 FORWARD PROCEDURE COT(REAL UA,UB,VA,VB; REFERENCE REAL U,V;REAL FL);
04900 FORWARD PROCEDURE DRAW(SAFE REAL ARRAY V1,V2);
05000 FORWARD PROCEDURE ARMIT;
05100 EXTERNAL PROCEDURE SND(SAFE REAL ARRAY A; INTEGER N,ASIZE,IPRIO,
05200 COLOR,POWER,INSIDE,HOLE; REAL DIFFUSE,FIELDOFVIEW,D,F);
05300 EXTERNAL PROCEDURE SINIT(INTEGER BC);
05400 EXTERNAL PROCEDURE INTFRM(REAL U,V,AV; INTEGER I,J,K,L,M; REAL UA,UB);
05500 EXTERNAL PROCEDURE DISPLAY(INTEGER MODE);
05600 EXTERNAL PROCEDURE ENDBUFF;
05700 EXTERNAL PROCEDURE SHUTTER;
05800
05900 PROCEDURE SOND(SAFE REAL ARRAY A; INTEGER NN, ASIZE, IPRIO, COLOR,
06000 POWER,INSIDE,HOLE; REAL DIFFUSE,FIELDOFVIEW,D,F);
06100 BEGIN OWN INTEGER I,J;
06200 FOR I←1 THRU NN DO BEGIN "DR"
06300 FOR J←1 THRU 3 DO
06400 V1[J]←A[I,J];
06500 IF I=NN THEN K←1 ELSE K←I+1;
06600 FOR J←1 THRU 3 DO
06700 V2[J]←A[K,J];
06800 COMMENT OUTSTR(CVF(V1[1])&CVF(V1[2])&CVF(V1[3])&CRLF);
06900 DRAW(V1,V2);
07100 END "DR";
07200 IF JK[2]>0 THEN OUT(0,CRLF);
07300 END;
07400
07500 INTEGER PROCEDURE FUNCT(REAL UA,UB);
07600 BEGIN REAL FUN;
07700 FUN←UA*180/(3.1416*10);
07800 RETURN(FUN);
07900 END;
08000
08100 SIMPLE PROCEDURE GET; BEGIN U←(I-1)/NU; V←(J-1)/NV; END;
00100 REAL PROCEDURE VICT(REAL U,V);
00200 BEGIN "VICT"
00300 POINT(U,V,C,0,0);
00400 DD←AC;
00500 FOR K←1 THRU 3 DO
00600 DD←DD+T[K]*C[K];
00700 RETURN(DD);
00800 END "VICT";
00900
01000 REAL PROCEDURE VOCT(REAL U,V);
01100 BEGIN "VOCT"
01200 POINT(U,V,C,0,0);
01300 POINT(U,V,D,1,0);
01400 POINT(U,V,E,0,1);
01500 B[3]←D[1]*E[2]-D[2]*E[1];
01600 B[2]←D[3]*E[1]-D[1]*E[3];
01700 B[1]←D[2]*E[3]-D[3]*E[2];
01800 DD←0;
01900 DR←0;
02000 DS←0;
02100 FOR K←1 THRU 3 DO BEGIN
02200 DS←DS+B[K]*B[K];
02300 DR←DR+(C[K]-VIEW[K])↑2;
02400 DD←DD+B[K]*(C[K]-VIEW[K]); END;
02500 DQ←DD/(DR*DS)↑.5;
02600 RETURN(DQ);
02700 END "VOCT";
02800
02900 PROCEDURE CIT(REAL UA,UB,VA,VB; REFERENCE REAL U,V);
03000 BEGIN
03100 REAL XR,XL,VAL,UL,UR,VL,VR;
03200 OWN INTEGER I;
03300 UL←UA;
03400 UR←UB;
03500 VL←VA;
03600 VR←VB;
03700 XL←VICT(UL,VL);
03800 XR←VICT(UR,VR);
03900 FOR I←1 THRU P[32,4,2] DO
04000 BEGIN "REFINE"
04100 COMMENT OUTSTR(CVF(U)&CVF(V)&CRLF);
04200 U←(UL+UR)/2;
04300 V←(VL+VR)/2;
04400 VAL←VICT(U,V);
04500 IF VAL*XL>0 THEN BEGIN
04600 XL←VAL;
04700 UL←U;
04800 VL←V; END ELSE BEGIN
04900 XR←VAL;
05000 UR←U;
05100 VR←V; END;
05200 END "REFINE";
05300 END;
05400
00100 PROCEDURE SEND(SAFE REAL ARRAY A;INTEGER NN; REAL DIFF);
00200 BEGIN "SEND"
00300 OWN SAFE REAL ARRAY HN[1:81,1:8];
00400 OWN INTEGER I,J,K,L,M,N,MM,NT;
00500 OWN SAFE REAL ARRAY JNF[1:4,1:3];
00600 LABEL ENDSEND;
00700 IF P[31,1,1]>0 THEN OUT(0,CRLF& "SEND"&CVS(IN)&CVS(JN)&CRLF);
00800 FLAG←0;
00900 BC←0;
01000 L←0;
01100 ARRTRAN(HN,A);
01200 FOR I←1 THRU 7 DO A[NN+1,I]←A[1,I];
01300 FOR I←1 THRU NN+1 DO BEGIN "FIRST"
01400 AD←AC;
01500 FOR K←1 THRU 3 DO AD←AD+A[I,K]*T[K];
01600 IF AD≥0 THEN FLAG←1;
01700 IF AD<0 THEN BC←1;
01800 A[I,8]←AD;
01900 IF I>1 AND AD*A[I-1,8]<0 THEN BEGIN
02000 L←L+1;
02100 JNF[L,1]←I;
02200 UA←A[I-1,6];
02300 UB←A[I,6];
02400 VA←A[I-1,7];
02500 VB←A[I,7];
02600 CIT(UA,UB,VA,VB,U,V);
02700 JNF[L,2]←U;
02800 JNF[L,3]←V;
02900 END;
03000 COMMENT IF P[31,1,2]>0 THEN OUT(0,CVF(AD)&CVS(I)&CVS(L)&CVS(BC)&CVS(FLAG)&
03100 CVS(JNF[L,1])&CVS(JNF[L,2])&CVS(JNF[L,3])&CRLF);
03200 END "FIRST";
03300 IF P[31,1,3]>0 THEN BEGIN
03400 OUT(0,CRLF);
03500 FOR I←1 THRU NN DO BEGIN
03600 FOR J←1 THRU 8 DO
03700 OUT(0,CVF(A[I,J]));
03800 OUT(0,CRLF); END;
03900 OUT(0,CRLF); END;
04000 IF FLAG=0 THEN GO TO ENDSEND;
04100 IF BC=0 THEN BEGIN
04200 SOND(HN,NN,ASIZE,IPRIO,COLOR,POWER,0,0,DIFF,DW,DZ,DF);
04300 IF P[31,2,1]>0 THEN BEGIN
04400 FOR MM←1 THRU NN DO BEGIN
04500 HN[MM,1]←(MAF*MAG*(HN[MM,1]-VIEW[1]));
04600 HN[MM,2]←(MAF*MAG*(HN[MM,2]-VIEW[2]));
04700 HN[MM,3]←(-HN[MM,3]+VIEW[3]);
04800 IF P[31,1,1]>0 THEN FOR K←1 THRU 7 DO OUT(0,CVF(HN[MM,K]));
04900 IF P[31,1,1]>0 THEN OUT(0,CRLF); END;
05000 SND(HN,NN,ASIZE,IPRIO,COLOR,POWER,0,0,DIFF,DW,DZ,DF);
05100 IF P[31,1,1]>0 THEN OUT(0," WHOLE"&CRLF);
05200 IF P[31,1,3]>0 THEN FOR I←1 THRU NN+3 DO BEGIN
05300 FOR K←1 THRU 5 DO OUT(0,CVF(HN[I,K]));
05400 OUT(0,CRLF); END;
05500 END;
05600 GO TO ENDSEND;
05700 END;
05800 IF L=1 THEN BEGIN OUTSTR("LL=1");
05900 IF P[31,1,1]>0 THEN OUT(0,"LL = 1"&CRLF);
06000 GO TO ENDSEND; END;
06100 IF L>2 THEN BEGIN OUTSTR("LL="&CVS(L));
06200 IF P[31,1,1]>0 THEN OUT(0,"LL ="&CVS(L)&CRLF); END;
06300 UC←JNF[1,2];
06400 VE←JNF[1,3];
06500 UD←JNF[2,2];
06600 VD←JNF[2,3];
06700 SU←UD-UC;
06800 SV←VD-VE;
06900 FF←0;
07000 GG←0;
07100 IF ABS(SU)>ABS(SV) THEN FF←1 ELSE GG←1;
07200 POINT(UC,VE,C,FF,GG);
07300 POINT(UD,VD,D,FF,GG);
07400 POINT(UC,VE,E,0,0);
07500 POINT(UD,VD,B,0,0);
07600 DD←0;
07700 DQ←0;
07800 DR←0;
07900 DS←0;
08000 FOR K←1 THRU 3 DO BEGIN
08100 C[K]←C[K]*(1-T[K]);
08200 D[K]←D[K]*(1-T[K]);
08300 DD←DD+C[K]*D[K];
08400 DQ←DQ+C[K]*C[K];
08500 DR←DR+D[K]*D[K];
08600 DS←DS+(E[K]-B[K])↑2;
08700 END;
08800 NT←P[31,2,3];
08900 AD←DD/(DQ*DR)↑.5;
09000 COMMENT SETFORMAT(10,5);
09100 COMMENT OUTSTR("AD="&CVF(AD)&CVF(DD)&CVF(DQ)&CVF(DR)&CRLF);
09200 IF ABS(AD)≤1 THEN ACS←ACOS(AD) ELSE ACS←0;
09300 NT←FUNCT(ACS,DS↑.5);
09400 N←NT+2;
09500 FOR K←1 THRU 3 DO BEGIN
09600 HN[1,K]←E[K];
09700 HN[N,K]←B[K]; END;
09800 HN[1,4]←1;
09900 HN[N,4]←1;
10000 HN[1,5]←VOCT(UC,VE);
10100 HN[N,5]←VOCT(UD,VD);
10200 HN[1,6]←UC;
10300 HN[1,7]←VE;
10400 HN[N,6]←UD;
10500 HN[N,7]←VD;
10600 DS←SIN(ACS)*FK;
10700 UA←UC-DS*SV;
10800 UB←UC+DS*SV;
10900 VA←VE+DS*SU;
11000 VB←VE-DS*SU;
11100 TU←SU/(NT+1);
11200 TV←SV/(NT+1);
11300 IF P[31,1,2]>0 AND P[31,1,1]>0 THEN
11400 OUT(0,CRLF&CVS(IN)&CVF(UA)&CVF(UB)&CVF(VA)&CVF(VB)
11500 &CVF(TU)&CVF(TV)&CRLF&CRLF);
11600 FOR M←1 THRU NT+2 DO
11700 BEGIN "EXTRA"
11800 CIT(UA,UB,VA,VB,U,V);
11900 IF P[31,1,2]>0 AND P[31,1,1]>0 THEN
12000 OUT(0,CVS(M)&CVF(UA)&CVF(UB)&CVF(VA)&CVF(VB)
12100 &CVF(U)&CVF(V)&CRLF);
12200 POINT(U,V,C,0,0);
12300 FOR K←1 THRU 3 DO
12400 HN[M,K]←C[K];
12500 HN[M,4]←1;
12600 HN[M,5]←VOCT(U,V);
12700 IF HN[M,5]<0 THEN HN[M,5]←HN[M,5]*.5;
12800 HN[M,6]←U;
12900 HN[M,7]←V;
13000 UA←UA+TU;
13100 UB←UB+TU;
13200 VA←VA+TV;
13300 VB←VB+TV;
13400 END "EXTRA";
13500 M←JNF[2,1]; MM←JNF[1,1];
13600 IF A[M,8]>0 THEN DM←1 ELSE BEGIN
13700 DM←-1; M←M-1; MM←MM-1; IF P[31,1,1]>0 THEN OUT(0," DM=-1"&CRLF);
13800 END;
13900 WHILE M ≠ MM DO BEGIN "SCIZ"
14000 N←N+1;
14100 FOR K←1 THRU 7 DO HN[N,K]←A[M,K];
14200 M←M+DM;
14300 IF M>NN THEN M←M-NN;
14400 IF M<1 THEN M←M+NN;
14500 END "SCIZ";
14600 IF P[31,1,1] >0 THEN BEGIN "OUT"
14700 OUT(0," "&CVS(IN)&CVS(JN)&CRLF);
14800 FOR I←1 THRU N DO BEGIN
14900 FOR K←1 THRU 7 DO OUT(0,CVF(HN[I,K]));
15000 OUT(0,CRLF); END;
15100 OUT(0,CRLF);
15200 IF P[31,2,1]>0 THEN OUT(0,"SND"&CRLF&CRLF);
15300 END "OUT";
15400 SOND(HN,N,ASIZE,IPRIO,COLOR,POWER,0,0,DIFF,DW,DZ,DF);
15500 IF P[31,2,1]>0 THEN BEGIN
15600 FOR MM←1 THRU N DO BEGIN
15700 HN[MM,1]←(MAF*MAG*(HN[MM,1]-VIEW[1]));
15800 HN[MM,2]←(MAF*MAG*(HN[MM,2]-VIEW[2]));
15900 HN[MM,3]←(-HN[MM,3]+VIEW[3]);
16000 IF P[31,1,1]>0 THEN FOR K←1 THRU 7 DO OUT(0,CVF(HN[MM,K]));
16100 IF P[31,1,1]>0 THEN OUT(0,CRLF); END;
16200 SND(HN,N,ASIZE,IPRIO,COLOR,POWER,0,0,DIFF,DW,DZ,DF);
16300 IF P[31,1,3]>0 THEN FOR I←1 THRU N+3 DO BEGIN
16400 FOR K←1 THRU 5 DO OUT(0,CVF(HN[I,K]));
16500 OUT(0,CRLF); END;
16600 IF P[31,1,1]>0 THEN OUT(0," AFTER"&CRLF);
16700 END;
16800 ENDSEND: END "SEND";
00100 PROCEDURE CATMULL(INTEGER I,J);
00200 BEGIN "CAT"
00300 IN←I; JN←J;
00400 IF L>2 THEN OUTSTR("L>2");
00500 IF P[31,1,1]>0 AND L>2 THEN OUT(0,"L ="&CVS(L)&CRLF);
00600 IF L=1 THEN OUTSTR("L=1");
00700 IF P[31,1,1]>0 AND L=1 THEN OUT(0,"L = 1"&CRLF);
00800 IF L=0 THEN BEGIN
00900 N←3+BZ;
01000 FOR M←1 THRU N DO BEGIN
01100 II←I+FU[M,BZ]*DI;
01200 JJ←J+FV[M,BZ];
01300 FOR K←1 THRU 3 DO HH[M,K]←VC[II,JJ,K];
01400 BC←1; SETFORMAT(7,2);
01500 IF JK[2]>0 THEN OUT(0,CVS(I)&CVS(J)&CVS(II)&CVS(JJ)&CVS(M)&CVS(FU[M,BZ])&
01600 CVS(FV[M,BZ])&CVS(BZ)); IF JK[2]>0 THEN OUT(0,CRLF);
01700 HH[M,4]←1;
01800 DD←TS[II,JJ];
01900 IF DD<0 THEN DD←.5*DD;
02000 HH[M,5]←DD;
02100 HH[M,6]←(II-1)/NU;
02200 HH[M,7]←(JJ-1)/NV;
02300 END;
02400 DIFF←DOFF;
02500 COLOR←COLA;
02600 IF TS[I,J]<0 THEN BEGIN
02700 DIFF←.5*DIFF;
02800 COLOR←COLB; END;
02900 IF P[31,1,1]>0 THEN FOR M←1 THRU N DO BEGIN
03000 FOR K←1 THRU 7 DO OUT(0,CVF(HH[M,K]));
03100 OUT(0," NO CORNERS"&CRLF); END;
03200 SEND(HH,N,DIFF);
03300 END ELSE BEGIN "CATM"
03400 UC←INF[1,2];
03500 VE←INF[1,3];
03600 UD←INF[2,2];
03700 VD←INF[2,3];
03800 SU←UD-UC;
03900 SV←VD-VE;
04000 FF←0;
04100 GG←0;
04200 IF ABS(SU)>ABS(SV) THEN FF←1 ELSE GG←1;
04300 POINT(UC,VE,C,FF,GG);
04400 POINT(UD,VD,D,FF,GG);
04500 POINT(UC,VE,A,0,0);
04600 POINT(UD,VD,B,0,0);
04700 DD←0;
04800 DQ←0;
04900 DR←0;
05000 DS←0;
05100 FOR K←1 THRU 3 DO BEGIN
05200 DD←DD+C[K]*D[K];
05300 DQ←DQ+C[K]*C[K];
05400 DR←DR+D[K]*D[K];
05500 DS←DS+(A[K]-B[K])↑2;
05600 END;
05700 IF JK[3]>0 THEN NT←FUNCT(ACOS(DD/(DQ*DR)↑.5),DS↑.5); NT←4;
05800 FOR K←1 THRU 3 DO BEGIN
05900 HH[1,K]←A[K];
06000 HH[NT+2,K]←B[K];
06100 END;
06200 FOR M←1 THRU NT+2 DO BEGIN
06300 HH[M,4]←1;
06400 IF P[31,1,1]>0 THEN OUT(0,CRLF&CVS(II)&CVS(JJ)&CRLF);
06500 HH[M,5]←0;
06600 END;
06700 HH[1,6]←UC;
06800 HH[1,7]←VE;
06900 HH[NT+2,6]←UD;
07000 HH[NT+2,7]←VD;
07100 IF ABS(SU) > ABS(SV) THEN BEGIN
07200 UA←UC;
07300 UB←UC;
07400 VA←(J-1.1)/NV; VB←J/NV;
07500 VB←(J+.1)/NV;
07600 TU←SU/(NT+1);
07700 TV←0;
07800 END ELSE BEGIN
07900 UA←(I-1.1)/NU;
08000 UB←(I+.1)/NU;
08100 VA←VE;
08200 VB←VE;
08300 TU←0; TV←SV/(NT+1);
08400 END;
08500 FOR M←1 THRU NT+2 DO
08600 BEGIN "EXTRA"
08700 IF M=1 OR M=NT+2 THEN FL←1 ELSE FL←0;
08800 COT(UA,UB,VA,VB,U,V,FL);
08900 POINT(U,V,A,0,0);
09000 FOR K←1 THRU 3 DO
09100 HH[M,K]←A[K];
09200 HH[M,4]←1;
09300 HH[M,5]←0;
09400 HH[M,6]←U;
09500 HH[M,7]←V;
09600 UA←UA+TU;
09700 UB←UB+TU;
09800 VA←VA+TV;
09900 VB←VB+TV;
10000 END "EXTRA";
10100 DIFF←DOFF;
10200 COLOR←COLA;
10300 NI←INF[2,1]-INF[1,1];
10400 N←NT+2+3+BZ-NI;
10500 NK←3+BZ-NI;
10600 FOR M←1 THRU NK DO BEGIN "CORNER"
10700 NL←INF[2,1]+M;
10800 Z←NT+2+M;
10900 II←I+FU[NL,BZ]*DI;
11000 JJ←J+FV[NL,BZ];
11100 FOR K←1 THRU 3 DO
11200 HH[Z,K]←VC[II,JJ,K];
11300 HH[Z,4]←1;
11400 HH[Z,5]←TS[II,JJ];
11500 HH[Z,6]←(II-1)/NU;
11600 HH[Z,7]←(JJ-1)/NV;
11700 IF HH[Z,5] < 0 THEN BEGIN
11800 HH[Z,5]←.5*HH[Z,5];
11900 DIFF←.5*DOFF;
12000 COLOR←COLB; END;
12100 END "CORNER";
12200 SETFORMAT(7,2);
12300 FOR M← 1 THRU N DO BEGIN
12400 FOR K←1 THRU 5 DO BEGIN
12500 COMMENT H[M,K]←HH[M,K]; IF JK[2]>0 THEN OUT(0,CVF(HH[M,K])); END;
12600 IF JK[2]>0 THEN OUT(0,CVF(HH[M,6])&CVF(HH[M,7])&" CORNER"&CRLF); END;
12700 SEND(HH,N,DIFF);
12800 DIFF←DOFF;
12900 COLOR←COLA;
13000 N←NT+2+NI;
13100 FOR M←1 THRU NI DO BEGIN "OTHER CORNER"
13200 NL←INF[2,1]+1-M;
13300 Z←NT+2+M;
13400 II←I+FU[NL,BZ]*DI;
13500 JJ←J+FV[NL,BZ];
13600 FOR K←1 THRU 3 DO
13700 HH[Z,K]←VC[II,JJ,K];
13800 HH[Z,4]←1;
13900 HH[Z,5]←TS[II,JJ];
14000 HH[Z,6]←(II-1)/NU;
14100 HH[Z,7]←(JJ-1)/NV;
14200 IF HH[Z,5] < 0 THEN BEGIN
14300 HH[Z,5]←.5*HH[Z,5];
14400 DIFF←.5*DOFF;
14500 COLOR←COLB; END;
14600 END "OTHER CORNER";
14700 IF JK[2]>0 THEN BEGIN
14800 OUT(0,CRLF);
14900 FOR M←1 THRU N DO BEGIN
15000 FOR K←1 THRU 7 DO OUT(0,CVF(HH[M,K]));
15100 OUT(0," OTHER CORNER"&CRLF);END;
15200 OUT(0,CRLF); END;
15300 COMMENT FOR M← 1 THRU N DO
15400 FOR K←1 THRU 5 DO
15500 H[M,K]←HH[M,K];
15600 SEND(HH,N,DIFF);
15700 END "CATM";
15800 END "CAT";
15900
16000 PROCEDURE SQUARE(INTEGER I,J);
16100 BEGIN "SQUARE(I,J)"
16200 L←0;
16300 IF CUTV[I,J] > 0 THEN BEGIN
16400 L←L+1;
16500 INF[L,1]←1;
16600 INF[L,2]←(I-1)/NU;
16700 INF[L,3]←CUTV[I,J];
16800 END;
16900 IF CUTU[I,J+1] > 0 THEN BEGIN
17000 L←L+1;
17100 INF[L,1]←2;
17200 INF[L,2]←CUTU[I,J+1];
17300 INF[L,3]←J/NV;
17400 END;
17500 IF CUTV[I+1,J]>0 THEN BEGIN
17600 L←L+1;
17700 INF[L,1]←3;
17800 INF[L,2]←I/NU;
17900 INF[L,3]←CUTV[I+1,J];
18000 END;
18100 IF CUTU[I,J]>0 THEN BEGIN
18200 L←L+1;
18300 INF[L,1]←4;
18400 INF[L,2]←CUTU[I,J];
18500 INF[L,3]←(J-1)/NV;
18600 END;
18700 BZ←1;
18800 CATMULL(I,J);
18900 END "SQUARE(I,J)";
19000
19100 PROCEDURE PENTAGON(INTEGER I,J);
19200 BEGIN "PENTA"
19300 L←0;
19400 IK←I+DI;
19500 IF DI>0 THEN II←I ELSE II←I-1;
19600 IF CUTV[I,J]>0 AND CUTV[I,J+1]=0 THEN BEGIN
19700 L←L+1;
19800 INF[L,1]←1;
19900 INF[L,2]←(I-1)/NU;
20000 INF[L,3]←CUTV[I,J];
20100 END;
20200 IF CUTV[I,J+1]>0 AND CUTV[I,J]=0 THEN BEGIN
20300 L←L+1;
20400 INF[L,1]←1;
20500 INF[L,2]←(I-1)/NU;
20600 INF[L,3]←CUTV[I,J+1];
20700 END;
20800 IF CUTU[II,J+2]>0 THEN BEGIN
20900 L←L+1;
21000 INF[L,1]←2;
21100 INF[L,2]←CUTU[II,J+2];
21200 INF[L,3]←(J+1)/NV;
21300 END;
21400 IF CUTV[IK,J+1]>0 THEN BEGIN
21500 L←L+1;
21600 INF[L,1]←3;
21700 INF[L,2]←(IK-1)/NU;
21800 INF[L,3]←CUTV[IK,J+1];
21900 END;
22000 IF CUTV[IK,J]>0 THEN BEGIN
22100 L←L+1;
22200 INF[L,1]←4;
22300 INF[L,2]←(IK-1)/NU;
22400 INF[L,3]←CUTV[IK,J];
22500 END;
22600 IF CUTU[II,J]>0 THEN BEGIN
22700 L←L+1;
22800 INF[L,1]←5;
22900 INF[L,2]←CUTU[II,J];
23000 INF[LL,3]←(J-1)/NV;
23100 END;
23200 BZ←2;
23300 CATMULL(I,J);
23400 END "PENTA";
23500
00100 PROCEDURE PU(REAL U);
00200 BEGIN
00300 OWN INTEGER I,J,K,L;
00400 OWN SAFE REAL ARRAY UQ[1:4],UR[1:4];
00500 UQ[1]←1; UR[1]←0; UQ[2]←U; UR[2]←1;
00600 FOR I←3 THRU 4 DO BEGIN
00700 UQ[I]←U↑(I-1);
00800 UR[I]←(I-1)*U↑(I-2);
00900 END;
01000
01100 FOR J←1 THRU 4 DO
01200 FOR K←1 THRU 3 DO BEGIN
01300 PQ[J,K]←0;
01400 PR[J,K]←0;
01500 FOR I←1 THRU 4 DO BEGIN
01600 PQ[J,K]←PQ[J,K]+Q[I,J,K]*UQ[I];
01700 PR[J,K]←PR[J,K]+Q[I,J,K]*UR[I];
01800 END;
01900 PS[J,K]←PR[J,K];
02000 IF J=1 THEN PS[J,K]←PS[J,K]-VIEW[K];
02100 END;
02200
02300 FOR K←1 THRU 2 DO
02400 FOR J←1 THRU 4 DO BEGIN
02500 PQ[J,K+3]←PQ[J,K];
02600 PR[J,K+3]←PR[J,K]; END;
02700
02800 FOR K←1 THRU 3 DO BEGIN
02900 FOR J←1 THRU 6 DO POLV[J,K]←0;
03000 FOR J←1 THRU 4 DO
03100 FOR L←1 THRU 3 DO
03200 POLV[J+L-1,K]←POLV[J+L-1,K]+PR[J,K+1]+PQ[L+1,K+2]*L
03300 -PR[J,K+2]*PQ[L+1,K+1]*L;
03400 END;
03500
03600 FOR J←1 THRU 9 DO
03700 EDGU[J]←0;
03800 FOR J←1 THRU 6 DO
03900 FOR L←1 THRU 4 DO
04000 FOR K←1 THRU 3 DO
04100 EDGU[J+L-1]←EDGU[J+L-1]+POLV[J,K]*PS[L,K];
04200 END;
04300
04400 REAL PROCEDURE DOT(REAL ARRAY V1,V2);
04500 BEGIN
04600 RETURN(V1[1]*V2[1]+V1[2]*V2[2]+V1[3]*V2[3]);
04700 END;
04800
04900 REAL PROCEDURE CURVE;
05000 BEGIN REAL A,B,CC,DD,EE,F,G,L,M,N,KU,SDS;
05100 OWN REAL ARRAY R11,R12,R22,R3[1:3];
05200 EE←DOT(D,D);
05300 F←DOT(D,E);
05400 G←DOT(E,E);
05500 POINT(U,V,R11,2,0);
05600 POINT(U,V,R12,1,1);
05700 POINT(U,V,R22,0,2);
05800 SDS←DS↑.5;
05900 FOR K←1 THRU 3 DO R3[K]←CUV[I,J,K]/SDS;
06000 L←DOT(R11,R3);
06100 M←DOT(R12,R3);
06200 N←DOT(R22,R3);
06300 A←EE*G-F*F;
06400 B←-(EE*N+G*L-2.*F*M);
06500 CC←L*N-M*M;
06600 DD←B*B-4.*A*CC;
06700 IF DD<0 THEN BEGIN OUTSTR("D<0"&CRLF); RETURN(0); END;
06800 IF B>0 THEN B←-B;
06900 KU←(-B+DD↑.5)/(2.*A);
07000 IF KU<0 THEN KU←-KU;
07100 COMMENT OUTSTR(CVS(I)&CVS(J)&CVG(KU)&CRLF);
07200 RETURN(KU);
07300 END;
07400
07500 REAL PROCEDURE KURV(REAL U,V);
07600 BEGIN
07700 REAL D,EE,F,G,L,M,N,KU,A,B,CC,DD;
07800 OWN REAL ARRAY R1,R2,R3,R11,R12,R22[1:3];
07900 POINT(U,V,R1,1,0);
08000 POINT(U,V,R2,0,1);
08100
08200 R3[1]←R1[2]*R2[3]-R1[3]*R2[2];
08300 R3[2]←R1[3]*R2[1]-R1[1]*R2[3];
08400 R3[3]←R1[1]*R2[2]-R1[2]*R2[1];
08500 D←(R3[1]*R3[1]+R3[2]*R3[2]+R3[3]*R3[3])↑.5;
08600 FOR K←1 THRU 3 DO R3[K]←R3[K]/D;
08700 EE←DOT(R1,R1);
08800 F←DOT(R2,R1);
08900 G←DOT(R2,R2);
09000 POINT(U,V,R11,2,0);
09100 POINT(U,V,R12,1,1);
09200 POINT(U,V,R22,0,2);
09300 L←DOT(R11,R3);
09400 M←DOT(R12,R3);
09500 N←DOT(R22,R3);
09600 A←EE*G-F*F;
09700 B←-(EE*N+G*L-2.*F*M);
09800 CC←L*N-M*M;
09900 DD←B*B-4.*A*CC;
10000 IF DD<0 THEN BEGIN OUTSTR("D<0"&CRLF); RETURN(0); END;
10100 IF B>0 THEN B←-B;
10200 KU←(-B+DD↑.5)/(2.*A);
10300 IF KU<0 THEN KU←-KU;
10400 COMMENT OUTSTR(CVS(I)&CVS(J)&CVG(KU)&CRLF);
10500 RETURN(KU);
10600 END;
10700
10800 PROCEDURE CALCOMP(STRING FILE; INTEGER ARRAY BUFR);
10900 Comment Outputs display buffer BUFR to disk file FILE in a format
11000 readable by the Nealy Calcomp plotter program PLTVEC, and by
11100 the Quam Video Synthesizer program MIRTOP;
11200 IF FILE THEN
11300 BEGIN INTEGER DSIZ,CCCHN;
11400 CCCHN←GETCHAN;
11500 OPEN(CCCHN,"DSK",'14,0,1,0,0,0);
11600 ENTER(CCCHN,FILE&".GRF",0);
11700 DPYPARS;DSIZ←BUFR[2]+4;
11800 ARRYOUT(CCCHN,BUFR[1],2);
11900 WORDOUT(CCCHN,0);
12000 ARRYOUT(CCCHN,BUFR[3],DSIZ-2);
12100 RELEASE(CCCHN);
12200 END "CALCOMP";
00100 PROCEDURE POINT(REAL U,V; REFERENCE SAFE REAL ARRAY C;INTEGER F,G);
00200 BEGIN OWN INTEGER I,J,K; OWN SAFE REAL ARRAY UP[1:4],VP[1:4];
00300 UP[1]←0.;VP[1]←0.;UP[2]←1.;VP[2]←1.;
00400 IF F=1 THEN FOR I←3 STEP 1 UNTIL 4 DO UP[I]←(I-1)*U↑(I-2)
00500 ELSE BEGIN IF F=0 THEN BEGIN
00600 UP[1]←1.;FOR I←2 STEP 1 UNTIL 4 DO UP[I]←U↑(I-1);END
00700 ELSE BEGIN UP[2]←0; UP[3]←2; UP[4]←6.*U; END; END;
00800 IF G=1 THEN FOR I←3 STEP 1 UNTIL 4 DO VP[I]←(I-1)*V↑(I-2)
00900 ELSE BEGIN IF G=0 THEN BEGIN
01000 VP[1]←1.;FOR I←2 STEP 1 UNTIL 4 DO VP[I]←V↑(I-1);END
01100 ELSE BEGIN VP[2]←0; VP[3]←2; VP[4]←6.*V; END; END;
01200 FOR K←1 STEP 1 UNTIL 3 DO BEGIN
01300 C[K]←0.;
01400 FOR J←1 STEP 1 UNTIL 4 DO BEGIN
01500 DD←0.;
01600 FOR I←1 STEP 1 UNTIL 4 DO
01700 DD←DD+Q[I,J,K]*UP[I] ;
01800 C[K]←C[K]+DD*VP[J] END; END;
01900 END;
02000
02100 PROCEDURE MULT;
02200 BEGIN INTEGER I,J,K,M,N;
02300 FOR K←1 STEP 1 UNTIL 3 DO
02400 FOR I←1 STEP 1 UNTIL 4 DO
02500 FOR J←1 STEP 1 UNTIL 4 DO
02600 BEGIN Q[I,J,K]←0.;
02700 FOR M←1 STEP 1 UNTIL 4 DO
02800 FOR N←1 STEP 1 UNTIL 4 DO
02900 Q[I,J,K]←Q[I,J,K]+R[M,N,K]*FM[N,I]*FM[M,J] END;
03000 END;
03100
03200 REAL PROCEDURE VECT(REAL U,V);
03300 BEGIN REAL VECT;
03400 OWN SAFE REAL ARRAY C[1:3],D[1:3],E[1:3];
03500 POINT(U,V,C,0,0);
03600 POINT(U,V,D,1,0);
03700 POINT(U,V,E,0,1);
03800 F[3]←D[1]*E[2]-D[2]*E[1];
03900 F[2]←D[3]*E[1]-D[1]*E[3];
04000 F[1]←D[2]*E[3]-D[3]*E[2];
04100 VECT←0.;
04200 FOR K←1 STEP 1 UNTIL 3 DO
04300 VECT←VECT+F[K]*(C[K]-VIEW[K]);
04400 RETURN(VECT);
04500 END;
04600
04700 PROCEDURE SEE(REAL U,V);
04800 BEGIN IF L>0 THEN
04900 BEGIN "1"
05000 POINT(U,V,V2,0,0);
05100 DRAW(V1,V2);
05200 L←0; COMMENT OUTSTR("SEE "&CVF(U)&CVF(V)&" "&CVS(I)&" "&CVS(J)&CRLF);
05300 END"1"
05400 ELSE BEGIN "2"
05500 POINT(U,V,V1,0,0);
05600 L←1; COMMENT OUTSTR("FIRST"&CVF(U)&CVF(V)&" "&CVS(I)&" "&CVS(J)&CRLF);
05700 END "2"
05800 END;
05900
06000 PROCEDURE DRAW(SAFE REAL ARRAY V1,V2);
06100 BEGIN
06200 INTEGER X1,X2,Y1,Y2,DX,DY;
06300 X1←-MAG*(V1[1]-VIEW[1])/(V1[3]-VIEW[3]);
06400 X2←-MAG*(V2[1]-VIEW[1])/(V2[3]-VIEW[3]);
06500 Y1←-MAG*(V1[2]-VIEW[2])/(V1[3]-VIEW[3]);
06600 Y2←-MAG*(V2[2]-VIEW[2])/(V2[3]-VIEW[3]);
06700 DX←X2-X1;
06800 DY←Y2-Y1;
06900 IF JK[4]>0 THEN INCHWL;
07000 AIVECT(X1,Y1);
07100 AVECT(X2,Y2);
07200 END;
07300
07400 PROCEDURE PATCH(INTEGER PNU,PNV);
07500 BEGIN
07600 LABEL OLD,ENDO;
07700 REAL X1,Y1,LED,DC,U3,W3;
07800 INTEGER LEI,LEJ,IC;
07900 MULT;
08000 IF P[30,2,2]>0 THEN ARMIT;
08100 LED←0;
08200 NU←PNU; NV←PNV; LP←P[32,4,2];
08300 IF (ZZZ=1 OR ZZZ=12) AND P[30,3,2]>0 THEN NV←NV*2;
08400 SETFORMAT(7,2); COMMENT OUTSTR("PATCH"&CRLF);
08500 BU←NU+1; BV←NV+1;
08600 SETFORMAT(11,3);
08700 FOR I←1 STEP 1 UNTIL BU DO BEGIN
08800 FOR J←1 STEP 1 UNTIL BV DO
08900 BEGIN
09000 GET;
09100 POINT(U,V,C,0,0);
09200 POINT(U,V,D,1,0);
09300 POINT(U,V,E,0,1);
09400 DQ←0;
09500 FOR K← 1 STEP 1 UNTIL 3 DO
09600 BEGIN
09700 VC[I,J,K]←C[K];
09800 DU[I,J,K]←D[K];
09900 DV[I,J,K]←E[K];
10000 DQ←DQ+D[K]*D[K];
10100 END;
10200 CUV[I,J,3]←D[1]*E[2]-D[2]*E[1];
10300 CUV[I,J,2]←D[3]*E[1]-D[1]*E[3];
10400 CUV[I,J,1]←D[2]*E[3]-D[3]*E[2];
10500 S[I,J]←0.; DS←0; DR←0;
10600 FOR K←1 STEP 1 UNTIL 3 DO BEGIN
10700 DS←DS+CUV[I,J,K]↑2;
10800 DR←DR+(C[K]-VIEW[K])↑2;
10900 S[I,J]←S[I,J]+CUV[I,J,K]*(C[K]-VIEW[K]);END;
11000 TS[I,J]←S[I,J]/(DR*DS)↑.5;
11100 DC←CURVE;
11200 IF P[31,1,1]>0 THEN OUT(0,CVF(DC));
11300 IF DC≥LED THEN BEGIN
11400 LED←DC; LEI←I; LEJ←J; END;
11500 END; IF P[31,1,1]>0 THEN OUT(0,CRLF); END;
11600 IF JK[2]>0 THEN OPEN(0,"LPT",0,0,2,0,0,0);
11700 I←LEI; J←LEJ; GET;
11800 POINT(U,V,C,0,0);
11900 IF P[30,2,1]>0 THEN BEGIN
12000 SETFORMAT(3,2);
12100 X1←-MAG*(C[1]-VIEW[1])/(C[3]-VIEW[3]);
12200 Y1←-MAG*(C[2]-VIEW[2])/(C[3]-VIEW[3]);
12300 AIVECT(X1,Y1);
12400 DPYSST(CVS(I)&CVS(J)&CVF(LED)); END;
12500 NSK←9;
12600 U1←(I-1)/NU;
12700 W1←(J-I)/NV;
12725 IF P[30,2,1]>0 THEN FOR IC←1 THRU P[30,2,1] DO BEGIN "KURV"
12800 IF U1<0 THEN U1←0;
12900 IF W1<0 THEN W1←0;
13000 U2←(I+1)/NU;
13100 W2←(J+1)/NV;
13200 IF W2>1 THEN W2←1;
13300 IF U2>1 THEN U2←1;
13400
13500 DDU←U2-U1;
13600 DDV←W2-W1;
13700 FOR N←0 THRU NSK DO
13800 FOR M←0 THRU NSK DO
13900 BEGIN
14000 U←U1+DDU*N/NSK;
14100 V←W1+DDV*M/NSK;
14200 DC←KURV(U,V);
14300 IF LED<DC THEN BEGIN LED←DC;
14350 U3←U;
14375 W3←V;
14387 END;
14400 END;
14500 DPYSST(CVF(LED));
14525 U1←U3-DDU/NSK;
14537 U2←U3+DDU/NSK;
14543 W1←W3-DDV/NSK;
14546 W2←W3+DDV/NSK;
14550 END "KURV";
14600 SETFORMAT(7,2);
14700 FOR I←1 STEP 1 UNTIL NU DO
14800 FOR J←1 STEP 1 UNTIL BV DO
14900 BEGIN "1"
15000 IF S[I+1,J]*S[I,J]<0 THEN
15100 BEGIN "2" REAL UL,UR,XL,XR,X,VAL;
15200 UL←S[I,J]; UR←S[I+1,J]; V←(J-1)/NV;
15300 XL←(I-1)/NU; XR←I/NU;
15400 FOR L←1 STEP 1 UNTIL LP DO
15500 BEGIN "3"
15600 X←(XL+XR)/2.;
15700 VAL←VECT(X,V);
15800 IF VAL*UL>0. THEN
15900 BEGIN "4"
16000 UL←VAL;
16100 XL←X;
16200 END "4"
16300 ELSE
16400 BEGIN "5"
16500 UR←VAL;
16600 XR←X;
16700 END "5";
16800 END "3";
16900 CUTU[I,J]←X;
17000 COMMENT OUTSTR(CVF(CUTU[I,J])&" "& CVS(I)&" "&CVS(J)&CRLF);
17100 END "2" ELSE CUTU[I,J]←0;
17200 END "1";
17300 COMMENT OUTSTR(CRLF);
17400 FOR I←1 STEP 1 UNTIL BV DO
17500 FOR J←1 STEP 1 UNTIL NV DO
17600 BEGIN "1"
17700 IF S[I,J+1]*S[I,J]<0 THEN
17800 BEGIN "2" REAL VL,VR,XL,XR,X,VAL;
17900 VL←S[I,J]; VR←S[I,J+1]; U←(I-1)/NU;
18000 XL←(J-1)/NV; XR←J/NV;
18100 FOR L←1 STEP 1 UNTIL LP DO
18200 BEGIN "3"
18300 X←(XL+XR)/2.;
18400 VAL←VECT(U,X);
18500 IF VAL*VL>0. THEN
18600 BEGIN "4"
18700 VL←VAL;
18800 XL←X;
18900 END "4"
19000 ELSE
19100 BEGIN "5"
19200 VR←VAL;
19300 XR←X;
19400 END "5";
19500 IF JK[2]>0 THEN OUT(0,CVF(X)&CRLF);
19600 END "3";
19700 CUTV[I,J]←X;
19800 IF JK[2]>0 THEN OUT(0,"CUTV"&CVF(CUTV[I,J])&" "&CVS(I)&" "&CVS(J)&CRLF);
19900 END "2" ELSE CUTV[I,J]←0;
20000 END "1";
20100 SETFORMAT(7,2);
20200 FOR J←1 THRU BV DO
20300 BEGIN "ROWS"
20400 FOR I←1 THRU BU DO BEGIN
20500 IF P[31,1,1]>0 THEN OUT(0,CVF(S[I,J])&CVF(CUTU[I,J]));
20600 COMMENT IF JK[2]>0 OR P[31,1,1]>0 THEN FOR K←1 THRU 3 DO OUT(0,CVF(VC[I,J,K]));
20700 COMMENT IF JK[2]>0 OR P[31,1,1]>0 THEN OUT(0, CRLF); END;
20800 IF JK[2]>0 OR P[31,1,1]>0 THEN OUT(0,CRLF);
20900 FOR I← 1 THRU BU DO
21000 IF P[31,1,1]>0 THEN OUT(0,CVF(CUTV[I,J])&" ");
21100 IF P[31,1,1]>0 THEN OUT(0,CRLF);
21200 END "ROWS";
21300 IF JK[2]>0 OR P[31,1,1]>0 THEN OUT(0,CRLF);
21400 SETFORMAT(0,7);
21500 IF P[32,3,2]>0 THEN BEGIN
21600 IF (ZZZ=1 OR ZZZ=12) AND P[30,3,2]>0 THEN BEGIN
21700 FOR J←1 THRU PNV DO BEGIN DI←1;
21800 PENTAGON(1,2*J-1); END;
21900 FOR I←2 THRU NU-1 DO
22000 FOR J←1 THRU NV DO BEGIN DI←1;
22100 SQUARE(I,J); END;
22200 FOR J←1 THRU PNV DO BEGIN DI←-1;
22300 PENTAGON(BU,2*J-1); END;
22400 END ELSE BEGIN DI←1;
22500 FOR I←1 THRU NU DO
22600 FOR J←1 THRU NV DO SQUARE(I,J); END;
22700 IF JK[2]>0 THEN CLOSE(0);
22800 GO TO ENDO; END;
22900
23000 OLD: FOR I←1 THRU NU DO
23100 FOR J←1 STEP KV UNTIL BV DO BEGIN
23200 FOR K←1 THRU 3 DO BEGIN
23300 D[K]←VC[I,J,K];
23400 E[K]←VC[I+1,J,K]; END;
23500 IF CUTU[I,J]>0 THEN
23600 BEGIN "1" GET;
23700 POINT(CUTU[I,J],V,C,0,0);
23800 DRAW(D,C);
23900 DRAW(C,E);
24000 END "1"
24100 ELSE DRAW(D,E); END;
24200 FOR I←1 STEP KU UNTIL BU DO
24300 FOR J←1 THRU NV DO BEGIN
24400 FOR K←1 THRU 3 DO
24500 BEGIN D[K]←VC[I,J,K];
24600 E[K]←VC[I,J+1,K] END;
24700 IF CUTV[I,J]>0 THEN
24800 BEGIN"1" GET;
24900 POINT(U,CUTV[I,J],C,0,0);
25000 DRAW(D,C);
25100 DRAW(C,E);
25200 END "1"
25300 ELSE DRAW(D,E); END;
25500 FOR I←1 THRU NU DO
25600 FOR J←1 THRU NV DO
25700 BEGIN "1" GET;
25800 L←0;
25900 IF CUTU[I,J]>0 THEN
26000 SEE(CUTU[I,J],V);
26100 IF CUTV[I,J]>0 THEN
26200 SEE(U,CUTV[I,J]);
26300 IF CUTU[I,J+1]>0 THEN
26400 SEE(CUTU[I,J+1],V+1./NV);
26500 IF CUTV[I+1,J]>0 THEN
26600 SEE(U+1./NU,CUTV[I+1,J]);
26700 END "1";
26800 IF KIF>0 THEN
26900 FOR I←1 STEP KU UNTIL BU DO
27000 FOR J←1 STEP KV UNTIL BV DO
27100 BEGIN "LABEL"
27200 U←-MAG*(VC[I,J,1]-VIEW[1])/(VC[I,J,3]-VIEW[3]);
27300 V←-MAG*(VC[I,J,2]-VIEW[2])/(VC[I,J,3]-VIEW[3]);
27400 AIVECT(U,V);
27500 DPYSST(CVS(I-1)&","&CVS(J-1)&CRLF);
27600 END "LABEL";
27700 ENDO: SETFORMAT(7,2); NV←PNV; END;
27800
27900 PROCEDURE COT(REAL UA,UB,VA,VB; REFERENCE REAL U,V;REAL FL);
28000 BEGIN
28100 REAL XR,XL,VAL,UL,UR,VL,VR;
28200 OWN INTEGER I;
28300 UL←UA;
28400 UR←UB;
28500 VL←VA;
28600 VR←VB;
28700 XL←VECT(UL,VL);
28800 XR←VECT(UR,VR);
28900 FOR I←1 THRU P[32,4,2] DO
29000 BEGIN "REFINE"
29100 COMMENT IF FL>0 AND P[31,1,1]>0 THEN OUT(0,CVS(I)&CVS(M)&CVF(U)&CVF(V)
29200 &CVF(UL)&CVF(UR)&CVF(VL)&CVF(VR)&CVF(VAL)&CVF(XL)&CVF(XR)&CRLF);
29300 U←(UL+UR)/2;
29400 V←(VL+VR)/2;
29500 VAL←VECT(U,V);
29600 IF VAL*XL>0 THEN BEGIN
29700 XL←VAL;
29800 UL←U;
29900 VL←V; END ELSE BEGIN
30000 XR←VAL;
30100 UR←U;
30200 VR←V; END;
30300 END "REFINE";
30400 END;
30500
30600 PROCEDURE POTCH(INTEGER PNU,PNV);
30700 BEGIN LABEL EEE, ENDO,OLD;
30800 LP←P[32,4,2];
30900 NU←PNU%2; NV←PNU%2;
31000 SETFORMAT(7,2); COMMENT OUTSTR("POTCH"&CRLF);
31100 BU←NU+1; BV←NV+1;
31200 FOR I←1 STEP 1 UNTIL BV DO
31300 FOR J←1 STEP 1 UNTIL BV+1-I DO
31400 BEGIN
31500 GET;
31600 POINT(U,V,C,0,0);
31700 POINT(U,V,D,1,0);
31800 POINT(U,V,E,0,1);
31900 FOR K← 1 STEP 1 UNTIL 3 DO
32000 BEGIN
32100 VC[I,J,K]←C[K];
32200 DU[I,J,K]←D[K];
32300 DV[I,J,K]←E[K];
32400 END;
32500 CUV[I,J,3]←D[1]*E[2]-D[2]*E[1];
32600 CUV[I,J,2]←D[3]*E[1]-D[1]*E[3];
32700 CUV[I,J,1]←D[2]*E[3]-D[3]*E[2];
32800 S[I,J]←0.; DS←0; DR←0;
32900 FOR K←1 STEP 1 UNTIL 3 DO BEGIN
33000 DS←DS+CUV[I,J,K]↑2;
33100 DR←DR+(C[K]-VIEW[K])↑2;
33200 S[I,J]←S[I,J]+CUV[I,J,K]*(C[K]-VIEW[K]);END;
33300 TS[I,J]←S[I,J]/(DR*DS)↑.5;
33400 END;
33500 COMMENT OUTSTR(CVE(VECT(.6,.5))&CRLF);
33600 FOR I←1 STEP 1 UNTIL NU DO
33700 FOR J←1 STEP 1 UNTIL BV DO
33800 BEGIN "1"
33900 IF S[I+1,J]*S[I,J]<0 THEN
34000 BEGIN "2" REAL UL,UR,XL,XR,X,VAL;
34100 UL←S[I,J]; UR←S[I+1,J]; V←(J-1)/NV;
34200 XL←(I-1)/NU; XR←I/NU;
34300 FOR L←1 STEP 1 UNTIL LP DO
34400 BEGIN "3"
34500 X←(XL+XR)/2.;
34600 VAL←VECT(X,V);
34700 IF VAL*UL>0. THEN
34800 BEGIN "4"
34900 UL←VAL;
35000 XL←X;
35100 END "4"
35200 ELSE
35300 BEGIN "5"
35400 UR←VAL;
35500 XR←X;
35600 END "5";
35700 END "3";
35800 CUTU[I,J]←X;
35900 COMMENT OUTSTR(CVF(CUTU[I,J])&" "& CVS(I)&" "&CVS(J)&CRLF);
36000 END "2" ELSE CUTU[I,J]←0;
36100 END "1";
36200 COMMENT OUTSTR(CRLF);
36300 FOR I←1 STEP 1 UNTIL BV DO
36400 FOR J←1 STEP 1 UNTIL NV DO
36500 BEGIN "1"
36600 IF S[I,J+1]*S[I,J]<0 THEN
36700 BEGIN "2" REAL VL,VR,XL,XR,X,VAL;
36800 VL←S[I,J]; VR←S[I,J+1]; U←(J-1)/NU;
36900 XL←(J-1)/NV; XR←J/NV;
37000 FOR L←1 STEP 1 UNTIL LP DO
37100 BEGIN "3"
37200 X←(XL+XR)/2.;
37300 VAL←VECT(U,X);
37400 IF VAL*VL>0. THEN
37500 BEGIN "4"
37600 VL←VAL;
37700 XL←X;
37800 END "4"
37900 ELSE
38000 BEGIN "5"
38100 VR←VAL;
38200 XR←X;
38300 END "5";
38400 END "3";
38500 CUTV[I,J]←X;
38600 COMMENT OUTSTR(CVF(CUTV[I,J])&" "&CVS(I)&" "&CVS(J)&CRLF);
38700 END "2" ELSE CUTV[I,J]←0;
38800 END "1";
38900 COMMENT OPEN(0,"LPT",0,0,2,0,0,0);
39000 SETFORMAT(7,2);
39100 FOR J←1 THRU BV DO
39200 BEGIN "ROWS"
39300 FOR I←1 THRU BU DO
39400 COMMENT OUTSTR(CVF(S[I,J])&CVF(CUTU[I,J]));
39500 COMMENT OUTSTR(CRLF);
39600 FOR I← 1 THRU BU DO
39700 COMMENT OUTSTR(CVF(CUTV[I,J])&" ");
39800 COMMENT OUTSTR(CRLF);
39900 END "ROWS";
40000 SETFORMAT(0,7);
40100 IF P[32,3,2]>0 THEN BEGIN
40200 FOR I←1 THRU NU DO BEGIN
40300 FOR J←1 THRU NV-I DO SQUARE(I,J);
40400 J←NV+1-I;
40500 L←0;
40600 IF CUTV[I,J]>0 THEN BEGIN
40700 L←L+1;
40800 INF[L,1]←1;
40900 INF[L,2]←(I-1)/NU;
41000 INF[L,3]←CUTV[I,J];
41100 END;
41200 IF S[I,J+1]*S[I+1,J]<0 THEN BEGIN
41300 L←L+1;
41400 INF[L,1]←2;
41500 COT((I-1)/NU,I/NU,J/NV,(J-1)/NV,U,V,0);
41600 INF[L,2]←U;
41700 INF[L,3]←V;
41800 END;
41900 IF CUTU[I,J]>0 THEN BEGIN
42000 L←L+1;
42100 INF[L,1]←3;
42200 INF[L,2]←CUTU[I,J];
42300 INF[L,3]←(J-1)/NV;
42400 END;
42500 IF P[31,1,1]>0 THEN OUT(0,"POTCH: L="&CVS(L)&
42600 CVS(INF[L,1])&CVF(INF[L,2])&CVF(INF[L,3])&CRLF);
42700 BZ←0;
42800 CATMULL(I,J);
42900 END;
43000 GO TO ENDO; END;
43100 OLD: FOR J←1 STEP KV UNTIL BV DO
43200 FOR I←1 THRU NU+1-J DO BEGIN
43300 FOR K←1 THRU 3 DO BEGIN
43400 D[K]←VC[I,J,K];
43500 E[K]←VC[I+1,J,K]; END;
43600 IF CUTU[I,J]>0 THEN
43700 BEGIN "1" GET;
43800 POINT(CUTU[I,J],V,C,0,0);
43900 DRAW(D,C);
44000 DRAW(C,E);
44100 END "1"
44200 ELSE DRAW(D,E); END;
44300 FOR I←1 STEP KU UNTIL BU DO
44400 FOR J←1 THRU NV+1-I DO BEGIN
44500 FOR K←1 THRU 3 DO
44600 BEGIN D[K]←VC[I,J,K];
44700 E[K]←VC[I,J+1,K] END;
44800 IF CUTV[I,J]>0 THEN
44900 BEGIN"1" GET;
45000 POINT(U,CUTV[I,J],C,0,0);
45100 DRAW(D,C);
45200 DRAW(C,E);
45300 END "1"
45400 ELSE DRAW(D,E); END;
45600 FOR I←1 THRU NU DO
45700 FOR J←1 THRU NV+1-I DO
45800 BEGIN "1" GET;
45900 L←0;
46000 IF CUTU[I,J]>0 THEN
46100 SEE(CUTU[I,J],V);
46200 IF CUTV[I,J]>0 THEN
46300 SEE(U,CUTV[I,J]);
46400 IF CUTU[I,J+1]>0 THEN
46500 SEE(CUTU[I,J+1],V+1./NV);
46600 IF CUTV[I+1,J]>0 THEN
46700 SEE(U+1./NU,CUTV[I+1,J]);
46800 END "1";
46900 IF KIF>0 THEN
47000 FOR I←1 STEP KU UNTIL BU DO
47100 FOR J←1 STEP KV UNTIL BV+1-I DO
47200 BEGIN "LABEL"
47300 U←-MAG*(VC[I,J,1]-VIEW[1])/(VC[I,J,3]-VIEW[3]);
47400 V←-MAG*(VC[I,J,2]-VIEW[2])/(VC[I,J,3]-VIEW[3]);
47500 AIVECT(U,V);
47600 DPYSST(CVS(I-1)&","&CVS(J-1)&CR);
47700 END "LABEL";
47800
47900 FOR I←1 THRU NV DO
48000 BEGIN "TRIANGLE"
48100 J←NV+1-I;
48200 FOR K←1 THRU 3 DO BEGIN
48300 D[K]←VC[I+1,J,K];
48400 E[K]←VC[I,J+1,K]; END;
48500 IF CUTU[I,J]>0 THEN BEGIN
48600 POINT(CUTU[I,J],(J-1)/NV,V1,0,0);
48700 IF CUTV[I,J]>0 THEN BEGIN
48800 POINT((I-1)/NV,CUTV[I,J],V2,0,0);
48900 DRAW(V1,V2);
49000 DRAW(D,E);
49100 GO TO EEE;
49200 END; END;
49300 IF CUTV[I,J]=0 AND CUTU[I,J]=0 THEN
49400 BEGIN DRAW(D,E); GO TO EEE; END;
49500 IF CUTV[I,J]>0 THEN
49600 POINT((I-1)/NU,CUTV[I,J],V1,0,0);
49700 COT((I-1)/NU,I/NU,J/NV,(J-1)/NV,U,V,0);
49800 COMMENT OUTSTR("POINT"&CVF(U)&CVF(V)&" "&CVS(I)&" "&CVS(J)&CRLF);
49900 POINT(U,V,V2,0,0);
50000 DRAW(V1,V2);
50100 DRAW(D,V2);
50200 DRAW(V2,E);
50300 EEE: END "TRIANGLE";
50400 ENDO:
50500 NU←PNU; NV←PNV;
50600 END;
50700
50800 PROCEDURE FITT(INTEGER J);
50900 BEGIN
51000 PRELOAD!WITH 1,1,1,2,2,2,2,1;
51100 OWN SAFE INTEGER ARRAY NK[1:4,1:2];
51200 INTEGER I,K,L,M,N;
51300 GU←FACT[HU[J]];
51400 GV←FACT[HV[J]];
51500 FOR I←1 THRU 4 DO
51600 BEGIN "SET"
51700 M←NK[I,1];
51800 N←NK[I,2];
51900 L←CL[J,I,3];
52000 FOR K←1 THRU 3 DO
52100 BEGIN "SET1"
52200 COMMENT OUTSTR(CVS(I)&CVS(J)&CVS(K)&CVS(L)&CVS(M)&CVF(PP[L,1,K])&CRLF);
52300 R[M,N,K]←PP[L,1,K];
52400 R[M,N+2,K]←(CL[J,I,4]*PP[L,2,K]+CL[J,I,5]*PP[L,3,K])*GU;
52500 R[M+2,N,K]←(CL[J,I,6]*PP[L,2,K]+CL[J,I,7]*PP[L,3,K])*GV;
52600 R[M+2,N+2,K]←CL[J,I,8]*PP[L,4,K]*GU*GV;
52700 END "SET1";
52800 END "SET";
52900 COMMENT FOR I←1 THRU 4 DO BEGIN FOR J←1 THRU 4 DO FOR K←1 THRU 3 DO
53000 OUTSTR(CVF(R[I,J,K])); COMMENT OUTSTR(CRLF); COMMENT END; COMMENT OUTSTR(CRLF);
53100 END;
53200
53300 PROCEDURE FOTT(INTEGER J);
53400 BEGIN
53500 OWN SAFE REAL ARRAY C[1:3,1:3],U[1:3,1:3],V[1:3,1:3],T[1:3,1:3];
53600 INTEGER I,K,L,M,N;
53700 BEGIN "POCK"
53800 FOR I←1 THRU 3 DO BEGIN "I"
53900 GU←1; GV←1; IF I=1 THEN BEGIN
54000 GU←FACT[HU[J]];
54100 GV←FACT[HV[J]]; END;
54200 FOR K←1 THRU 3 DO
54300 BEGIN "SET"
54400 L←CL[J,I,3];
54500 C[I,K]←PP[L,1,K];
54600 U[I,K]←(CL[J,I,4]*PP[L,2,K]+CL[J,I,5]*PP[L,3,K])*GU;
54700 V[I,K]←(CL[J,I,6]*PP[L,2,K]+CL[J,I,7]*PP[L,3,K])*GV;
54800 T[I,K]←CL[J,I,8]*PP[L,4,K]*GU*GV;
54900 END "SET";
55000 END "I";
55100 FOR K←1 THRU 3 DO
55200 BEGIN "MOLT"
55300 Q[1,1,K]←C[1,K];
55400 Q[2,1,K]←U[1,K];
55500 Q[3,1,K]←3*C[2,K]-3*C[1,K]-2*U[1,K]-U[2,K];
55600 Q[4,1,K]←U[2,K]-2*C[2,K]+2*C[1,K]+U[1,K];
55700 Q[1,2,K]←V[1,K];
55800 Q[2,2,K]←T[1,K];
55900 Q[3,2,K]←6*C[2,K]-6*C[1,K]-2*U[1,K]-U[2,K]
56000 -T[2,K]+3*V[2,K]-3*V[1,K]-2*T[1,K];
56100 Q[4,2,K]←6*C[1,K]-6*C[2,K]+2*U[1,K]+2*U[2,K]
56200 +T[2,K]-2*V[2,K]+2*V[1,K]+T[1,K];
56300 Q[1,3,K]←3*C[3,K]-3*C[1,K]-V[3,K]-2*V[1,K];
56400 Q[1,4,K]←V[3,K]-2*C[3,K]+2*C[1,K]+V[1,K];
56500 Q[2,3,K]←6*C[3,K]-6*C[1,K]-V[3,K]-2*V[1,K]
56600 -T[3,K]-2*T[1,K]+3*U[3,K]-3*U[1,K];
56700 Q[2,4,K]←6*C[1,K]-6*C[3,K]+2*V[3,K]+2*V[1,K]
56800 +T[3,K]+T[1,K]-2*U[3,K]+2*U[1,K];
56900 Q[3,4,K]←0;
57000 Q[4,4,K]←0;
57100 Q[4,3,K]←0;
57200 Q[3,3,K]←Q[2,4,K]+Q[4,2,K];
57300 COMMENT FOR M←1 THRU 3 DO
57400 OUTSTR(CVF(C[M,K])); COMMENT OUTSTR(CRLF);
57500 END "MOLT";
57600 SETFORMAT(5,1);
57700 FOR I←1 THRU 4 DO BEGIN FOR M←1 THRU 4 DO
57800 COMMENT FOR K←1 THRU 3 DO OUTSTR(CVF(Q[I,M,K])); COMMENT OUTSTR(CRLF); END;
57900 END "POCK";
58000 END;
58100
58200 PROCEDURE CHANGE(INTEGER I,J,ST; REAL V,ROT);
58300 BEGIN "CHANGE"
58400 INTEGER K,L;
58500 LABEL INDEX,ENDCH;
58600 SETFORMAT(7,3);
58700 COMMENT OUTSTR(CVS(I)&CVS(J)&CVS(ST)&CVF(V)&CVS(ROT)&CRLF);
58800 IF I<1 OR I>32 THEN GO TO INDEX;
58900 IF ST="A" THEN P[I,J,1]←V;
59000 IF ST="B" THEN P[I,J,2]←V;
59100 IF ST="C" THEN P[I,J,3]←V;
59200 IF ST="X" THEN P[I,J,1]←P[I,J,1]+V;
59300 IF ST="Y" THEN P[I,J,2]←P[I,J,2]+V;
59400 IF ST="Z" THEN P[I,J,3]←P[I,J,3]+V;
59500 IF ST="U" THEN FOR K←1 THRU 3 DO
59600 P[I,J,K]←P[I,J,K]+V*P[I,2,K];
59700 IF ST="V" THEN FOR K←1 THRU 3 DO
59800 P[I,J,K]←P[I,J,K]+V*P[I,3,K];
59900 IF ST="W" THEN BEGIN "W"
60000 AU←(P[I,2,1]↑2+P[I,2,2]↑2+P[I,2,3]↑2)↑.5;
60100 AV←(P[I,3,1]↑2+P[I,3,2]↑2+P[I,3,3]↑2)↑.5*AU;
60200 P[I,J,1]←V*(P[I,2,2]*P[I,3,3]-P[I,2,3]*P[I,3,2])/AV+P[I,J,1];
60300 P[I,J,2]←V*(P[I,2,3]*P[I,3,1]-P[I,2,1]*P[I,3,3])/AV+P[I,J,2];
60400 P[I,J,3]←V*(P[I,2,1]*P[I,3,2]-P[I,2,2]*P[I,3,1])/AV+P[I,J,3];
60500 END "W";
60600 IF ST="R" THEN BEGIN "R"
60700 NR←ROT;
60800 IF NR<1 OR NR>32 THEN GO TO INDEX;
60900 IF J=1 THEN FOR K←1 THRU 3 DO
61000 P[I,1,K]←P[I,1,K]-P[NR,1,K];
61100 DQ←(P[I,J,1]↑2+P[I,J,2]↑2+P[I,J,3]↑2)↑.5;
61200 DD←(P[NR,2,1]↑2+P[NR,2,2]↑2+P[NR,2,3]↑2)↑.5;
61300 IF DD>0. THEN BEGIN "1"
61400 DOTT←(P[NR,2,1]*P[I,J,1]+P[NR,2,2]*P[I,J,2]
61500 +P[NR,2,3]*P[I,J,3])/DD;
61600 FOR K←1 THRU 3 DO A[K]←P[I,J,K]-DOTT*P[NR,2,K]/DD;
61700 B[1]←(P[NR,2,2]*P[I,J,3]-P[NR,2,3]*P[I,J,2])/DD;
61800 B[2]←(P[NR,2,3]*P[I,J,1]-P[NR,2,1]*P[I,J,3])/DD;
61900 B[3]←(P[NR,2,1]*P[I,J,2]-P[NR,2,2]*P[I,J,1])/DD;
62000 DR←(B[1]↑2+B[2]↑2+B[3]↑2)↑.5;
62100 IF DR > .001*DQ THEN BEGIN "2"
62200 FOR K←1 THRU 3 DO B[K]←B[K]*DQ/DR;
62300 V←V*PI/180.;
62400 SV←SIN(V);
62500 CV←COS(V);
62600 FOR K←1 THRU 3 DO
62700 P[I,J,K]←DOTT*P[NR,2,K]/DD+CV*A[K]+SV*B[K];
62800 IF J=1 THEN FOR K←1 THRU 3 DO
62900 P[I,J,K]←P[I,J,K]+P[NR,1,K];
63000 END "2"; END "1" ELSE OUTSTR("DD=0"&CRLF);
63100 END "R";
63200 IF I>28 THEN GO TO ENDCH;
63300 IF I MOD 2 THEN L←I+1 ELSE L←I-1;
63400 FOR J←1 THRU 4 DO BEGIN "3"
63500 P[L,J,1]← -P[I,J,1];
63600 P[L,J,2]← -P[I,J,2];
63700 P[L,J,3] ← P[I,J,3]; END "3";
63800 GO TO ENDCH;
63900 INDEX: OUTSTR("BAD INDEX"&CRLF);
64000 ENDCH: END "CHANGE";
64100
64200 PROCEDURE DROT(SAFE REAL ARRAY V1,V2);
64300 BEGIN
64400 REAL X1,X2,Y1,Y2,DX,DY;
64500 X1←-MAG*(V1[1]-VIEW[1])/(V1[3]-VIEW[3]);
64600 X2←-MAG*(V2[1]-VIEW[1])/(V2[3]-VIEW[3]);
64700 Y1←-MAG*(V1[2]-VIEW[2])/(V1[3]-VIEW[3]);
64800 Y2←-MAG*(V2[2]-VIEW[2])/(V2[3]-VIEW[3]);
64900 DX←X2-X1;
65000 DY←Y2-Y1;
65100 AIVECT(X1,Y1);
65200 AVECT(X2,Y2);
65300 END;
65400
65500 PROCEDURE ARMIT;
65600 BEGIN "ARMIT"
65700 REAL UU,VV;
65800 INTEGER P,Q;
65900 FOR I←0 THRU 1 DO
66000 FOR J←0 THRU 1 DO BEGIN "CALC"
66100
66200 UU←-(2*I-1)/3;
66300 VV←-(2*J-1)/3;
66400 M←3*I+1;
66500 N←3*J+1;
66600 P←I+2;
66700 Q←J+2;
66800
66900 POINT(I,J,C,0,0);
67000 POINT(I,J,A,1,0);
67100 POINT(I,J,B,0,1);
67200 POINT(I,J,D,1,1);
67300
67400 FOR K←1 THRU 3 DO BEGIN
67500 VC[M,N,K]←C[K];
67600 VC[P,N,K]←C[K]+A[K]*UU;
67700 VC[M,Q,K]←C[K]+B[K]*VV;
67800 VC[P,Q,K]←C[K]+A[K]*UU+B[K]*VV+D[K]*UU*VV;
67900 END;
68000 END "CALC";
68100
68200 FOR I←1 THRU 3 DO
68300 FOR J←1 STEP DAM UNTIL 4 DO BEGIN
68400 FOR K←1 THRU 3 DO BEGIN
68500 V1[K]←VC[I,J,K];
68600 V2[K]←VC[I+1,J,K]; END;
68700 DROT(V1,V2); END;
68800
68900 FOR I←1 STEP DAM UNTIL 4 DO
69000 FOR J←1 THRU 3 DO BEGIN
69100 FOR K←1 THRU 3 DO BEGIN
69200 V1[K]←VC[I,J,K];
69300 V2[K]←VC[I,J+1,K]; END;
69400 DROT(V1,V2); END;
69500
69600 END "ARMIT";
69700
00100
00200 BC←GETCHAN;
00300 DPYSET(DPYBUF);
00400 OPEN(BC,"TTY",0,2,2,0,0,ZILCH);
00500 SINIT(BC);
00600 OUTSTR(CVOS(XBITS)&CVOS(XESTRT)&CRLF);
00700 BREAKSET(2,"Q","I");
00800 BREAKSET(3,",;:"&CR,"I");
00900 BREAKSET(4,"P","IP");
01000 BREAKSET(5,"DEFGH","I");
01100 BREAKSET(6,"IJKLMNOS","I");
01200 RX←0.; RZ←0.;
01300 PI←3.14159265;
01400 DW←80; DZ←5; DF←100000; ACADEMY←1;
01500 COLOR←'77777777; POWER←1.; DIFF←0.;
01600 COLA←'20020377; COLB←'77777400;
01700 INSIDE←0; HOLE←0; ASIZE←19; IPRIO←0;
01800 GO TO ARRANGE;
01900
02000 START: NI←0; NJ←0; NL←0;
02100 OUTSTR("$");
02200 SETFORMAT(7,3);
02300 SOURCE←INCHWL;
02400 SAVE←SOURCE;
02500 RESULT←SCAN(SAVE,2,BZ);
02600 IF BZ>0 THEN GO TO START;
02700 ST←SCAN(RESULT,4,BZ);
02800 IF BZ>0 THEN BEGIN "PRINT"
02900 I←INTSCAN(RESULT,Z);
03000 IF I<1 OR I>32 THEN GO TO BAD;
03100 FOR J←1 THRU 4 DO
03200 OUTSTR(CVF(P[I,J,1])&CVF(P[I,J,2])&CVF(P[I,J,3])&CRLF);
03300 GO TO START; END "PRINT";
03400 SAVE←SOURCE;
03500 RESULT←SCAN(SAVE,5,BZ);
03600 IF BZ="D" THEN GO TO FIT;
03700 IF BZ="F" OR BZ="E" THEN BEGIN
03800 CHAN←GETCHAN;
03900 OPEN(CHAN,"DSK",'10,4,4,0,0,0);
04000 COMMENT OUTSTR(CVS(CHAN)&CRLF);
04100 COMMENT OUTSTR(RESULT&CRLF);
04200 COMMENT OUTSTR(CVS(FLAG)&CRLF);
04300 ENTER(CHAN,SAVE,FLAG);
04400 IF FLAG=0 THEN
04500 ARRYOUT(CHAN,P[1,1,1],384);
04600 IF BZ="F" AND FLAG=0 THEN ARRYOUT(CHAN,CL[1,1,1],960);
04700 OUTSTR(CVS(FLAG)&CRLF);
04800 RELEASE(CHAN);
04850 FILE←SAVE;
04900 GO TO ARRANGE;
05000 END;
05100 IF BZ="G" OR BZ="H" THEN BEGIN
05200 CHAN←GETCHAN;
05300 OPEN(CHAN,"DSK",'10,4,4,0,0,0);
05400 LOOKUP(CHAN,SAVE,FLAG);
05500 ARRYIN(CHAN,P[1,1,1],384);
05600 IF BZ="H" THEN ARRYIN(CHAN,CL[1,1,1],960);
05700 OUTSTR(CVS(FLAG)&CRLF);
05800 RELEASE(CHAN);
05850 FILE←SAVE;
05900 GO TO ARRANGE;
06000 END;
06100 SAVE←SOURCE;
06200 RESULT←SCAN(SAVE,6,BC);
06300 ROT←REALSCAN(SAVE,Z);
06400 BZ←ROT;
06500 ROT←PI*ROT/180.;
06600 IF BC="I" THEN RZ←RZ+ROT;
06700 IF BC="J" THEN RX←RX+ROT;
06800 IF BC="K" THEN RZ←ROT;
06900 IF BC="L" THEN RX←ROT;
07000 IF (BZ<1 OR BZ> 30) AND (BC="N" OR BC="O") THEN GO TO BAD;
07100 IF BZ>30 AND BC="M" THEN BEGIN
07200 FOR I←1 THRU 22 DO MM[I]←1;
07300 GO TO START; END;
07400 IF BZ<1 AND BC="M" THEN GO TO BAD;
07500 IF BC="M" THEN MM[BZ]←1;
07600 IF BC="N" THEN MM[BZ]←0;
07700 IF BC="O" THEN BEGIN FOR M←1 THRU 30 DO
07800 MM[M]←0; MM[BZ]←1; END;
07850 IF BC="S" THEN DPYSET(DPYBUF);
07900 COMMENT FOR I←1 THRU 30 DO OUTSTR(CVS(MM[I])&CRLF);
08100 IF BC>0 THEN GO TO START;
08200 SAVE←SOURCE;
08300 NEW!I: ST←SCAN(SAVE,3,BC);
08400 NI←NI+1;
08500 SI[NI]←INTSCAN(ST,I);
08600 F[NI]←1.;
08700 IF BC=":" THEN BEGIN "2"
08800 ST←SCAN(SAVE,3,BC);
08900 F[NI]←REALSCAN(ST,I);
09000 END "2";
09100 IF BC="," THEN GO TO NEW!I;
09200 IF BC NEQ ";" THEN GO TO BAD;
09300 NEW!J: ST←SCAN(SAVE,3,BC);
09400 NJ←NJ+1; SJ[NJ]←0;
09500 IF EQU(ST,"C") THEN SJ[NJ]←1;
09600 IF EQU(ST,"U") THEN SJ[NJ]←2;
09700 IF EQU(ST,"V") THEN SJ[NJ]←3;
09800 IF EQU(ST,"T") THEN SJ[NJ]←4;
09900 IF SJ[NJ]=0 THEN GO TO BAD;
10000 IF BC="," THEN GO TO NEW!J;
10100 IF BC NEQ ";" THEN GO TO BAD;
10200 NEW!K: Z←SCAN(SAVE,3,BC);
10300 NL←NL+1;
10400 SL[NL]←Z;
10500 IF BC="," THEN GO TO NEW!K;
10600 IF BC NEQ ";" THEN GO TO BAD;
10700 IF Z="R" THEN NL←NL+1;
10800 FOR I←1 THRU NL DO BEGIN"3"
10900 ST←SCAN(SAVE,3,BC);
11000 IF LENGTH(ST)=0 THEN GO TO BAD;
11100 G[I]←REALSCAN(ST,BZ);
11200 END"3";
11300 IF Z="R" THEN NL←NL-1;
11400 FOR I←1 THRU NI DO
11500 FOR J←1 THRU NJ DO
11600 FOR L←1 THRU NL DO
11700 COMMENT BEGIN OUTSTR(CVS(I)&CVS(J)&CVS(L));
11800 CHANGE(SI[I],SJ[J],SL[L],F[I]*G[L],G[L+1]);
11900 ARRANGE:
12000 FOR K←1 THRU 4 DO JK[K]←P[32,K,3];
12100 NU←P[32,1,1];NV←P[32,2,1];KU←P[32,3,1];KV←P[32,4,1];
12200 KIF←P[32,1,2];MAG←P[32,2,2];FK←P[31,2,2];
12300 FOR K←1 THRU 3 DO VIEW[K]←P[30,4,K];
12400 MAF←P[30,3,3]; FACT[4]←P[30,3,1]; FACT[5]←1;
12500 FOR K←1 THRU 3 DO FACT[K]←P[30,1,K];
12600
12700 ARRTRAN(PP,P);
12800 FOR ZZ←23 THRU 30 DO
12900 BEGIN "MIDPOINT"
13000 OWN SAFE REAL ARRAY A[1:3],B[1:3],D[1:3],E[1:3];
13100 FITT(ZZ);
13200 MULT;
13300 II←CL[ZZ,2,1];
13400 U←CL[ZZ,2,2];
13500 V←0;
13600 POINT(U,V,A,0,0);
13700 POINT(U,V,B,1,0);
13800 COMMENT IF ZZ=25 THEN OUTSTR(CRLF&CVF(B[1])&CVF(B[2])&CVF(B[3])&CRLF);
13900 POINT(U,V,D,0,1);
14000 POINT(U,V,E,1,1);
14100 FOR K←1 THRU 3 DO BEGIN
14200 P[II,1,K]←A[K];
14300 P[II,2,K]←B[K];
14400 P[II,3,K]←D[K];
14500 P[II,4,K]←E[K]; END;
14600 END "MIDPOINT";
14700 DD←0; AC←0;
14800 FOR K←1 THRU 3 DO
14900 DD←DD+P[31,4,K]↑2;
15000 DD←DD↑.5;
15100 FOR K←1 THRU 3 DO BEGIN
15200 T[K]←P[31,4,K]/DD;
15300 AC←AC+T[K]*P[31,3,K]; END;
15400 GO TO START;
15600 COMMENT FOR IZ←41 THRU 48 DO BEGIN "WHOLE"
15700 COMMENT OUTSTR("IZ=1 ONLY"&" AND RES=128"&CRLF);
15850 DPYSET(DPYBUF);
15900 RZ←PI*IZ/48;
16000 GZ←.25+.5*COS(2*RZ);
16100 HZ←.25-.5*COS(2*RZ);
16200 CHANGE(1,1,"C",GZ,0);
16300 CHANGE(3,1,"C",GZ,0);
16400 CHANGE(9,1,"C",HZ,0);
16500 CHANGE(11,1,"C",HZ,0);
16600 ARRTRAN(PP,P);
16700 FOR ZZ←23 THRU 30 DO
16800 BEGIN "MIDPOINT"
16900 OWN SAFE REAL ARRAY A[1:3],B[1:3],D[1:3],E[1:3];
17000 FITT(ZZ);
17100 MULT;
17200 II←CL[ZZ,2,1];
17300 U←CL[ZZ,2,2];
17400 V←0;
17500 POINT(U,V,A,0,0);
17600 POINT(U,V,B,1,0);
17700 COMMENT IF ZZ=25 THEN OUTSTR(CRLF&CVF(B[1])&CVF(B[2])&CVF(B[3])&CRLF);
17800 POINT(U,V,D,0,1);
17900 POINT(U,V,E,1,1);
18000 FOR K←1 THRU 3 DO BEGIN
18100 P[II,1,K]←A[K];
18200 P[II,2,K]←B[K];
18300 P[II,3,K]←D[K];
18400 P[II,4,K]←E[K]; END;
18500 END "MIDPOINT";
18600 INTFRM(1,0,0,RES,RES,20000,0,0,0,0);
18700 FIT:
18750 DPYTYP(-300,1,6);
18800 COSA←COS(RZ);
18900 SINA←SIN(RZ);
19000 COSB←COS(RX);
19100 SINB←SIN(RX);
19200 QZ[1,1]←COSA;
19300 QZ[1,2]←-SINA;
19400 QZ[1,3]←0.;
19500 QZ[2,1]←SINA*COSB;
19600 QZ[2,2]←COSA*COSB;
19700 QZ[2,3]←-SINB;
19800 QZ[3,1]←SINA*SINB;
19900 QZ[3,2]←COSA*SINB;
20000 QZ[3,3]←COSB;
20100 FOR I←1 THRU 30 DO
20200 FOR J←1 THRU 4 DO
20300 FOR K←1 THRU 3 DO BEGIN
20400 PP[I,J,K]←0.;
20500 FOR L←1 THRU 3 DO
20600 PP[I,J,K]←PP[I,J,K]+QZ[K,L]*P[I,J,L];
20700 END;
20800 IF P[31,1,1] > 0 OR P[31,1,3] > 0 THEN OPEN(0,"LPT",0,0,2,0,0,0);
20900 DAM←P[30,2,3];
21000 IF DAM<1 THEN DAM←1;
21100 FOR ZZZ←1 THRU 14 DO
21200 IF MM[ZZZ] THEN BEGIN
21300 FITT(ZZZ); PATCH(NU,NV); DPYOUT(1);
21350 IF K←INCHRS > 0 THEN GO TO MISTAKE; END;
21400 FOR ZZZ←15 THRU 22 DO
21500 IF MM[ZZZ] THEN BEGIN
21600 FOTT(ZZZ); POTCH(NU,NV); DPYOUT(1);
21650 IF K←INCHRS>0 THEN DONE; END;
21675 MISTAKE:
21687 CALCOMP(FILE,DPYBUF);
21700 FOR ZZZ←23 THRU 30 DO
21800 IF MM[ZZZ] THEN BEGIN
21900 FITT(ZZZ); END;
22200 IF P[31,1,1]>0 OR P[31,1,3]> 0 THEN CLOSE(0);
22300 IF P[32,3,2]>0 AND P[31,2,1]>0 THEN BEGIN
22400 DISPLAY(0); IFC 1=0 THENC
22500 DISPLAY(2);
22600 SHUTTER;
22700 DISPLAY(3);
22800 SHUTTER;
22900 DISPLAY(1);
23000 SHUTTER;
23100 IF IZ MOD 4 =0 THEN ENDBUFF; ENDC
23200 END;
23300 COMMENT END "WHOLE";
23400 GO TO START;
23500 BAD: OUTSTR("BAD"&CRLF); GO TO START;
23600 END "PASH"