'******************************************************** '* * * VARIANT FOR TESTING * '* SPIDERP.BAS is a DeltaCad macro for producing an * '* "Azimutal Like", but DECLINING and INCLINING Sundial * '* with Longitude Correction and EOT correction * '* created by Valentin Hristov (valhrist@bas.bg) * '* who was inspired by Mac Oglesby to use * '* The North American Sundial Society DeltaCad programs * '* as tutorials (http://sundials.org). * '* The STYLE in this variant is POLAR! * '******************************************************** Option Explicit ' Force all variables to be declared before they are used. No adhoc variables Dim x,y,z,x0,y0,z0,x1,y1,z1,x2,y2,z2,x3,y3,z3,w As Double Dim xx1,yy1,xx2,yy2,xx3,yy3,xxx1,yyy1,xxx2,yyy2,xe,ye As Double Dim l,d,i,lr,dr,ir,sl,cl,sd,cd,si,ci,lon,cm,lc,lcr,slc,clc As Double Dim xN0,yN0,zN0,xNN0,yNN0,zNN0,lNN0 As Double Dim xNN,yNN,zNN,XZ0,yZ0,zZ0,xZZ0,yZZ0,zZZ0 As Double Dim xpr,ypr,zpr,lpr,xpr0,ypr0,zpr0,lpr0,xpr1,ypr1,zpr1,lpr1,xprn,yprn,zprn,lprn As Double Dim pi,d2r,r2d,h,ch,sh,hr,dm,dmr,dmm,t,g,gr,sg,cg As Double Dim alpha,beta,betar,gamma, gammar,m,m1,mm,radius As Double Dim ha,hac,hacr,shac,chac,dsr,sds,cds,index,phi,phir,phid As Double Dim decl(366),eot(366),spl(732) As Double Dim datetext(13),bm(13),outtext,ll,p As String Dim count,sw,cw,cs,beg1,beg2,end1,end2 As Integer Dim hhb,hhe,hhv As Boolean Dim lat As Double 'Dim ss,dd,ll As Integer 'Dim lat,dw,iw,ha,declmax As Double 'Dim alpha,beta,gamma,v,b,ts,M,mm,m1,radius,nN,cnN,snN,sN As Double 'Dim radius,flag,count,count1,count2,ss As Integer Dim action,button As String Dim cx,cy,xa,ya,xb,yb,hrad,wrad As Double Dim inputcorrect As boolean Dim filename As String Dim text1,text2,text3 As String Dim dx,dy As Double dcSetLineParms dcBLACK, dcSOLID, dcTHIN dcSetCircleParms dcBLACK, dcSOLID, dcTHIN 'Establish the 5 standard line thicknesses in thousands of an inch. dcSetDrawingData dcLineThin, .003 dcSetDrawingData dcLineNormal, .008 dcSetDrawingData dcLineThick, .012 dcSetDrawingData dcLineHeavy, .024 dcSetDrawingData dcLineWide, .048 'Maximize the window, close any existing drawing without saving, and start a new drawing. dcSetDrawingWindowMode dcMaximizeWin dcCloseWithoutSaving dcNew "" '************************************** 'Start of program init_constants Input_constants_of_sundial Angles Vectors Preparation Main 'DateLine 'Hours 'EquationOfTime Control 'End of program '************************************** 'Start of subroutines Sub Input_constants_of_sundial Begin Dialog CONSTANTS_INPUT 13,1,200,130, "Input data for the sundial" Text 15,0,300,10, "SPIDER DECLINED AND INCLINED SUNDIAL" Text 15,8,150,10, "with corrections for the latitude and the EOT" Text 15,20,150,10, "Place" Text 15,32,150,10, "Latitude (N is >0)" Text 15,44,150,10, "Longitude (E is >0)" Text 15,56,150,10, "Central meridian" Text 15,68,150,10, "Declination of the plane" Text 15,80,150,10, " (S=0, W=90, E=-90, N=180 or -180)" Text 15,92,150,10, "Inclination of the plane" Text 15,104,180,10, " (90 = vertical, from you < 90, towards you >90)" TextBox 88,20,99,10, .p TextBox 150,32,37,10, .l TextBox 150,44,37,10, .lon TextBox 150,56,37,10, .cm TextBox 150,68,37,10, .d TextBox 150,92,37,10, .i OKButton 82,116,37,12 End Dialog 'Initialize Dim prompt As constants_input 'prompt.p = "Blattleboro-Vevmont-USA" 'prompt.l = 42.85 'prompt.lon = -72.55 'prompt.cm = -75 'prompt.d = -46.56 'prompt.i = 90 prompt.p = "Lozen-Sofia-Bulgaria" prompt.l = 42.6 prompt.lon = 23.5 prompt.cm = 30 prompt.d = 180 prompt.i = 0 'prompt.p = "Test" 'prompt.l = 40 'prompt.lon = 30 'prompt.cm = 30 'prompt.d = 0 'prompt.i = 0 repeat_until_inputcorrect: 'label to return if input is not correct action = Dialog(prompt) 'get the input If test("l",prompt.l,-90,90) = false Then GoTo repeat_until_inputcorrect End If If test("lon",prompt.lon,-180,180) = false Then GoTo repeat_until_inputcorrect End If If test("cm",prompt.cm,-180,180) = false Then GoTo repeat_until_inputcorrect End If If test("d",prompt.d,-180,180) = false Then GoTo repeat_until_inputcorrect End If If test("i",prompt.i,0,180) = false Then GoTo repeat_until_inputcorrect End If 'Set program variables with input variables, angles in degrees p = prompt.p l = prompt.l lon = prompt.lon cm = prompt.cm d = prompt.d i = prompt.i End Sub Sub init_constants pi = 4 * Atn(1) d2r = pi/180 r2d = 180/pi dm = 23.43954 dmr = dm*d2r bm( 1)= 1 '1jan bm( 2)= 32 '1feb bm( 3)= 60 bm( 4)= 91 bm( 5)=121 bm( 6)=152 bm( 7)=182 bm( 8)=213 bm( 9)=244 bm(10)=274 bm(11)=305 bm(12)=335 '1dec bm(13)=366 '1jan for count=1 to 365 w=.017202792*(count-(cm-15)/360) decl(count)=.367402-23.275*cos(w+.178044)-.38506*cos(2*w+.0687076)-.16046*cos(3*w+.451301)+.00315469*cos(4*w+.876643) next count decl(366)=decl(1) for count=1 to 365 w=.017202792*(count-(cm-15)/360) eot(count)=.00884207-7.36034*cos(w+1.49487)+9.91068*cos(2*w-1.21808)-.306344*cos(3*w+1.82055)+.204774*Cos(4*w-.875115) next count eot(366)=eot(1) datetext( 1) = "jan" datetext( 2) = "feb" datetext( 3) = "mar" datetext( 4) = "apr" datetext( 5) = "may" datetext( 6) = "jun" datetext( 7) = "jul" datetext( 8) = "aug" datetext( 9) = "sep" datetext(10) = "oct" datetext(11) = "nov" datetext(12) = "dec" datetext(13) = "jan" End Sub Sub Angles lc=lon-cm 'longitude correction lcr=lc*d2r 'longitude correction in radians slc=sin(lcr) 'sin(longitude correction) clc=cos(lcr) 'cos(longitude correction) lr=l*d2r 'longitude in radians sl=sin(lr) 'sin(latitude) cl=cos(lr) 'cos(latitude) dr=d*d2r 'declination in radians sd=sin(dr) 'sin(declination) cd=cos(dr) 'cos(declination) ir=i*d2r 'inclination in radians si=sin(ir) 'sin(inclination) ci=cos(ir) 'cos(inclination) End Sub Sub Vectors 'Celestial North xN0=0 yN0=0 zN0=1 ' 0 hours without longitude correction xZ0=0 yZ0=-1 zZ0=0 ' 0 hours with longitude correction xZZ0=-slc yZZ0=-clc zZZ0=0 End Sub Sub Preparation dcCreateCircle 0,0,.02 x0=xN0 y0=yN0 z0=zN0 convert xNN0=x3 'Celestian N in new coordinates yNN0=y3 zNN0=z3 lNN0=Sqr(xNN0*xNN0+yNN0*yNN0) xNN=xNN0/lNN0 'Unit projection of N in the plane yNN=yNN0/lNN0 if zNN0<0 then cw=-1 else cw=1 'Clockwise flag if cw=1 then xpr=xNN0 ypr=yNN0 zpr=1+zNN0 else xpr=-xNN0 ypr=-yNN0 zpr=1-zNN0 end if lpr0=Sqr(xpr*xpr+ypr*ypr+zpr*zpr) xpr0=xpr/lpr0 'Unit vector for projection ypr0=ypr/lpr0 zpr0=zpr/lpr0 lpr1=Sqr(xpr*xpr+ypr*ypr) xpr1=xpr/lpr1 'Unit vector in the plane ypr1=ypr/lpr1 zpr1=0 if xpr1>=0 then betar=arcsin(ypr1) else if ypr1>=0 then betar=arccos(xpr1) else betar=-arccos(xpr1) end if end if beta=betar*r2d 'angle of the projection in the plane cg=xpr0*xpr1+ypr0*ypr1+zpr0*zpr1 'cos(gnomon) gr=arccos(cg) 'angle of gnomon in radians g=gr*r2d 'angle of gnomon in degrees sg=Sqr(1-cg*cg) 'sin(gnomon) End Sub Sub Main dcSetTextParms dcDarkGreen, "Tahoma","Standard",0,8,21,0,0 dcCreateLine -1,0,1,0 dcCreateLine 0,-1,0,1 if zNN0<0 then dcCreateLine 0,0,-xNN*2.8,-yNN*2.8 else dcCreateLine 0,0,xNN*2.8,yNN*2.8 end if phir=arccos(lNN0) phid=phir*r2d phi=Int(100*phid)/100 for count=1 to 12 dcCreateCircle 0,0,(1+bm(count)*.004) dcCreateText 0,(1.07+bm(count)*.004),0,datetext(count) 'dcCreateText 0,-(1.04+bm(count)*.004),0,datetext(count) next count dcCreateCircle 0,0,(1+bm(13)*.004) cs=0 'counter for spline for ha=0 to 23.999 step .25 if ha=Int(ha) then dcSetLineParms dcDarkPurple,dcSolid,dcThick dcSetSplineParms dcDarkPurple,dcSolid,dcThick end if hhv=False hhb=True hhe=False ' for count=1 to 366 'max number of points in Spline is 248 for count=1 to 366 step 2 hac=ha*15+lc-eot(count)/4 hacr=hac*d2r shac=sin(hacr) chac=cos(hacr) dsr=decl(count)*d2r sds=sin(-dsr) cds=cos(-dsr) x0=-shac*cds y0=-chac*cds z0=sds convert if z1<0 and z3<0 then cs=cs+1 xx3=x3-z3*xNN0/zNN0 yy3=y3-z3*yNN0/zNN0 lpr=Sqr(xx3*xx3+yy3*yy3) spl(2*cs-1)=(1+count*.004)*xx3/lpr spl(2*cs)=(1+count*.004)*yy3/lpr xe=spl(2*cs-1) ye=spl(2*cs) if hhb=True then xb=spl(2*cs-1) yb=spl(2*cs) if ha=Int(ha) then dcSetTextParms dcRed, "Tahoma","Standard",0,8,21,0,0 dcCreateText xb*.9,yb*.9,0,CStr(ha+1) end if hhb=False hhv=True end if else if cs>2 then dcCreateSpline spl(1),cs,False else if cs=2 then dcCreateLine spl(1),spl(2),spl(3),spl(4) 'else 'dcCreateCircle spl(1),spl(2),.02 end if end if cs=0 end if next count hhe=False if cs>2 then 'if the hour line finishes at 365 dcCreateSpline spl(1),cs,False else if cs=2 then dcCreateLine spl(1),spl(2),spl(3),spl(4) 'else 'dcCreateCircle spl(1),spl(2),.02 end if end if cs=0 if ha=Int(ha) and hhe=False and hhv=True then dcSetTextParms dcBlue, "Tahoma","Standard",0,8,21,0,0 dcCreateText xe*1.04,ye*1.04,0,CStr(ha) end if dcSetLineParms dcBlack,dcThin dcSetSplineParms dcBlack,dcThin next ha End Sub Sub Control dcSetTextParms dcDarkGreen, "Times New Roman","Standard",0,12,21,0,0 if l<0 then ll="S" else ll="N" dcCreateText -.4,.4,0,CStr(abs(l))+" "+ll if lon<0 then ll="W" else ll="E" dcCreateText .4,.4,0,CStr(abs(lon))+" "+ll dcCreateText -2.1,-2,0,"Decl "+d dcCreateText 2.1,-2,0,"Incl "+i dcSetTextParms dcBrown, "Times New Roman","Standard",0,10,21,0,0 dcCreateText 0,.6,0,"SPIDER SUNDIAL" 'dcCreateText 0,.4,0,"Declining and Inclining" dcCreateText 0,.2,0,p 'dcCreateText 0,2.7,0,"Corrections for the Longitude and the Equation Of Time are included" dcSetTextParms dcRed, "Times New Roman","Standard",0,10,21,0,0 dcCreateText 0,-.2,0,"Daylight Savings Time" dcCreateText 0,-.4,0,"(Summer Time)" dcCreateText 0,-.6,0,"is INSIDE" dcSetTextParms dcBlue, "Times New Roman","Standard",0,10,21,0,0 dcCreateText 0,-2.7,0,"Time on the Central Meridian (Winter Time) is OUTSIDE" dcCreateText 0,-2.85,0,"The polar style has with the plane an angle of "+CStr(phi)+" degrees." dcCreateText 0,-3,0,"The direction of the projection of the style is indicated by a line from the centre." dcCreateText 0,-3.3,0,"Valentin Hristov valhrist@bas.bg" dcCreateText 0,-3.45,0,"www.math.bas.bg/complan/valhrist/mystuff.htm" End Sub Sub Convert 'rotation to horizontal plane x1=x0 y1=sl*y0+cl*z0 z1=-cl*y0+sl*z0 'rotation for declination of the plane x2=cd*x1-sd*y1 y2=sd*x1+cd*y1 z2=z1 'rotation for the inclination of the plane x3=x2 y3=ci*y2+si*z2 z3=-si*y2+ci*z2 End Sub Function arcsin(ByVal x) As double If Abs(x) > 0.999999999999 Then x = sgn(x)*0.999999999999 arcsin = Atn(x/Sqr(1-x*x)) End Function Function arccos(ByVal x) As Double arccos = pi/2-arcsin(x) End Function Function test(varname,x,minval,maxval) As boolean If IsNumeric(x) = false Then test = false outtext = varname & " must be numeric" MsgBox outtext exit Function End If If x < minval Or x > maxval Then outtext = varname & " must be between " & chr$(13) & minval & " and " & maxval MsgBox outtext exit Function End If test = true End Function