//gkf: cleaning up the =3D and the = for continuations // Copyright (C) Tony Robbin, N.Y. PROCEDURE DEFINE; VAR B,J,I,ARGI,ANS:INTEGER; PSI,ARG,A1,A2,A3,A4,A5,A6,B1,B2,B3,B4,B5,B6,A,INV,BB:REAL; PROCEDURE LOOPS; VAR I:INTEGER; BEGIN I:= -25; REPEAT ARG := (I/A) + B1; ARGI := TRUNC(ARG); IF ARG <0 THEN ARGI := ARGI -1; B:= TRUNC(B1); IF B1 <0 THEN B:= B-1; PLANE[1,I]:=I+0.6180*ARGI+A1 -B*0.618 ; I:= I+1; UNTIL I = 26; I:= -25; REPEAT ARG := (I/A) + B2; ARGI := TRUNC(ARG); IF ARG <0 THEN ARGI := ARGI -1; B:= TRUNC(B2); IF B2 <0 THEN B:= B-1; PLANE[2,I]:=I+0.6180*ARGI+A2 -B*0.618 ; I:= I+1; UNTIL I = 26; I:= -25; REPEAT ARG := (I/A) + B3; ARGI := TRUNC(ARG); IF ARG <0 THEN ARGI := ARGI -1; B:= TRUNC(B3); IF B3 <0 THEN B:= B-1; PLANE[3,I]:=I+0.6180*ARGI+A3 -B*0.618 ; I:= I+1; UNTIL I = 26; I:= -25; REPEAT ARG := (I/A) + B4; ARGI := TRUNC(ARG); IF ARG <0 THEN ARGI := ARGI -1; B:= TRUNC(B4); IF B4 <0 THEN B:= B-1; PLANE[4,I]:=I+0.6180*ARGI+A4 -B*0.618 ; I:= I+1; UNTIL I = 26; I:= -25; REPEAT ARG := (I/A) + B5; ARGI := TRUNC(ARG); IF ARG <0 THEN ARGI := ARGI -1; B:= TRUNC(B5); IF B5 <0 THEN B:= B-1; PLANE[5,I]:=I+0.6180*ARGI+A5 -B*0.618 ; I:= I+1; UNTIL I = 26; I:= -25; REPEAT ARG := (I/A) + B6; ARGI := TRUNC(ARG); IF ARG <0 THEN ARGI := ARGI -1; B:= TRUNC(B6); IF B6 <0 THEN B:= B-1; PLANE[6,I]:=I+0.6180*ARGI+A6 -B*0.618 ; I:= I+1; UNTIL I = 26; END; //gf: loops //gf: something wrong here, what begins? possibly the procedure PLANE ? BEGIN {PLANE [ ONE OF SIX DIRECTIONS, K OR ORDINAL POSITION] := VALUE OF QUASIPERIODIC OR PERIODIC LEGNTH; THIS MEANS THAT FOR EVERY DIRECTION EVERY SLOT OR ORDINAL POSITION OF THE ARRAY HAS ASSOCIATED WITH IT A REAL NUMBER WHICH IS ITS DISTANCE FROM THE ORIGIN } A:=1.618; {tau is 1.618 1/tau is 0.6180} WRITELN; WRITELN(' CHOOSE BY NUMBER AND HIT RETURN '); WRITELN('1:CHOOSE ALPHAS AND BETAS '); WRITELN('2:CHOOSE DEFAULT ALPHAS AND BETAS '); WRITELN('3:CHOOSE UNIT PERIODIC ALPHAS AND BETAS '); READLN(ANS); CASE ANS OF 1: BEGIN WRITELN(' A1 B1 '); {gf: alpha beta s} READLN(A1,B1); WRITELN(' A2 B2 '); READLN(A2,B2); WRITELN(' A3 B3 '); READLN(A3,B3); WRITELN(' A4 B4 '); READLN(A4,B4); WRITELN(' A5 B5 '); READLN(A5,B5); WRITELN(' A6 B6 '); READLN(A6,B6); LOOPS; END; 2: BEGIN {gf: default } A1:=0.6300; A2:=0.6300; A3:=0.6300; A4:=0.6300; A5:=0.6300; A6:=0.6300; B1:= -0.5; B2:= -0.5; B3:= -0.5; B4:= -0.5; B5:= -0.5; B6:= -0.5; LOOPS; END; 3: BEGIN {unit alpha beta ?} WRITELN(' ENTER SHIFT FACTOR -->RETURN'); READLN(A1); FOR I:= -25 TO 25 DO PLANE [1,I] := I + A1; WRITELN(' ENTER SHIFT FACTOR -->RETURN'); READLN(A1); FOR I:= -25 TO 25 DO PLANE [2,I] := I + A1; WRITELN(' ENTER SHIFT FACTOR -->RETURN'); READLN(A1); FOR I:= -25 TO 25 DO PLANE [3,I] := I + A1; WRITELN(' ENTER SHIFT FACTOR -->RETURN'); READLN(A1); FOR I:= -25 TO 25 DO PLANE [4,I] := I + A1; WRITELN(' ENTER SHIFT FACTOR -->RETURN'); READLN(A1); FOR I:= -25 TO 25 DO PLANE [5,I] := I + A1; WRITELN(' ENTER SHIFT FACTOR -->RETURN'); READLN(A1); FOR I:= -25 TO 25 DO PLANE [6,I] := I + A1; end; END; //gf: another corruption? can this stuff be out in the open like this? //or is it part of the procedure? writeln(plane[1,-6]:8,plane[1,-5]:8,plane[1,-4]:8,plane[1,-3]:8,plane[1,-= 2]:8,plane[1,-1]:8); writeln(plane[1,0]:8,plane[1,1]:8,plane[1,2]:8,plane[1,3]:8,plane[1,4]:8)= ; WRITELN(plane[1,5]:8,plane[1,6]:8,plane[1,7]:8,plane[1,8]:8,plane[1,9]:8,= plane[1,10]:8); //gf: more corruption? what's that * doing infront ? (*THE STAR VECTOR MATRIX*) BB:= *(1/SQRT(5)); INV:= 1/SQRT(5); E[1,1]:= BB; E[1,2]:= 0; E[1,3]:=INV; E[2,1]:= BB*COS(2*PI/5); E[2,2]:= BB*SIN(2*PI/5); E[2,3]:=INV; E[3,1]:= BB*COS(4*PI/5); E[3,2]:= BB*SIN(4*PI/5); E[3,3]:=INV; E[4,1]:= BB*COS(6*PI/5); E[4,2]:= BB*SIN(6*PI/5); E[4,3]:=INV; E[5,1]:= BB*COS(8*PI/5); E[5,2]:= BB*SIN(8*PI/5); E[5,3]:=INV; E[6,1]:= 0; E[6,2]:= 0; E[6,3]:=1; WRITELN( E[1,1]:10:4,E[1,2]:10:4,E[1,3]:10:4); WRITELN( E[2,1]:10:4,E[2,2]:10:4,E[2,3]:10:4); WRITELN( E[3,1]:10:4,E[3,2]:10:4,E[3,3]:10:4); WRITELN( E[4,1]:10:4,E[4,2]:10:4,E[4,3]:10:4); WRITELN( E[5,1]:10:4,E[5,2]:10:4,E[5,3]:10:4); WRITELN( E[6,1]:10:4,E[6,2]:10:4,E[6,3]:10:4); //what is ACSRQQ?? PSI := ACSRQQ(0.5/SIN(PI/5)); WRITELN( PSI:10:4,'PSI'); FOR I := 1 TO 5 DO BEGIN E[I,1] := COS((I-0.4)* 2*PI/5) * SIN( 2* PSI); E[I,2] := SIN((I-0.4)* 2*PI/5) * SIN( 2* PSI); E[I,3] := COS( 2*PSI); END; WRITELN( E[1,1]:10:4,E[1,2]:10:4,E[1,3]:10:4); WRITELN( E[2,1]:10:4,E[2,2]:10:4,E[2,3]:10:4); WRITELN( E[3,1]:10:4,E[3,2]:10:4,E[3,3]:10:4); WRITELN( E[4,1]:10:4,E[4,2]:10:4,E[4,3]:10:4); WRITELN( E[5,1]:10:4,E[5,2]:10:4,E[5,3]:10:4); WRITELN( E[6,1]:10:4,E[6,2]:10:4,E[6,3]:10:4); END; //gf: of the procedure LOOPS //gf: what the h... is the carat for? PROCEDURE DT(K:ROM;X:INTEGER); VAR I:INTEGER; //a matrix multiplication representing a projection of // 8 points in R6 to eight points in R3 BEGIN FOR I:=1 TO 8 DO BEGIN F1^[X,1,I]:=K[I,1]* E[1,1] + K[I,2] * E[2,1] + K[I,3] * E[3,1] + K[I,4]* E[4,1] + K[I,5] * E[5,1] + K[I,6] * E[6,1]; F1^[X,2,I]:=K[I,1]* E[1,2] + K[I,2] * E[2,2] + K[I,3] * E[3,2] + K[I,4]* E[4,2] + K[I,5] * E[5,2] + K[I,6] * E[6,2]; F1^[X,3,I]:=K[I,1]* E[1,3] + K[I,2] * E[2,3] + K[I,3] * E[3,3] + K[I,4]* E[4,3] + K[I,5] * E[5,3] + K[I,6] * E[6,3]; END; {40 IS GOOD TOO} IF SQR(F1^[X,1,1]) + SQR(F1^[X,2,1]) + SQR(F1^[X,3,1]) < 30 THEN PPLOT(X) ELSE NEXT :=NEXT -1; //gf: domelike selection? but PPLOT(X) is not in this code //so, there's no plotting here. Tony said this just creates the data. //and I don't have the code for the viewer "quasi.exe". END; // procedure DT //gf: looks like an antiprojection, given 3 coords of the projection, //the 3 proposed and if planes intersect, also found "place" where to //apply the rhomb. PROCEDURE DIREC(A,B,C:INTEGER); {TAKES IN THE THREE DIRECTIONS AND DISCOVERS THE OTHER THREE} VAR I:INTEGER; DIR:ARRAY[1..6] OF INTEGER; LEGAL:ARRAY[1..6] OF BOOLEAN; BEGIN FOR I := 1 TO 6 DO BEGIN DIR[I]:=I; LEGAL[I]:=TRUE; END; FOR I := 1 TO 6 DO IF A=DIR[I] THEN LEGAL[I] :=FALSE; FOR I := 1 TO 6 DO IF B=DIR[I] THEN LEGAL[I] :=FALSE; FOR I := 1 TO 6 DO IF C=DIR[I] THEN LEGAL[I] :=FALSE; I:=0; REPEAT I:=I+1; IF LEGAL[I] THEN DD:= I UNTIL LEGAL[I]; LEGAL[I]:= FALSE; I:=0; REPEAT I:=I+1; IF LEGAL[I] THEN EE:= I UNTIL LEGAL[I]; LEGAL[I]:= FALSE; I:=0; REPEAT I:=I+1; IF LEGAL[I] THEN FF:= I UNTIL LEGAL[I]; END; //procedure DIREC FUNCTION FINDK( X:REAL8; A:INTEGER): INTEGER; VAR I:INTEGER; BEGIN IF X < PLANE[A,-25] THEN BEGIN FINDK := -25; WRITELN('FINK TOO LOW'); END; FOR I := -25 TO 24 DO BEGIN IF (X >= PLANE[A,I]-0.0001 ) AND (X < PLANE[A,I+1]+0.0001) THEN FINDK := I; (* IF (X = PLANE[A,I] ) THEN FINDK := I-1;*) IF X= PLANE[A,I] THEN BEGIN COUNT := COUNT+1; WRITELN( A:6:12,X:12); END; END; IF X >= PLANE[A,25] THEN BEGIN FINDK := 25; WRITELN('FINDK TOO HIGH'); END; {I:= TRUNC(X); IF X<0 THEN I := I-1; FINDK:= I;} END; //procedure FINDK PROCEDURE RHOMBUS(A,B,C:INTEGER); { SEVEN SIX-TUPLETS ARE COMPUTED FROM ONE KNOWN } { THE DIRECTIONS ARE PASSED THROUGH ie ARBITRARY SET OF = DIRECTIONS} { R IS A 6x8 MATRIX THAT HOLDS THE KS FOR ONE RHOMBUS} { CALLS DT} BEGIN R[1,A]:=K[A]; R[1,B]:=K[B]; R[1,C]:=K[C]; R[1,DD]:=K[DD]; R[1,EE]:=K[EE]; R[1,FF]:=K[FF]; R[2,A]:=K[A]+1;R[2,B]:=K[B]; R[2,C]:=K[C]; R[2,DD]:=K[DD]; R[2,EE]:=K[EE]; R[2,FF]:=K[FF]; R[3,A]:=K[A]; R[3,B]:=K[B]+1; R[3,C]:=K[C]; R[3,DD]:=K[DD]; R[3,EE]:=K[EE]; R[3,FF]:=K[FF]; R[4,A]:=K[A]; R[4,B]:=K[B]; R[4,C]:=K[C]+1; R[4,DD]:=K[DD]; R[4,EE]:=K[EE]; R[4,FF]:=K[FF]; R[5,A]:=K[A]+1;R[5,B]:=K[B]+1; R[5,C]:=K[C]; R[5,DD]:=K[DD]; R[5,EE]:=K[EE]; R[5,FF]:=K[FF]; R[6,A]:=K[A]+1;R[6,B]:=K[B]; R[6,C]:=K[C]+1; R[6,DD]:=K[DD]; R[6,EE]:=K[EE]; R[6,FF]:=K[FF]; R[7,A]:=K[A]; R[7,B]:=K[B]+1; R[7,C]:=K[C]+1; R[7,DD]:=K[DD]; R[7,EE]:=K[EE]; R[7,FF]:=K[FF]; R[8,A]:=K[A]+1;R[8,B]:=K[B]+1; R[8,C]:=K[C]+1; R[8,DD]:=K[DD]; R[8,EE]:=K[EE]; R[8,FF]:=K[FF]; DT(R,NEXT); {THE VERTICIES OF A RHOMBUS ARE COMPUTED AND SEND TO F^ } END; //procedure RHOMBUS PROCEDURE INTSECT(A,B,C,H,I,J:INTEGER); // { A,B,C ARE THE THREE DIRECTION BEING CONSIDERED // H I J ARE THE ORDINAL POSITIONS -THE KS -PLANES OF THE THREE // DIRECTIONS} VAR AX,AY,AZ,BX,BY,BZ,CX,CY,CZ,AAX,AAY,AAZ,BBX,BBY:REAL8; BBZ,CCX,CCY,CCZ,ISECX,ISECY,ISECZ,LL,MM,NN:REAL8; R1,R2,R3:REAL8; U:ARRAY[1..3,1..3] OF REAL8; BEGIN { Uabc =Eb x Ec/ (Ea* (Eb x Ec) Ubca =Ec x Ea/ (Eb* (Ec x Ea) Ucab =Ea x Eb/ (Ec* (Ea x Eb) AX AY AZ AX AY BX BY BZ BX BY CX CY CZ CX CY } AX:=E[A,1];AY:=E[A,2];AZ:=E[A,3]; BX:=E[B,1];BY:=E[B,2];BZ:=E[B,3]; CX:=E[C,1];CY:=E[C,2];CZ:=E[C,3]; {EQUATION FOR Uabc} NUM:=AX * ((BY * CZ) - ( BZ * CY)) + AY * ((BZ * CX) - ( CZ * BX)) + AZ * ((BX * CY) - ( CX * BY)) ; CCX:=CX/NUM; CCY:=CY/NUM; CCZ:=CZ/NUM; U[1,1]:= (BY * CCZ) - (BZ * CCY); U[1,2]:= (BZ * CCX) - (BX * CCZ); U[1,3]:= (BX * CCY) - (BY * CCX); {EQUATION FOR Ubca} NUM:=BX * ((CY * AZ) - ( CZ * AY)) + BY * ((CZ * AX) - ( AZ * CX)) + BZ * ((CX * AY) - ( AX * CY)) ; AAX:=AX/NUM; AAY:=AY/NUM; AAZ:=AZ/NUM; U[2,1]:= (CY * AAZ) - (CZ * AAY); U[2,2]:= (CZ * AAX) - (CX * AAZ); U[2,3]:= (CX * AAY) - (CY * AAX); {EQUATION FOR Ucab} NUM:=CX * ((AY * BZ) - ( AZ * BY)) + CY * ((AZ * BX) - ( BZ * AX)) + CZ * ((AX * BY) - ( BX * AY)) ; BBX:=BX/NUM; BBY:=BY/NUM; BBZ:=BZ/NUM; U[3,1]:= (AY * BBZ) - (AZ * BBY); U[3,2]:= (AZ * BBX) - (AX * BBZ); U[3,3]:= (AX * BBY) - (AY * BBX); r1:=plane[a,h];r2:=plane[b,i];r3:=plane[c,j]; ISECX:=(r1*U[1,1]) + (r2*U[2,1]) + (r3*U[3,1]); ISECY:=(r1*U[1,2]) + (r2*U[2,2]) + (r3*U[3,2]); ISECZ:=(r1*U[1,3]) + (r2*U[2,3]) + (r3*U[3,3]); (****************** {CALCULATE THE DISTANCE FROM THE ORIGIN, IF ITS TOO FAR, DROP IT} IF ( SQR(ISECX) + SQR(ISECY) + SQR(ISECZ) ) < 20 THEN BEGIN ********************) DIREC(A,B,C); {THE OTHER THREE DIRECTIONS ARE DISCOVERED} {CALCULATE THE LEGNTH ON THE OTHER THREE} {DOT ISECX ETC WITH EACH OTHER FROM STAR} LL:=(ISECX * E[DD,1]) + (ISECY * E[DD,2]) + (ISECZ * E[DD,3]); MM:=(ISECX * E[EE,1]) + (ISECY * E[EE,2]) + (ISECZ * E[EE,3]); NN:=(ISECX * E[FF,1]) + (ISECY * E[FF,2]) + (ISECZ * E[FF,3]); K[A]:=H; K[B]:=I; K[C]:=J; K[DD]:=FINDK(LL,DD); K[EE]:=FINDK(MM,EE); K[FF]:=FINDK(NN,FF); RHOMBUS(A,B,C); NEXT:=NEXT+1; (********** END; {check distance} *************) END; //end procedure INRSECT PROCEDURE FILL; {LOOPS THROUGH THREE PLANE INTERSECTIONS VIA THEIR } {ORDINAL POSITIONS - THEIR KS -AND CALLS INTSECT EACH} VAR DIR,PLN,A,B,C,H,I,J:INTEGER; ANS:CHAR; BEGIN NEXT:=1; FOR I := 1 TO 3 DO BEGIN FOR J := 1 TO NPTS DO BEGIN F^[I,J] :=0 ; END;END; WRITELN; WRITELN('DO YOU WISH TO DRAW THE WHOLE FIGURE? Y/N AND HIT RETURN'); READLN(ANS); IF ANS IN ['Y','y'] THEN BEGIN FOR A:= 1 TO 6 DO BEGIN FOR B:= 1 TO 6 DO BEGIN FOR C:= 1 TO 6 DO BEGIN { FOR EACH A NOT B NOT C IN ONLY ONE ORDER} IF (A<>B) AND (B<>C) AND (A<>C) AND (A