rem The Ball Room ....... Rev 4.1 rem A J Tooth // 1st-7th February 2004 on error if (err=17) then quit rem Preamble himem=lomem + 10000000 *FLOAT64 proc_fullscreen(22) rem PART ONE rem ============================================================== Xmax%=512 : Ymax%=512 : rem Grid size Xscl%=1024 : Yscl%=768 : rem Screen scaling Size%=(Xmax%+1)*(Ymax%+1)*3 : rem Size in Bytes of each wall-file rem Use single-byte r/g/b arrays, similar to .bmp format rem Enables easy conversion of .bmp to this format if needed later dim Box1% Size%, Box2% Size%, Box3% Size%, Box4% Size% dim re% 0, gr% 0, bl% 0, Ref% 3, r% 0, g% 0, b% 0, cr% 0, cg% 0, cb% 0 rem Intro Screen proc_intro rem Setup Walls proc_walls rem Show Pattern proc_showpat a$=get$ : cls rem PART TWO - THE ROOM rem ============================================================== rem Parameters and Set Pxpos%=Xmax%/2 : Pypos%=Ymax%-(2.5)*Ymax% : h%=300 : rem Position of Person rem Line of Sight Initial Angles thF=10 : phF=5 rem Set Background Colour Skr%=0 : Skg%=0 : Skb%=70 : colour 134,Skr%,Skg%,Skb% 400 rem REPEAT Line gcol 134 : clg case a$ of when "u" : h%=int(h%*1.5) : if h%>1000 then h%=1000 when "d" : h%=int(h%/1.5) when "l" : Pxpos%=int(Pxpos%/1.5) when "r" : Pxpos%=int(Pxpos%*1.5) : if Pxpos%>700 then Pxpos%=700 when "f" : Pypos%=Ymax%+int((Pypos%-Ymax%)/1.5) when "b" : Pypos%=Ymax%+int((Pypos%-Ymax%)*1.5) : if Pypos%<-1500 then Pypos%=-1500 when chr$(136) : phF=phF+2 : if phF>=20 then phF=20 when chr$(137) : phF=phF-2 : if phF<=-20 then phF=-20 when chr$(138) : thF=thF+2 : if thF>=45 then thF=45 when chr$(139) : thF=thF-2 : if thF<=-10 then thF=-10 otherwise endcase Pts%=1024 : rem Range points Dg=0.45 : rem Reflection degredation factor origin 0,0 ThF=rad(thF) : PhF=rad(phF) rem Line of Sight Unit Vector d=(d1,d2,d3) d1=-sin(PhF) d2=(cos(ThF))*cos(PhF) d3=-(sin(ThF))*cos(PhF) rem Display the Room proc_room rem PART THREE - THE BALLs rem ============================================================== rem Vector for Centre of Ball 1 c=(c1,c2,c3) c1%=50 : c2%=462 : c3%=50 : rd%=50 : rem Ball Radius=50 Dg=0.9 Bcolr%=0 : Bcolg%=0 : Bcolb%=0 : CRef%=127 rem Draws a Black Ball proc_ball(c1%,c2%,c3%,rd%,15*rd%) rem Vector for Centre of Ball 2 c1%=250 : c2%=380 : c3%=100 : rd%=100 : rem Ball Radius=100 rem Draws another Black Ball proc_ball(c1%,c2%,c3%,rd%,15*rd%) a$=get$ if (a$="u" or a$="d" or a$="l" or a$="r" or a$="b" or a$="f") then goto 400 if (a$=chr$(136) or a$=chr$(137) or a$=chr$(138) or a$=chr$(139)) then goto 400 quit end rem End of Program +++++++++++++++++++++++++++++++++++++++++++++ rem Set up use of Full Screen def proc_fullscreen(N%) sys "GetSystemMetrics", 0 to xscreen% sys "GetSystemMetrics", 1 to yscreen% sys "SetWindowLong",@hwnd%,-16,&16000000 sys "SetWindowPos",@hwnd%,-1,0,0,xscreen%,yscreen%,0 mode N% mouse off : off : rem Turns off the Mouse Pointer and the Cursor endproc rem =============================================================== rem Setup Walls def proc_walls local x%,y%,cl%,Ind print tab(20,30);"Press -s- for a smooth wall pattern, any other key for solid ones." b$=get$ : print tab(20,32);"Calculating ... " sys "GetCurrentProcess" to hprocess% sys "SetPriorityClass", hprocess%, &100 Red%=70+rnd(100) : Gre%=70+rnd(100) : Blu%=70+rnd(100) for x%=0 to Xmax% for y%=0 to Ymax% Ind=(sin(20*pi*x%/Xmax%))*(sin(20*pi*y%/Ymax%)) if Ind<=0 then Clr%=0 : Clg%=0 : Clb%=0 else if b$="s" then Clr%=int(Red%*Ind) Clg%=int(Gre%*Ind) Clb%=int(Blu%*Ind) else Clb%=0 Clg%=0 Clr%=200 endif endif !Ref%=(y%*3*(Xmax%+1)) + 3*x% Box1%?(!Ref%) =Clr% Box1%?(!Ref%+1)=Clg% Box1%?(!Ref%+2)=Clb% Box2%?(!Ref%) =Clb% Box2%?(!Ref%+1)=Clr% Box2%?(!Ref%+2)=Clg% if a$="s" then Box3%?(!Ref%) =Clg% Box3%?(!Ref%+1)=Clb% Box3%?(!Ref%+2)=Clr% else Box3%?(!Ref%) =Clr% Box3%?(!Ref%+1)=Clr% Box3%?(!Ref%+2)=Clb% endif Box4%?(!Ref%) =Clb% Box4%?(!Ref%+1)=Clg% Box4%?(!Ref%+2)=Clr% next y% next x% sys "GetCurrentProcess" to hprocess% sys "SetPriorityClass", hprocess%, &20 cls endproc rem =============================================================== rem Show Pattern def proc_showpat local a%,c% sys "GetCurrentProcess" to hprocess% sys "SetPriorityClass", hprocess%, &100 ?g%=0 : ?b%=0 origin 800,300 print tab(75,3);"UNDERLYING WALL PATTERN." colour 2:print tab(5,15);"Press any key to continue." colour 3:print tab(5,30);"After the first picture has completed, press ... " print tab(15,31);"u = upwards" print tab(15,32);"d = downwards" print tab(15,33);"l = move left" print tab(15,34);"r = move right" print tab(15,35);"f = move forwards" print tab(15,36);"b = move backwards" print tab(5,38);"Use the ARROW keys to move the view angles." for a%=0 to Xmax% for c%=0 to Ymax% !Ref%=(c%*3*(Xmax%+1)) + 3*a% ?r%=Box1%?(!Ref%) ?g%=Box1%?(!Ref%+1) ?b%=Box1%?(!Ref%+2) vdu 19,10,16,?r%,?g%,?b% : gcol 10 plot 2*a%,2*c% next c% next a% sys "GetCurrentProcess" to hprocess% sys "SetPriorityClass", hprocess%, &20 endproc rem =============================================================== rem Display the Room def proc_room local t%,p%,Th,Ph,mu,nu,rho Hts%=Pts%/2 for t%=0 to Hts% sys "GetCurrentProcess" to hprocess% sys "SetPriorityClass", hprocess%, &100 Th=rad(10 - (20*t%/Hts%)) : rem Range +/- of Azimuthal Angle for p%=0 to Pts% Ph=rad(10 - (20*p%/Pts%)) : rem Range +/- of Horizontal Angle rem Field of View Unit Vector s=(s1,s2,s3) s1=d1*cos(Ph) - d2*sin(Ph) s2=d1*cos(Th)*sin(Ph) + d2*cos(Th)*cos(Ph) + d3*sin(Th) s3=-d1*sin(Th)*sin(Ph) - d2*sin(Th)*cos(Ph) + d3*cos(Th) rem Floor proc_floor rem Back Wall if s2>0 then mu=(Ymax%-Pypos%)/s2 xt2%=Pxpos% + int(mu*s1) zt2%=h% + int(mu*s3) if xt2%>0 and xt2%<=Xmax% and zt2%>0 and zt2%<=Ymax% then !Ref%=(zt2%*3*(Xmax%+1)) + 3*xt2% ?re%=Box2%?(!Ref%) ?gr%=Box2%?(!Ref%+1) ?bl%=Box2%?(!Ref%+2) vdu 19,10,16,?re%,?gr%,?bl% : gcol 10 hor%=int(Xscl%*p%/Pts%) : ver%=int(Yscl%*t%/Hts%) plot 2*hor%,2*ver% endif endif rem Left Wall if s1<0 then nu=-Pxpos%/s1 xt3%=Pypos% + int(nu*s2) zt3%=h% + int(nu*s3) if xt3%>0 and xt3%<=Xmax% and zt3%>0 and zt3%<=Ymax% then !Ref%=(zt3%*3*(Xmax%+1)) + 3*xt3% ?re%=Box3%?(!Ref%) ?gr%=Box3%?(!Ref%+1) ?bl%=Box3%?(!Ref%+2) vdu 19,10,16,?re%,?gr%,?bl% : gcol 10 hor%=int(Xscl%*p%/Pts%) : ver%=int(Yscl%*t%/Hts%) plot 2*hor%,2*ver% endif endif rem Right Wall if s1>0 then rho=(Xmax%-Pxpos%)/s1 xt4%=Pypos% + int(rho*s2) zt4%=h% + int(rho*s3) if xt4%>0 and xt4%<=Xmax% and zt4%>0 and zt4%<=Ymax% then !Ref%=(zt4%*3*(Xmax%+1)) + 3*xt4% ?re%=Box4%?(!Ref%) ?gr%=Box4%?(!Ref%+1) ?bl%=Box4%?(!Ref%+2) vdu 19,10,16,?re%,?gr%,?bl% : gcol 10 hor%=int(Xscl%*p%/Pts%) : ver%=int(Yscl%*t%/Hts%) plot 2*hor%,2*ver% endif endif next p% sys "GetCurrentProcess" to hprocess% sys "SetPriorityClass", hprocess%, &20 a$=inkey$(1) next t% endproc rem =============================================================== rem Floor with Reflections def proc_floor local lam,blam,rlam,llam,xt%,yt%,Xt%,Yt% ?re%=0 : ?gr%=0 : ?bl%=0 if s3<0 then lam=-h%/s3 xt%=Pxpos% + int(lam*s1) yt%=Pypos% + int(lam*s2) if xt%>0 and xt%<=Xmax% and yt%>0 and yt%<=Ymax% then !Ref%=(yt%*3*(Xmax%+1)) + 3*xt% ?re%=?re%+Box1%?(!Ref%) ?gr%=?gr%+Box1%?(!Ref%+1) ?bl%=?bl%+Box1%?(!Ref%+2) r1=s1 : r2=s2 : r3=-s3 rem Back wall reflection if r2>0 then blam=(Ymax%-yt%)/r2 Xt%=xt%+blam*r1 Yt%=blam*r3 if Xt%>0 and Xt%<=Xmax% and Yt%>0 and Yt%<=Ymax% then !Ref%=(Yt%*3*(Xmax%+1)) + 3*Xt% ?re%=?re%+int(Dg*(Box2%?(!Ref%))) ?gr%=?gr%+int(Dg*(Box2%?(!Ref%+1))) ?bl%=?bl%+int(Dg*(Box2%?(!Ref%+2))) endif endif rem Left wall reflection if r1<0 then llam=-xt%/r1 Xt%=yt%+llam*r2 Yt%=llam*r3 if Xt%>0 and Xt%<=Xmax% and Yt%>0 and Yt%<=Ymax% then !Ref%=(Yt%*3*(Xmax%+1)) + 3*Xt% if ?re%=0 then ?re%=?re%+int(Dg*(Box3%?(!Ref%))) ?gr%=?gr%+int(Dg*(Box3%?(!Ref%+1))) ?bl%=?bl%+int(Dg*(Box3%?(!Ref%+2))) endif endif rem Right wall reflection if r1>0 then rlam=(Xmax%-xt%)/r1 Xt%=yt%+rlam*r2 Yt%=rlam*r3 if Xt%>0 and Xt%<=Xmax% and Yt%>0 and Yt%<=Ymax% then !Ref%=(Yt%*3*(Xmax%+1)) + 3*Xt% ?re%=?re%+int(Dg*(Box4%?(!Ref%))) ?gr%=?gr%+int(Dg*(Box4%?(!Ref%+1))) ?bl%=?bl%+int(Dg*(Box4%?(!Ref%+2))) endif endif vdu 19,10,16,?re%,?gr%,?bl% : gcol 10 hor%=int(Xscl%*p%/Pts%) : ver%=int(Yscl%*t%/Hts%) plot 2*hor%,2*ver% endif endif endproc rem =============================================================== rem Draws a Black Ball def proc_ball(C1%,C2%,C3%,Rd%,Qts%) local P,R,R1,R2,R3,t,p%,alp,bet,r1,r2,r3,Xt%,Yt%,Zt%,Sr local R1b,R2b,R3b,Th,Ph,sgam,csa,csb,csc local eps,beps,leps,reps rem Line of Sight Unit Vector to Centre of Ball (csa,csb,csc) csa=C1%-Pxpos% : csb=C2%-Pypos% : csc=C3%-h% P=sqr(csa*csa + csb*csb + csc*csc) rem These are Direction Cosines csa=csa/P : csb=csb/P : csc=csc/P ThC=acs(csb/sqr(csb*csb+csc*csc)) : ThO=(ThC-ThF) PhC=acs(csb/sqr(csa*csa+csb*csb)) : PhO=(PhC-PhF) Sqts%=int(0.7*Qts%) SubQ%=int(0.95*Sqts%) for t%=0 to SubQ% sys "GetCurrentProcess" to hprocess% sys "SetPriorityClass", hprocess%, &100 alp=pi*(Sqts%-t%)/(2*Sqts%) rem R is Line of Sight vector to point on Ball for (alp,0) i.e. bet=0 R1=P*csa + Rd%*cos(alp) R2=P*csb - Rd%*sin(alp) R3=P*csc R=sqr(R1*R1 + R2*R2 + R3*R3) sgam=Rd%*(cos(alp))/R : rem Sine of Gamma rem Default colouring ?re%=0 : ?gr%=0 : ?bl%=0 for p%=0 to Qts% rem Computational Error Trapping on error local goto 5050 bet=2*pi*p%/Qts% rem (r1,r2,r3) is the unit outward NORMAL vector to the Ball r1=cos(alp)*cos(bet) : r2=-sin(alp) : r3=cos(alp)*sin(bet) rem Rotated parallel to the LoS Vector rr1= r1*cos(PhC) - r2*sin(PhC) rr2= r1*cos(ThC)*sin(PhC) + r2*cos(ThC)*cos(PhC) + r3*sin(ThC) rr3=-r1*sin(ThC)*sin(PhC) - r2*sin(ThC)*cos(PhC) + r3*cos(ThC) rem Rb is Line of Sight vector of point on Ball for any (alp,bet) R1b=P*csa + Rd%*rr1 R2b=P*csb + Rd%*rr2 R3b=P*csc + Rd%*rr3 Rbdotr=(R1b*rr1 + R2b*rr2 + R3b*rr3) rem Components of the reflected Line of Sight vector Sr1=R1b - (2*Rbdotr*rr1) Sr2=R2b - (2*Rbdotr*rr2) Sr3=R3b - (2*Rbdotr*rr3) Sr=sqr(Sr1*Sr1 + Sr2*Sr2 + Sr3*Sr3) Sr1=Sr1/Sr : Sr2=Sr2/Sr : Sr3=Sr3/Sr : rem Normalised reflection vector vdu 19,5,16,Skr%,Skg%,Skb% : gcol 5 rem Floor Reflections if Sr3<0 then eps=-(h%+R3b)/Sr3 Xt%=Pxpos% + int(R1b + eps*Sr1) Yt%=Pypos% + int(R2b + eps*Sr2) if Xt%>=0 and Xt%<=Xmax% and Yt%>=0 and Yt%<=Ymax% then !Ref%=(Yt%*3*(Xmax%+1)) + 3*Xt% ?re%=int(255*sqr((Box1%?(!Ref%))/255)) ?gr%=int(255*sqr((Box1%?(!Ref%+1))/255)) ?bl%=int(255*sqr((Box1%?(!Ref%+2))/255)) vdu 19,5,16,?re%,?gr%,?bl% : gcol 5 endif endif rem Back Wall Reflections if Sr2>0 then beps=(Ymax%-Pypos%-R2b)/Sr2 Xt%=Pxpos% + int(R1b + beps*Sr1) Zt%=h% + int(R3b + beps*Sr3) if Xt%>=0 and Xt%<=Xmax% and Zt%>=0 and Zt%<=Ymax% then !Ref%=(Zt%*3*(Xmax%+1)) + 3*Xt% ?re%=int(255*sqr((Box2%?(!Ref%))/255)) ?gr%=int(255*sqr((Box2%?(!Ref%+1))/255)) ?bl%=int(255*sqr((Box2%?(!Ref%+2))/255)) vdu 19,5,16,?re%,?gr%,?bl% : gcol 5 endif endif rem Left Wall Reflections if Sr1<0 then leps=(-Pxpos%-R1b)/Sr1 Xt%=Pypos% + int(R2b + leps*Sr2) Zt%=h% + int(R3b + leps*Sr3) if Xt%>=0 and Xt%<=Xmax% and Zt%>=0 and Zt%<=Ymax% then !Ref%=(Zt%*3*(Xmax%+1)) + 3*Xt% ?re%=int(255*sqr((Box3%?(!Ref%))/255)) ?gr%=int(255*sqr((Box3%?(!Ref%+1))/255)) ?bl%=int(255*sqr((Box3%?(!Ref%+2))/255)) vdu 19,5,16,?re%,?gr%,?bl% : gcol 5 endif endif rem Right Wall Reflections if Sr1>0 then reps=(Xmax%-Pxpos%-R1b)/Sr1 Xt%=Pypos% + int(R2b + reps*Sr2) Zt%=h% + int(R3b + reps*Sr3) if Xt%>=0 and Xt%<=Xmax% and Zt%>=0 and Zt%<=Ymax% then !Ref%=(Zt%*3*(Xmax%+1)) + 3*Xt% ?re%=int(255*sqr((Box4%?(!Ref%))/255)) ?gr%=int(255*sqr((Box4%?(!Ref%+1))/255)) ?bl%=int(255*sqr((Box4%?(!Ref%+2))/255)) vdu 19,5,16,?re%,?gr%,?bl% : gcol 5 endif endif rem Adjust Viewing Angle Xgam=sgam/sqr((sgam*sgam*sin(bet)*sin(bet)) +1) Th=asn(Xgam*sin(bet)) Ph=asn(Xgam*cos(bet)) rem Scale Viewing Angle and Plot the Reflected Colour or the Colour of the Ball hor%=int(Xscl%*(10-deg(PhO-Ph))/20) : ver%=int(Yscl%*(10-deg(ThO-Th))/20) move 2*hor%,2*ver% : draw 2*hor%,2*ver% 4610 next p% sys "GetCurrentProcess" to hprocess% sys "SetPriorityClass", hprocess%, &20 a$=inkey$(1) next t% endproc rem =============================================================== rem Intro def proc_intro Font$="Castellar," colour 6 for w%=0 to 30 Fs%=40-int(30*(w%/30)) cls command$="FONT "+Font$+str$(Fs%) oscli command$ print tab(10+w%,10);"The Ball Room" a$=inkey$(5) next w% for u%=1 to 5 Fs%=10+6*u% cls command$="FONT "+Font$+str$(Fs%) oscli command$ print tab(5,5);"The Ball Room" a$=inkey$(5) next u% a$=inkey$(100) *FONT Georgia,12 colour 3 endproc rem Traps Computational Range Errors ONLY 5050 if err=21 or err=23 or err=18 or err=20 or err=22 or err=24 then goto 4610 else restore error endif goto 4610