'******************************************************** '* NOT FINISHED YET - VARIANT FOR TESTING * '* SDCROSS.bas is a DeltaCad macro for producing a * '* Cross 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 shadow edges in this variant are in North-South * '* celestial direction * '******************************************************** ' '* THIS IS ONLY A FIRST DRAFT FOR TESTING !!! The code of '* the macro needs big cleaning!!! '* The opening screen was taken from another macro and '* DOES NOT correspond to this dial. '* '* ONLY the LONGITUDE and the CENTRAL MERIDIAN are important!!! '* '* No hour labels are presented because the cross can stay '* in different positions. You can put the labels using '* DeltaCad or to write them by hand. '* The pattern contains "teeth" to help assembling without '* glueing. Remove some unneccessary parts from the fifth '* copy of the pattern. 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,s 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,tir As Double Dim alpha,beta,betar,gamma, gammar,m,m1,mm,radius As Double Dim ha,hac,hacr,shac,chac,dsr,sds,cds,thac,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, "CROSS POLAR SUNDIAL (test)" 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 for s=-4 to 4 step 2 dcCreateLine s-1,0,s+1,0 dcCreateLine s-1,2.3,s+1,2.3 dcCreateLine s-1,0,s-1,2.3 dcCreateLine s+1,-1,s+1,3.3 dcCreateLine s,-1,s,3.3 dcCreateLine s-1,0,s,-1 dcCreateLine s,-1,s+1,-1 dcCreateLine s-1,2.3,s,3.3 dcCreateLine s,3.3,s+1,3.3 '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 dcSetTextParms dcDarkGreen, "Tahoma","Standard",0,12,21,0,0 dcCreateText s,2.1,s,"N" dcCreateText s,.2,0,"S" dcSetTextParms dcDarkGreen, "Tahoma","Standard",0,7,21,0,0 for count=1 to 12 dcCreateLine s-1,1.65-bm(count)/366,s+1,1.65-bm(count)/366 dcCreateText s,1.615-bm(count)/366,s,datetext(count) next count dcCreateLine s-1,0.65,s+1,0.65 cs=0 'counter for spline for ha=0 to 23.999 step .25 hac=ha*15+lc if ha=Int(ha) then tir=tan(hac*d2r) if abs(tir)<=1 then dcSetLineParms dcDarkPurple,dcSolid,dcThin dcSetSplineParms dcDarkPurple,dcSolid,dcThin dcCreateLine s+tir,.5,s+tir,1.8 end if 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 thac=tan(hacr) ' 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 if abs(thac)<=1 then cs=cs+1 ' xx3=x3-z3*xNN0/zNN0 ' yy3=y3-z3*yNN0/zNN0 ' lpr=Sqr(xx3*xx3+yy3*yy3) spl(2*cs-1)=s+thac spl(2*cs)=1.65-count/366 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,yb,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 s+spl(1),spl(2),s+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 next s 'dcSelectObjInBox -1,-3.3,1,3.3 'dcCopySelObjstoClipboard 'dcSetSelectBase 1,1 'dcPasteClipboardData 'dcMoveSelObjs 2,0 'dcSetSelectBase -1,-1 'dcPasteClipboardData 'dcMoveSelObjs -4,0 'dcUnselectAll 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(l)+" "+ll if lon<0 then ll="W" else ll="E" dcCreateText .4,.4,0,CStr(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." 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 Sub MainOld 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 ' if ha=Int(ha) then dcSetLineParms dcDarkPurple,dcSolid,dcThin 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