program gigaminx c c Mike Collins -- cinclodes@yahoo.com c c This FORTRAN code simulates on the screen a generalization of the c Megaminx that is analogous to the generalization of Rubik's Cube c to Rubik's Professor. I call this puzzle the Gigaminx. It c apparently does not exist outside the computer. It has about c 3.65x10^263 distinguishable configurations. c c The output file gigaminx.ps contains the display. After compiling c the code, run it and enter zeros when prompted. The code will c quit after you enter the second zero. This initializes the c display file, which you can now open with your Postscript c displayer. Keep the display open and run the code again. This c time, you can enter a random integer to mix up the code or zero c again if you want to start with the puzzle solved. Then you can c make a series of moves by entering one integer per line. Enter c negatives to twist in the opposite directions. You can reopen c the display after each move. c real vx(20),vy(20),vz(20),fx(12,5),fy(12,5),fz(12,5), > nx(12),ny(12),nz(12),tilex(372,5),tiley(372,5) integer iclr(372),jclr(12) character*15 cname(12) pi=4.0*atan(1.0) theta=-18.0 1 cname(1)=' blue' cname(2)=' yellow' cname(3)=' orange' cname(4)=' green' cname(5)=' purple' cname(6)=' red' cname(7)=' slate' cname(8)=' lavender' cname(9)=' pine' cname(10)=' brown' cname(11)=' white' cname(12)=' aqua' c n=0 do 3 i=1,12 jclr(i)=i do 2 j=1,31 n=n+1 iclr(n)=i 2 continue 3 continue c call vrtx(vx,vy,vz,pi) call faces(vx,vy,vz,fx,fy,fz,nx,ny,nz) call fclr(fx,fy,fz,nx,ny,nz,theta,pi,tilex,tiley,1.0) call fclr(fx,fy,fz,nx,ny,nz,theta,pi,tilex,tiley,-1.0) c c Mix up the cube. c write(*,*)' ' write(*,*)' Randomly mix up the puzzle. Enter an integer seed' write(*,*)' for the random number generator. Enter 0 if you' write(*,*)' dont want to mix up the cube.' write(*,*)' ' read(*,*)iseed c if(iseed.ne.0)then do 4 i=1,1000 xran=1.0+23.999*ran0(iseed) n=ifix(xran) if(n.gt.12)n=n+8 call opera(iclr,n,1,jclr,cname) 4 continue end if c open(unit=1,status='unknown',file='gigaminx.ps') call start(jclr,cname) call tclr(tilex,tiley,iclr) call frame(tilex,tiley) write(1,*)' showpage' close(1) c c Solve the cube. c write(*,*)' ' write(*,*)' Enter an operator number one at a time.' write(*,*)' Definition of the operators is given in the display.' write(*,*)' Use negative numbers for inverse operators.' write(*,*)' Enter 99 to reset the cube. Enter 0 to quit.' write(*,*)' ' c 5 read(*,*)i if(i.eq.0)go to 6 k=1 if(i.lt.0)then k=4 i=-i end if c call opera(iclr,i,k,jclr,cname) open(unit=1,status='unknown',file='gigaminx.ps') call start(jclr,cname) call tclr(tilex,tiley,iclr) call frame(tilex,tiley) write(1,*)' showpage' close(1) if(i.eq.99)go to 1 go to 5 c 6 stop end c subroutine opera(iclr,i,kin,jclr,cname) integer iclr(372),jclr(12) character*15 cname(12),ctemp c k=kin if(k.lt.0)k=5+kin c do 7 j=1,k c if((i.eq.1).or.(i.eq.2))then call cycle(iclr,157,161,165,169,173) call cycle(iclr,158,162,166,170,174) call cycle(iclr,159,163,167,171,175) call cycle(iclr,160,164,168,172,176) call cycle(iclr,177,179,181,183,185) call cycle(iclr,178,180,182,184,186) call cycle(iclr,68,130,99,347,316) call cycle(iclr,67,129,98,346,315) call cycle(iclr,66,128,97,345,314) call cycle(iclr,65,127,96,344,313) call cycle(iclr,64,126,95,343,312) end if c if(i.eq.2)then call cycle(iclr,69,131,100,348,317) call cycle(iclr,86,148,117,365,334) call cycle(iclr,85,147,116,364,333) call cycle(iclr,84,146,115,363,332) call cycle(iclr,83,145,114,362,331) end if c if((i.eq.3).or.(i.eq.4))then call cycle(iclr,64,68,72,76,80) call cycle(iclr,65,69,73,77,81) call cycle(iclr,66,70,74,78,82) call cycle(iclr,67,71,75,79,83) call cycle(iclr,84,86,88,90,92) call cycle(iclr,85,87,89,91,93) call cycle(iclr,134,173,312,227,14) call cycle(iclr,133,172,331,226,13) call cycle(iclr,132,171,330,225,12) call cycle(iclr,131,170,329,224,11) call cycle(iclr,130,169,328,223,10) end if c if(i.eq.4)then call cycle(iclr,135,174,313,228,15) call cycle(iclr,150,185,332,243,28) call cycle(iclr,149,184,341,242,27) call cycle(iclr,148,183,340,241,26) call cycle(iclr,129,168,327,222,9) end if c if((i.eq.5).or.(i.eq.6))then call cycle(iclr,126,130,134,138,142) call cycle(iclr,127,131,135,139,143) call cycle(iclr,128,132,136,140,144) call cycle(iclr,129,133,137,141,145) call cycle(iclr,146,148,150,152,154) call cycle(iclr,147,149,151,153,155) call cycle(iclr,157,64,10,45,103) call cycle(iclr,176,83,9,44,102) call cycle(iclr,175,82,8,43,101) call cycle(iclr,174,81,7,42,100) call cycle(iclr,173,80,6,41,99) end if c if(i.eq.6)then call cycle(iclr,46,104,158,65,11) call cycle(iclr,59,119,177,84,26) call cycle(iclr,58,118,186,93,25) call cycle(iclr,57,117,185,92,24) call cycle(iclr,40,98,172,79,5) end if c if((i.eq.7).or.(i.eq.8))then call cycle(iclr,95,99,103,107,111) call cycle(iclr,96,100,104,108,112) call cycle(iclr,97,101,105,109,113) call cycle(iclr,98,102,106,110,114) call cycle(iclr,115,117,119,121,123) call cycle(iclr,116,118,120,122,124) call cycle(iclr,161,126,41,293,351) call cycle(iclr,160,145,40,292,350) call cycle(iclr,159,144,39,291,349) call cycle(iclr,158,143,38,290,348) call cycle(iclr,157,142,37,289,347) end if c if(i.eq.8)then call cycle(iclr,162,127,42,294,352) call cycle(iclr,179,146,57,307,367) call cycle(iclr,178,155,56,306,366) call cycle(iclr,177,154,55,305,365) call cycle(iclr,176,141,36,288,346) end if c if((i.eq.9).or.(i.eq.10))then call cycle(iclr,2,6,10,14,18) call cycle(iclr,3,7,11,15,19) call cycle(iclr,4,8,12,16,20) call cycle(iclr,5,9,13,17,21) call cycle(iclr,22,24,26,28,30) call cycle(iclr,23,25,27,29,31) call cycle(iclr,49,138,80,223,192) call cycle(iclr,48,137,79,222,191) call cycle(iclr,47,136,78,221,190) call cycle(iclr,46,135,77,220,189) call cycle(iclr,45,134,76,219,188) end if c if(i.eq.10)then call cycle(iclr,50,139,81,224,193) call cycle(iclr,61,152,92,241,210) call cycle(iclr,60,151,91,240,209) call cycle(iclr,59,150,90,239,208) call cycle(iclr,44,133,75,238,207) end if c if((i.eq.11).or.(i.eq.12))then call cycle(iclr,33,37,41,45,49) call cycle(iclr,34,38,42,46,50) call cycle(iclr,35,39,43,47,51) call cycle(iclr,36,40,44,48,52) call cycle(iclr,53,55,57,59,61) call cycle(iclr,54,56,58,60,62) call cycle(iclr,107,142,6,188,297) call cycle(iclr,106,141,5,207,296) call cycle(iclr,105,140,4,206,295) call cycle(iclr,104,139,3,205,294) call cycle(iclr,103,138,2,204,293) end if c if(i.eq.12)then call cycle(iclr,108,143,7,189,298) call cycle(iclr,121,154,24,208,309) call cycle(iclr,120,153,23,217,308) call cycle(iclr,119,152,22,216,307) call cycle(iclr,102,137,21,203,292) end if c if((i.eq.13).or.(i.eq.14))then call cycle(iclr,312,316,320,324,328) call cycle(iclr,313,317,321,325,329) call cycle(iclr,314,318,322,326,330) call cycle(iclr,315,319,323,327,331) call cycle(iclr,332,334,336,338,340) call cycle(iclr,333,335,337,339,341) call cycle(iclr,343,258,231,72,169) call cycle(iclr,362,257,230,71,168) call cycle(iclr,361,256,229,70,167) call cycle(iclr,360,255,228,69,166) call cycle(iclr,359,254,227,68,165) end if c if(i.eq.14)then call cycle(iclr,344,259,232,73,170) call cycle(iclr,363,274,245,88,183) call cycle(iclr,372,273,244,87,182) call cycle(iclr,371,272,243,86,181) call cycle(iclr,358,253,226,67,164) end if c if((i.eq.15).or.(i.eq.16))then call cycle(iclr,343,347,351,355,359) call cycle(iclr,344,348,352,356,360) call cycle(iclr,345,349,353,357,361) call cycle(iclr,346,350,354,358,362) call cycle(iclr,363,365,367,369,371) call cycle(iclr,364,366,368,370,372) call cycle(iclr,289,262,320,165,95) call cycle(iclr,288,261,319,164,114) call cycle(iclr,287,260,318,163,113) call cycle(iclr,286,259,317,162,112) call cycle(iclr,285,258,316,161,111) end if c if(i.eq.16)then call cycle(iclr,290,263,321,166,96) call cycle(iclr,305,276,336,181,115) call cycle(iclr,304,275,335,180,124) call cycle(iclr,303,274,334,179,123) call cycle(iclr,284,257,315,160,110) end if c if((i.eq.17).or.(i.eq.18))then call cycle(iclr,219,223,227,231,235) call cycle(iclr,220,224,228,232,236) call cycle(iclr,221,225,229,233,237) call cycle(iclr,222,226,230,234,238) call cycle(iclr,239,241,243,245,247) call cycle(iclr,240,242,244,246,248) call cycle(iclr,328,254,196,18,76) call cycle(iclr,327,253,195,17,75) call cycle(iclr,326,252,194,16,74) call cycle(iclr,325,251,193,15,73) call cycle(iclr,324,250,192,14,72) end if c if(i.eq.18)then call cycle(iclr,329,255,197,19,77) call cycle(iclr,340,272,212,30,90) call cycle(iclr,339,271,211,29,89) call cycle(iclr,338,270,210,28,88) call cycle(iclr,323,269,191,13,71) end if c if((i.eq.19).or.(i.eq.20))then call cycle(iclr,250,254,258,262,266) call cycle(iclr,251,255,259,263,267) call cycle(iclr,252,256,260,264,268) call cycle(iclr,253,257,261,265,269) call cycle(iclr,270,272,274,276,278) call cycle(iclr,271,273,275,277,279) call cycle(iclr,359,285,200,235,324) call cycle(iclr,358,284,199,234,323) call cycle(iclr,357,283,198,233,322) call cycle(iclr,356,282,197,232,321) call cycle(iclr,355,281,196,231,320) end if c if(i.eq.20)then call cycle(iclr,360,286,201,236,325) call cycle(iclr,371,303,214,247,338) call cycle(iclr,370,302,213,246,337) call cycle(iclr,369,301,212,245,336) call cycle(iclr,354,300,195,230,319) end if c if((i.eq.21).or.(i.eq.22))then call cycle(iclr,281,285,289,293,297) call cycle(iclr,282,286,290,294,298) call cycle(iclr,283,287,291,295,299) call cycle(iclr,284,288,292,296,300) call cycle(iclr,301,303,305,307,309) call cycle(iclr,302,304,306,308,310) call cycle(iclr,204,266,355,111,37) call cycle(iclr,203,265,354,110,36) call cycle(iclr,202,264,353,109,35) call cycle(iclr,201,263,352,108,34) call cycle(iclr,200,262,351,107,33) end if c if(i.eq.22)then call cycle(iclr,205,267,356,112,38) call cycle(iclr,216,278,369,123,55) call cycle(iclr,215,277,368,122,54) call cycle(iclr,214,276,367,121,53) call cycle(iclr,199,261,350,106,52) end if c if((i.eq.23).or.(i.eq.24))then call cycle(iclr,188,192,196,200,204) call cycle(iclr,189,193,197,201,205) call cycle(iclr,190,194,198,202,206) call cycle(iclr,191,195,199,203,207) call cycle(iclr,208,210,212,214,216) call cycle(iclr,209,211,213,215,217) call cycle(iclr,219,250,281,33,2) call cycle(iclr,238,269,300,52,21) call cycle(iclr,237,268,299,51,20) call cycle(iclr,236,267,298,50,19) call cycle(iclr,235,266,297,49,18) end if c if(i.eq.24)then call cycle(iclr,220,251,282,34,3) call cycle(iclr,239,270,301,53,22) call cycle(iclr,248,279,310,62,31) call cycle(iclr,247,278,309,61,30) call cycle(iclr,234,265,296,48,17) end if c if(i.eq.25)then call cycle(iclr,157,161,165,169,173) call cycle(iclr,158,162,166,170,174) call cycle(iclr,159,163,167,171,175) call cycle(iclr,160,164,168,172,176) call cycle(iclr,177,179,181,183,185) call cycle(iclr,178,180,182,184,186) call cycle(iclr,204,200,196,192,188) call cycle(iclr,205,201,197,193,189) call cycle(iclr,206,202,198,194,190) call cycle(iclr,207,203,199,195,191) call cycle(iclr,216,214,212,210,208) call cycle(iclr,217,215,213,211,209) c i1=63 i2=125 i3=94 i4=342 i5=311 do 1 iii=1,31 call cycle(iclr,i1,i2,i3,i4,i5) i1=i1+1 i2=i2+1 i3=i3+1 i4=i4+1 i5=i5+1 1 continue c i1=1 i2=32 i3=280 i4=249 i5=218 do 2 iii=1,31 call cycle(iclr,i1,i2,i3,i4,i5) i1=i1+1 i2=i2+1 i3=i3+1 i4=i4+1 i5=i5+1 2 continue c ctemp=cname(3) cname(3)=cname(2) cname(2)=cname(7) cname(7)=cname(8) cname(8)=cname(4) cname(4)=ctemp ctemp=cname(5) cname(5)=cname(9) cname(9)=cname(10) cname(10)=cname(11) cname(11)=cname(6) cname(6)=ctemp end if c if(i.eq.26)then call cycle(iclr,64,68,72,76,80) call cycle(iclr,65,69,73,77,81) call cycle(iclr,66,70,74,78,82) call cycle(iclr,67,71,75,79,83) call cycle(iclr,84,86,88,90,92) call cycle(iclr,85,87,89,91,93) call cycle(iclr,297,293,289,285,281) call cycle(iclr,298,294,290,286,282) call cycle(iclr,299,295,291,287,283) call cycle(iclr,300,296,292,288,284) call cycle(iclr,309,307,305,303,301) call cycle(iclr,310,308,306,304,302) c call cycle(iclr,1,125,156,311,218) i1=2 i2=142 i3=161 i4=320 i5=235 do 3 iii=1,20 call cycle(iclr,i1,i2,i3,i4,i5) i1=i1+1 i2=i2+1 if(i2.gt.145)i2=126 i3=i3+1 if(i3.gt.176)i3=157 i4=i4+1 if(i4.gt.331)i4=312 i5=i5+1 if(i5.gt.238)i5=219 3 continue c i1=22 i2=154 i3=179 i4=336 i5=247 do 4 iii=1,10 call cycle(iclr,i1,i2,i3,i4,i5) i1=i1+1 i2=i2+1 if(i2.gt.155)i2=146 i3=i3+1 if(i3.gt.186)i3=177 i4=i4+1 if(i4.gt.341)i4=332 i5=i5+1 if(i5.gt.248)i5=239 4 continue c call cycle(iclr,32,94,342,249,187) i1=33 i2=107 i3=351 i4=262 i5=200 do 5 iii=1,20 call cycle(iclr,i1,i2,i3,i4,i5) i1=i1+1 i2=i2+1 if(i2.gt.114)i2=95 i3=i3+1 if(i3.gt.362)i3=343 i4=i4+1 if(i4.gt.269)i4=250 i5=i5+1 if(i5.gt.207)i5=188 5 continue c i1=53 i2=121 i3=367 i4=276 i5=214 do 6 iii=1,10 call cycle(iclr,i1,i2,i3,i4,i5) i1=i1+1 i2=i2+1 if(i2.gt.124)i2=115 i3=i3+1 if(i3.gt.372)i3=363 i4=i4+1 if(i4.gt.279)i4=270 i5=i5+1 if(i5.gt.217)i5=208 6 continue c ctemp=cname(3) cname(3)=cname(5) cname(5)=cname(9) cname(9)=cname(7) cname(7)=cname(1) cname(1)=ctemp ctemp=cname(6) cname(6)=cname(12) cname(12)=cname(10) cname(10)=cname(8) cname(8)=cname(4) cname(4)=ctemp end if c 7 continue c return end c subroutine cycle(iclr,i1,i2,i3,i4,i5) integer iclr(372) c temp=iclr(i5) iclr(i5)=iclr(i4) iclr(i4)=iclr(i3) iclr(i3)=iclr(i2) iclr(i2)=iclr(i1) iclr(i1)=temp c return end c subroutine fclr(fx,fy,fz,nx,ny,nz,theta,pi,tilex,tiley,sign) real fx(12,5),fy(12,5),fz(12,5),nx(12),ny(12),nz(12), > tilex(372,5),tiley(372,5),x(45),y(45) c wx=cos(theta*pi/180.0) wy=0.0 wz=sin(theta*pi/180.0) c if(sign.gt.0.0)itile=0 if(sign.lt.0.0)itile=186 c do 2 i=1,12 dot=wx*nx(i)+wy*ny(i)+wz*nz(i) if(sign*dot.gt.0.0)then x(1)=fy(i,1) y(1)=fz(i,1)*cos(theta*pi/180.0)-fx(i,1)*sin(theta*pi/180.0) x(2)=fy(i,2) y(2)=fz(i,2)*cos(theta*pi/180.0)-fx(i,2)*sin(theta*pi/180.0) x(3)=fy(i,3) y(3)=fz(i,3)*cos(theta*pi/180.0)-fx(i,3)*sin(theta*pi/180.0) x(4)=fy(i,4) y(4)=fz(i,4)*cos(theta*pi/180.0)-fx(i,4)*sin(theta*pi/180.0) x(5)=fy(i,5) y(5)=fz(i,5)*cos(theta*pi/180.0)-fx(i,5)*sin(theta*pi/180.0) c a1=0.2375 b1=1.0-a1 a2=0.475 b2=1.0-a2 c m1=4 m2=5 n=6 x(n)=b1*x(m1)+a1*x(m2) y(n)=b1*y(m1)+a1*y(m2) x(n+1)=b2*x(m1)+a2*x(m2) y(n+1)=b2*y(m1)+a2*y(m2) x(n+2)=a2*x(m1)+b2*x(m2) y(n+2)=a2*y(m1)+b2*y(m2) x(n+3)=a1*x(m1)+b1*x(m2) y(n+3)=a1*y(m1)+b1*y(m2) c m1=5 m2=1 n=n+4 x(n)=b1*x(m1)+a1*x(m2) y(n)=b1*y(m1)+a1*y(m2) x(n+1)=b2*x(m1)+a2*x(m2) y(n+1)=b2*y(m1)+a2*y(m2) x(n+2)=a2*x(m1)+b2*x(m2) y(n+2)=a2*y(m1)+b2*y(m2) x(n+3)=a1*x(m1)+b1*x(m2) y(n+3)=a1*y(m1)+b1*y(m2) c m1=1 m2=2 n=n+4 x(n)=b1*x(m1)+a1*x(m2) y(n)=b1*y(m1)+a1*y(m2) x(n+1)=b2*x(m1)+a2*x(m2) y(n+1)=b2*y(m1)+a2*y(m2) x(n+2)=a2*x(m1)+b2*x(m2) y(n+2)=a2*y(m1)+b2*y(m2) x(n+3)=a1*x(m1)+b1*x(m2) y(n+3)=a1*y(m1)+b1*y(m2) c m1=2 m2=3 n=n+4 x(n)=b1*x(m1)+a1*x(m2) y(n)=b1*y(m1)+a1*y(m2) x(n+1)=b2*x(m1)+a2*x(m2) y(n+1)=b2*y(m1)+a2*y(m2) x(n+2)=a2*x(m1)+b2*x(m2) y(n+2)=a2*y(m1)+b2*y(m2) x(n+3)=a1*x(m1)+b1*x(m2) y(n+3)=a1*y(m1)+b1*y(m2) c m1=3 m2=4 n=n+4 x(n)=4.0*x(m1)+x(m2) y(n)=4.0*y(m1)+y(m2) x(n)=b1*x(m1)+a1*x(m2) y(n)=b1*y(m1)+a1*y(m2) x(n+1)=b2*x(m1)+a2*x(m2) y(n+1)=b2*y(m1)+a2*y(m2) x(n+2)=a2*x(m1)+b2*x(m2) y(n+2)=a2*y(m1)+b2*y(m2) x(n+3)=a1*x(m1)+b1*x(m2) y(n+3)=a1*y(m1)+b1*y(m2) c call insct(x,y,26,25,10,6,21) call insct(x,y,27,25,10,7,20) call insct(x,y,28,25,10,8,15) call insct(x,y,29,25,10,9,14) call insct(x,y,30,9,14,11,24) call insct(x,y,31,9,14,12,19) call insct(x,y,32,9,14,13,18) call insct(x,y,33,13,18,8,15) call insct(x,y,34,13,18,16,23) call insct(x,y,35,13,18,17,22) call insct(x,y,36,17,22,12,19) call insct(x,y,37,17,22,20,7) call insct(x,y,38,17,22,6,21) call insct(x,y,39,21,6,23,16) call insct(x,y,40,21,6,24,11) call insct(x,y,41,24,11,7,20) call insct(x,y,42,8,15,11,24) call insct(x,y,43,8,15,12,19) call insct(x,y,44,12,19,16,23) call insct(x,y,45,16,23,7,20) c call scale(x,y,sign) c itile=itile+1 tilex(itile,1)=x(41) tiley(itile,1)=y(41) tilex(itile,2)=x(42) tiley(itile,2)=y(42) tilex(itile,3)=x(43) tiley(itile,3)=y(43) tilex(itile,4)=x(44) tiley(itile,4)=y(44) tilex(itile,5)=x(45) tiley(itile,5)=y(45) c call tile(tilex,tiley,x,y,itile,1,14,32,13) call tile(tilex,tiley,x,y,itile,14,15,33,32) call tile(tilex,tiley,x,y,itile,15,16,34,33) call tile(tilex,tiley,x,y,itile,16,17,35,34) call tile(tilex,tiley,x,y,itile,17,2,18,35) call tile(tilex,tiley,x,y,itile,18,19,36,35) call tile(tilex,tiley,x,y,itile,19,20,37,36) call tile(tilex,tiley,x,y,itile,20,21,38,37) call tile(tilex,tiley,x,y,itile,21,3,22,38) call tile(tilex,tiley,x,y,itile,22,23,39,38) call tile(tilex,tiley,x,y,itile,23,24,40,39) call tile(tilex,tiley,x,y,itile,24,25,26,40) call tile(tilex,tiley,x,y,itile,25,4,6,26) call tile(tilex,tiley,x,y,itile,6,7,27,26) call tile(tilex,tiley,x,y,itile,7,8,28,27) call tile(tilex,tiley,x,y,itile,8,9,29,28) call tile(tilex,tiley,x,y,itile,9,5,10,29) call tile(tilex,tiley,x,y,itile,10,11,30,29) call tile(tilex,tiley,x,y,itile,11,12,31,30) call tile(tilex,tiley,x,y,itile,12,13,32,31) call tile(tilex,tiley,x,y,itile,31,32,33,43) call tile(tilex,tiley,x,y,itile,33,34,44,43) call tile(tilex,tiley,x,y,itile,34,35,36,44) call tile(tilex,tiley,x,y,itile,44,36,37,45) call tile(tilex,tiley,x,y,itile,45,37,38,39) call tile(tilex,tiley,x,y,itile,39,40,41,45) call tile(tilex,tiley,x,y,itile,41,40,26,27) call tile(tilex,tiley,x,y,itile,41,27,28,42) call tile(tilex,tiley,x,y,itile,42,28,29,30) call tile(tilex,tiley,x,y,itile,42,30,31,43) c end if 2 continue c return end c subroutine tile(tilex,tiley,x,y,itile,i1,i2,i3,i4) real tilex(372,5),tiley(372,5),x(45),y(45) c itile=itile+1 tilex(itile,1)=x(i1) tiley(itile,1)=y(i1) tilex(itile,2)=x(i2) tiley(itile,2)=y(i2) tilex(itile,3)=x(i3) tiley(itile,3)=y(i3) tilex(itile,4)=0.5*(x(i3)+x(i4)) tiley(itile,4)=0.5*(y(i3)+y(i4)) tilex(itile,5)=x(i4) tiley(itile,5)=y(i4) c return end c subroutine insct(x,y,n,n1,n2,n3,n4) real x(45),y(45) c xa=x(n1) ya=y(n1) xb=x(n2) yb=y(n2) xc=x(n3) yc=y(n3) xd=x(n4) yd=y(n4) call lines(xa,ya,xb,yb,xc,yc,xd,yd,xint,yint) x(n)=xint y(n)=yint c return end c subroutine lines(xa,ya,xb,yb,xc,yc,xd,yd,xint,yint) a=xd-xc b=xa-xb c=yd-yc d=ya-yb r1=xa-xc r2=ya-yc s=(d*r1-b*r2)/(a*d-b*c) xint=xc+s*(xd-xc) yint=yc+s*(yd-yc) return end c subroutine scale(x,y,sign) real x(45),y(45) c do 1 i=1,45 if(sign.gt.0.0)then x(i)=410.0+85.0*x(i) y(i)=560.0+85.0*y(i) else x(i)=410.0+85.0*x(i) y(i)=280.0+85.0*y(i) end if 1 continue return end c subroutine tclr(tilex,tiley,iclr) real tilex(372,5),tiley(372,5) integer iclr(372) c c do 1 i=1,372 write(1,*)tilex(i,1),tiley(i,1),' moveto' write(1,*)tilex(i,2),tiley(i,2),' lineto' write(1,*)tilex(i,3),tiley(i,3),' lineto' write(1,*)tilex(i,4),tiley(i,4),' lineto' write(1,*)tilex(i,5),tiley(i,5),' lineto' write(1,*)' closepath' n=iclr(i) call color(n) write(1,*)' fill' 1 continue 2 continue c return end c subroutine frame(tilex,tiley) real tilex(372,5),tiley(372,5) c do 1 i=1,372 write(1,*)tilex(i,1),tiley(i,1),' moveto' write(1,*)tilex(i,2),tiley(i,2),' lineto' write(1,*)tilex(i,3),tiley(i,3),' lineto' write(1,*)tilex(i,4),tiley(i,4),' lineto' write(1,*)tilex(i,5),tiley(i,5),' lineto' write(1,*)' closepath' call color(99) write(1,*)' stroke' 1 continue 2 continue c return end c subroutine color(n) c if(n.eq.12)write(1,*)' 0.75 0.4 1 sethsbcolor' if(n.eq.2)write(1,*)' 0 1 1 sethsbcolor' if(n.eq.10)write(1,*)' 1 1 1 setrgbcolor' if(n.eq.4)write(1,*)' 0.333 1 1 sethsbcolor' if(n.eq.5)write(1,*)' 0.1 1 1 sethsbcolor' if(n.eq.7)write(1,*)' 0.55 1 1 sethsbcolor' if(n.eq.1)write(1,*)' 0.75 1 1 sethsbcolor' if(n.eq.11)write(1,*)' 0.35 0.35 0.35 setrgbcolor' if(n.eq.3)write(1,*)' 0.167 1 1 sethsbcolor' if(n.eq.8)write(1,*)' 0.333 1 0.5 sethsbcolor' if(n.eq.9)write(1,*)' 0.1 1 0.6 sethsbcolor' if(n.eq.6)write(1,*)' 0.667 1 1 sethsbcolor' if(n.eq.44)write(1,*)' 1 1 1 setrgbcolor' if(n.eq.99)write(1,*)' 0 0 0 setrgbcolor' c return end c subroutine vrtx(vx,vy,vz,pi) real vx(20),vy(20),vz(20) cost=cos(72.0*pi/180.0) sint=sin(72.0*pi/180.0) cost2=cos(36.0*pi/180.0) sint2=sin(36.0*pi/180.0) c vx(1)=-0.5/sin(36.0*pi/180.0) vy(1)=0.0 vz(1)=0.0 do 1 i=2,5 vx(i)=cost*vx(i-1)-sint*vy(i-1) vy(i)=sint*vx(i-1)+cost*vy(i-1) vz(i)=0.0 1 continue c alpha=cos(108.0*pi/180.0)/cos(54.0*pi/180.0) dz1=sqrt(1.0-alpha**2) vx(6)=vx(1)+alpha vy(6)=0.0 vz(6)=dz1 do 2 i=7,10 vx(i)=cost*vx(i-1)-sint*vy(i-1) vy(i)=sint*vx(i-1)+cost*vy(i-1) vz(i)=vz(6) 2 continue c dz2=dz1*cos(54.0*pi/180.0)/sin(72.0*pi/180.0) vx(11)=cost2*vx(6)-sint2*vy(6) vy(11)=sint2*vx(6)+cost2*vy(6) vz(11)=dz1+dz2 do 3 i=12,15 vx(i)=cost*vx(i-1)-sint*vy(i-1) vy(i)=sint*vx(i-1)+cost*vy(i-1) vz(i)=vz(11) 3 continue c vx(16)=cost2*vx(1)-sint2*vy(1) vy(16)=sint2*vx(1)+cost2*vy(1) vz(16)=2.0*dz1+dz2 do 4 i=17,20 vx(i)=cost*vx(i-1)-sint*vy(i-1) vy(i)=sint*vx(i-1)+cost*vy(i-1) vz(i)=vz(16) 4 continue c return end c subroutine faces(vx,vy,vz,fx,fy,fz,nx,ny,nz) real vx(20),vy(20),vz(20),fx(12,5),fy(12,5),fz(12,5), > nx(12),ny(12),nz(12) c call setfc(vx,vy,vz,fx,fy,fz,1,1,1) call setfc(vx,vy,vz,fx,fy,fz,1,2,2) call setfc(vx,vy,vz,fx,fy,fz,1,3,3) call setfc(vx,vy,vz,fx,fy,fz,1,4,4) call setfc(vx,vy,vz,fx,fy,fz,1,5,5) c call setfc(vx,vy,vz,fx,fy,fz,2,1,1) call setfc(vx,vy,vz,fx,fy,fz,2,2,6) call setfc(vx,vy,vz,fx,fy,fz,2,3,11) call setfc(vx,vy,vz,fx,fy,fz,2,4,7) call setfc(vx,vy,vz,fx,fy,fz,2,5,2) c call setfc(vx,vy,vz,fx,fy,fz,3,1,2) call setfc(vx,vy,vz,fx,fy,fz,3,2,7) call setfc(vx,vy,vz,fx,fy,fz,3,3,12) call setfc(vx,vy,vz,fx,fy,fz,3,4,8) call setfc(vx,vy,vz,fx,fy,fz,3,5,3) c call setfc(vx,vy,vz,fx,fy,fz,4,1,3) call setfc(vx,vy,vz,fx,fy,fz,4,2,8) call setfc(vx,vy,vz,fx,fy,fz,4,3,13) call setfc(vx,vy,vz,fx,fy,fz,4,4,9) call setfc(vx,vy,vz,fx,fy,fz,4,5,4) c call setfc(vx,vy,vz,fx,fy,fz,5,1,4) call setfc(vx,vy,vz,fx,fy,fz,5,2,9) call setfc(vx,vy,vz,fx,fy,fz,5,3,14) call setfc(vx,vy,vz,fx,fy,fz,5,4,10) call setfc(vx,vy,vz,fx,fy,fz,5,5,5) c call setfc(vx,vy,vz,fx,fy,fz,6,1,5) call setfc(vx,vy,vz,fx,fy,fz,6,2,10) call setfc(vx,vy,vz,fx,fy,fz,6,3,15) call setfc(vx,vy,vz,fx,fy,fz,6,4,6) call setfc(vx,vy,vz,fx,fy,fz,6,5,1) c call setfc(vx,vy,vz,fx,fy,fz,7,1,16) call setfc(vx,vy,vz,fx,fy,fz,7,2,17) call setfc(vx,vy,vz,fx,fy,fz,7,3,12) call setfc(vx,vy,vz,fx,fy,fz,7,4,7) call setfc(vx,vy,vz,fx,fy,fz,7,5,11) c call setfc(vx,vy,vz,fx,fy,fz,8,1,17) call setfc(vx,vy,vz,fx,fy,fz,8,2,18) call setfc(vx,vy,vz,fx,fy,fz,8,3,13) call setfc(vx,vy,vz,fx,fy,fz,8,4,8) call setfc(vx,vy,vz,fx,fy,fz,8,5,12) c call setfc(vx,vy,vz,fx,fy,fz,9,1,18) call setfc(vx,vy,vz,fx,fy,fz,9,2,19) call setfc(vx,vy,vz,fx,fy,fz,9,3,14) call setfc(vx,vy,vz,fx,fy,fz,9,4,9) call setfc(vx,vy,vz,fx,fy,fz,9,5,13) c call setfc(vx,vy,vz,fx,fy,fz,10,1,19) call setfc(vx,vy,vz,fx,fy,fz,10,2,20) call setfc(vx,vy,vz,fx,fy,fz,10,3,15) call setfc(vx,vy,vz,fx,fy,fz,10,4,10) call setfc(vx,vy,vz,fx,fy,fz,10,5,14) c call setfc(vx,vy,vz,fx,fy,fz,11,1,20) call setfc(vx,vy,vz,fx,fy,fz,11,2,16) call setfc(vx,vy,vz,fx,fy,fz,11,3,11) call setfc(vx,vy,vz,fx,fy,fz,11,4,6) call setfc(vx,vy,vz,fx,fy,fz,11,5,15) c call setfc(vx,vy,vz,fx,fy,fz,12,1,20) call setfc(vx,vy,vz,fx,fy,fz,12,2,19) call setfc(vx,vy,vz,fx,fy,fz,12,3,18) call setfc(vx,vy,vz,fx,fy,fz,12,4,17) call setfc(vx,vy,vz,fx,fy,fz,12,5,16) c do 1 i=1,12 x1=fx(i,2)-fx(i,1) y1=fy(i,2)-fy(i,1) z1=fz(i,2)-fz(i,1) x2=fx(i,3)-fx(i,2) y2=fy(i,3)-fy(i,2) z2=fz(i,3)-fz(i,2) nx(i)=y1*z2-y2*z1 ny(i)=-x1*z2+x2*z1 nz(i)=x1*y2-x2*y1 1 continue c return end c subroutine setfc(vx,vy,vz,fx,fy,fz,i,j,k) real vx(20),vy(20),vz(20),fx(12,5),fy(12,5),fz(12,5) fx(i,j)=vx(k) fy(i,j)=vy(k) fz(i,j)=vz(k) return end c subroutine start(jclr,cname) integer jclr(12) character*15 cname(12) c x=40 z=800 write(1,*)'%!' write(1,*)' /Times-Roman findfont' write(1,*)' 14 scalefont setfont' z=z-40 write(1,*)x,z,' moveto' write(1,*)' (Rotate a face: ) show' z=z-20 write(1,*)x,z,' moveto' write(1,*)' ((outer layer, both layers) ) show' z=z-20 write(1,*)x,z,' moveto' write(1,*)' ( 1, 2 =',cname(jclr(1)),' ) show' z=z-20 write(1,*)x,z,' moveto' write(1,*)' ( 3, 4 =',cname(jclr(2)),' ) show' z=z-20 write(1,*)x,z,' moveto' write(1,*)' ( 5, 6 =',cname(jclr(3)),' ) show' z=z-20 write(1,*)x,z,' moveto' write(1,*)' ( 7, 8 =',cname(jclr(4)),' ) show' z=z-20 write(1,*)x,z,' moveto' write(1,*)' ( 9, 10 =',cname(jclr(5)),' ) show' z=z-20 write(1,*)x,z,' moveto' write(1,*)' ( 11, 12 =',cname(jclr(6)),' ) show' z=z-20 write(1,*)x,z,' moveto' write(1,*)' ( 13, 14 =',cname(jclr(7)),' ) show' z=z-20 write(1,*)x,z,' moveto' write(1,*)' ( 15, 16 =',cname(jclr(8)),' ) show' z=z-20 write(1,*)x,z,' moveto' write(1,*)' ( 17, 18 =',cname(jclr(9)),' ) show' z=z-20 write(1,*)x,z,' moveto' write(1,*)' ( 19, 20 =',cname(jclr(10)),' ) show' z=z-20 write(1,*)x,z,' moveto' write(1,*)' ( 21, 22 =',cname(jclr(11)),' ) show' z=z-20 write(1,*)x,z,' moveto' write(1,*)' ( 23, 24 =',cname(jclr(12)),' ) show' c z=z-40 write(1,*)x,z,' moveto' write(1,*)' (Rotate the entire dodecahedron:) show' z=z-20 write(1,*)x,z,' moveto' write(1,*)' ( 25 = about the vertical axis) show' z=z-20 write(1,*)x,z,' moveto' write(1,*)' ( 26 = about the 3-21 axis) show' c z=z-40 write(1,*)x,z,' moveto' write(1,*)' (All rotations are counterclockwise.) show' z=z-20 write(1,*)x,z,' moveto' write(1,*)' (Rotations of back faces appear clockwise.) show' c x=300 z=515 write(1,*)x,z,' moveto' write(1,*)' (Above: Direct view of the front faces.) show' z=z-20 write(1,*)x,z,' moveto' write(1,*)' (Below: Mirror view of the back faces.) show' c return end c function ran0(iseed) if(iseed.eq.0)iseed=178544878 m=2147483647 n=16807 k=iseed/127773 iseed=n*(iseed-k*127773)-k*2836 if(iseed.lt.0)iseed=iseed+m ran0=float(iseed)/float(m) return end