'******************************************************** '* NOT FINISHED YET - VARIANT FOR TESTING * '* SDARBPAR.bas is a DeltaCad macro for producing a * '* Sundial with gnomon parallel to the plane with * '* Longitude Correction and EOT Correction and * '* ARBITRARY position of the box, created by * '* Valentin Hristov (valhrist@bas.bg). * '* I was inspired by Mac Oglesby to use the * '* North American Sundial Society DeltaCad programs * '* as tutorials (http://sundials.org) * '* and made with DeltaCad (www.deltacad.com) * '* different types of sundials. * '******************************************************** '* The gnomon is parallel to the plane and its projection is indicated by '* the central vertical line. Folding the upper and the lower triangles '* will indicate the height of the gnomon (the distance to the plane). '* You can use a parallelipiped with the suitable height as a gnomon and '* then you will have to cut the printing along the central vertical line '* and to adjust the two parts to both sides of this thick gnomon. '* Usually an extension of the gnomon is needed. Therefore a second '* layer "ShadowCastingPoints" is added to show all points on the gnomon '* which cast a shadow on the hour lines inside the rectangular area. '* Do not forget to switch off this layer before printing. '* The design allows the sundial to have arbitrary position. '* Printing landscape on A4 paper gives a really portable sundial. '* You can use a copy machine to enlarge to A3 if you wish to have '* a bigger size. '* You can see the picture of another type of sundial generated by one '* of my DeltaCad macros at '* www.flickr.com/photos/Valentin_Hristov/261303801/ '* Click on the button "All sizes" to see a bigger photo with details. '* I am very grateful to my friends Daniela (www.danyo.net) and '* Todor (www.todor.org) who converted my drawing into a real art piece!!! '* There is a Demo version of DeltaCad at www.deltacad.com. '* Use the menu "Options - Macro - Run..." or the separate "Macro" '* button - "Edit Macro List", add the file, and "Run Macro". '* In the dialog box use DECIMAL DEGREES. Negative values indicate '* South for latitude and West for longitude and central meridian. '* E N J O Y !!! Option Explicit ' Force all variables to be declared before they are used. No adhoc variables dcSetLineParms dcBlack, dcSolid, dcThin Dim l,p,lon,cm,rot,i,pi,d2r,r2d,dm,dmr,w,ll,ud,lol,s,cs As Double Dim ha,ham,ham1,has,has1,lc,hac,tir,hacr,thac,xe,ye,xb,yb As Double Dim x,y,xx,yy,d,h,lcr,slc,clc,lr,sl,cl,dr,sd,cd,ir,si,ci As Double Dim xN0,yN0,zN0,xZ0,yZ0,zZ0,xZZ0,yZZ0,zZZ0,rr,sr,cr as Double Dim xNN0,yNN0,zNN0,lNN0,xNN,yNN,xpr,ypr,zpr,dsr,sds,cds as Double Dim lpr0,xpr0,ypr0,zpr0,lpr1,xpr1,ypr1,zpr1,cg,gr,g,sg as Double Dim x0,y0,z0,x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4,shac,chac as Double Dim beta,betar,sb,cb,feot,flon,ceot,clon as Double Dim decl(366),eot(366),spl(732) As Double Dim count,nl,bm(13),ind(37) As Integer Dim action,outtext As String Dim datetext(13) As String Dim hhv,hhb,hhe,nlcheck As Boolean dcSetLineParms dcBLACK, dcSOLID, dcTHIN dcSetCircleParms dcBLACK, dcSOLID, dcTHIN dcSetTextParms dcPurple, "Tahoma","Bold",0,12,21,0,0 '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 'Latitude 'End of program '************************************** 'Start of subroutines ''''''''''''''''''''''''''''''''''''''' Sub Input_constants_of_sundial Begin Dialog CONSTANTS_INPUT 13,1,200,178, "Input data for the sundial" Text 15,0,180,10, "SUNDIAL WITH PARALLEL GNOMON" Text 15,8,180,10, "with corrections for the latitude and the EOT" Text 15,20,150,10, "Place" Text 15,32,180,10, "Latitude(N>0) Longitude(E>0) Central meridian(E>0)" Text 15,56,150,10, "Declination of the plane of the box" Text 15,68,150,10, " (S=0, W=90, E=-90, N=180 or -180)" Text 15,80,150,10, "Inclination of the plane of the box" Text 15,92,180,10, " (vertical = 90, from you < 90, towards you >90)" Text 15,104,150,10, "Rotation of the box" Text 15,116,180,10, " (vertical = 0, clockwise < 0, anticlockwise > 0)" Text 15,128,180,10, "Lines per hour (1=1hr, 2=30m, 4=15m)" Text 15,140,180,10, "EOT correction (Yes=1,No=0) Longitude correction" TextBox 88,20,99,10, .p TextBox 15,44,30,10, .l TextBox 65,44,30,10, .lon TextBox 115,44,30,10, .cm TextBox 150,56,37,10, .d TextBox 150,80,37,10, .i TextBox 150,104,37,10, .rot TextBox 30,152,22,10, .feot TextBox 140,152,22,10, .flon TextBox 150,128,37,10, .nl OKButton 82,164,37,12 End Dialog 'Initialize Dim prompt As constants_input prompt.p = "Lozen-Sofia-Bulgaria" prompt.l = 42.6 prompt.lon = 23.5 prompt.cm = 30 prompt.d = 5 prompt.i = 90 prompt.rot = 0 prompt.nl = 4 prompt.feot = 1 prompt.flon = 1 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 If test("rot",prompt.rot,-90,90) = false Then GoTo repeat_until_inputcorrect End If 'nlcheck = false 'if nl = 1 or nl = 2 or nl = 4 then nlcheck = true 'if nlcheck = 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 rot=prompt.rot nl=prompt.nl feot=prompt.feot flon=prompt.flon 'without "+0" does not work ?!? if feot<>0 then feot=1 if flon<>0 then flon=1 End Sub ''''''''''''''''''''''''''''''''''''''' Sub init_constants pi = 4 * Atn(1) d2r = pi/180 r2d = 180/pi dm = 23.43954 dmr = dm*d2r ind( 1)= 1 '1Jan ind( 2)= 11 ind( 3)= 21 ind( 4)= 32 '1Feb ind( 5)= 42 ind( 6)= 52 ind( 7)= 60 '1Mar ind( 8)= 70 ind( 9)= 80 ind(10)= 91 '1Apr ind(11)=101 ind(12)=111 ind(13)=121 '1May ind(14)=131 ind(15)=141 ind(16)=152 '1Jun ind(17)=162 ind(18)=172 ind(19)=182 '1Jul ind(20)=192 ind(21)=202 ind(22)=213 '1Aug ind(23)=223 ind(24)=233 ind(25)=244 '1Sep ind(26)=254 ind(27)=264 ind(28)=274 '1Oct ind(29)=284 ind(30)=294 ind(31)=305 '1Nov ind(32)=315 ind(33)=325 ind(34)=335 '1Dec ind(35)=345 ind(36)=355 ind(37)=366 '1Jan 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" 'datetext( 1) = "J" 'datetext( 2) = "F" 'datetext( 3) = "M" 'datetext( 4) = "A" 'datetext( 5) = "M" 'datetext( 6) = "J" 'datetext( 7) = "J" 'datetext( 8) = "A" 'datetext( 9) = "S" 'datetext(10) = "O" 'datetext(11) = "N" 'datetext(12) = "D" 'datetext(13) = "J" '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) rr=rot*d2r 'rotation in radians sr=sin(rr) 'sin(rotation) cr=cos(rr) 'cos(rotation) 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=x4 'Celestian N in new coordinates yNN0=y4 zNN0=z4 lNN0=Sqr(xNN0*xNN0+yNN0*yNN0) xNN=xNN0/lNN0 'Unit projection of N in the plane yNN=yNN0/lNN0 if zNN0<0 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 sb=sin(betar) cb=cos(betar) 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) dcCreateLine 0,0,cg,sg 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 'rotation of the box in its plane x4=cr*x3+sr*y3 y4=-sr*x3+cr*y3 z4=z3 End Sub Sub Main dcCreateLine 0,3.5,0,-3.5 dcCreateLine -4.75,2.5,-1,2.5 dcCreateLine 1,2.5,4.75,2.5 dcCreateLine -4.75,-2.5,-1,-2.5 dcCreateLine 1,-2.5,4.75,-2.5 dcCreateLine -4,-2,-4,2 dcCreateLine -4.75,-2.5,-4.75,2.5 dcCreateLine 4,-2,4,2 dcCreateLine 4.75,-2.5,4.75,2.5 dcCreateLine -1,-2.5,0,-3.5 dcCreateLine 0,-3.5,1,-2.5 dcCreateLine -1,2.5,0,3.5 dcCreateLine 0,3.5,1,2.5 dcSetLineParms dcBlack, dcStitch, dcThin dcCreateLine -1,2.5,1,2.5 dcCreateLine -1,-2.5,1,-2.5 if l>=0 then ll=CStr(l)+" N" ud=0 else ll=CStr(-Val(l))+" S" ud=180 end if if lon>=0 then lol=CStr(lon)+" E" else lol=CStr(-Val(lon))+" W" dcSetTextParms dcDarkPurple, "Tahoma","Bold",0,10,21,0,0 dcCreateText 0,2.35,0,p dcCreateText -2.5,2.35,0,"Latitude "+ll dcCreateText 2.5,2.35,0,"Longitude "+lol dcSetTextParms dcDarkPurple, "Tahoma","Bold",180,8,21,0,0 dcCreateText 1.5,-2.35,0,"Declination "+CStr(d) dcCreateText -1.5,-2.35,0,"Inclination "+CStr(i) dcCreateText 0,-2.35,0,"Rotation "+CStr(rot) if flon=1 then dcCreateText 3,-2.35,0,"With Longitude correction" else dcCreateText 3,-2.35,0,"Without Longitude correction" end if if feot=1 then dcCreateText -3,-2.35,0,"With EOT correction" else dcCreateText -3,-2.35,0,"Without EOT correction" end if dcSetLineParms dcBlack, dcSolid, dcThin dcSetTextParms dcBlack,"Tahoma","Bold",90,8,21,0,0 dcCreateText -4.5,0,0,"Author: Valentin Hristov, Sofia, Bulgaria E-mail: valhrist@bas.bg" dcSetTextParms dcBlack,"Tahoma","Bold",-90,8,21,0,0 dcCreateText 4.5,0,0,"Web page: www.math.bas.bg/complan/valhrist/mystuff.htm" 'dcCreateText 4.3,0,0,"Cut along the solid lines." 'dcCreateText 4.5,0,0,"Make mountain folds along the lines with long dashes." 'dcCreateText 4.7,0,0,"Make valley folds along the lines with short dashes." 'dcSetTextParms dcBlue,"Tahoma","Standard",0,8,21,0,0 'dcCreateText 0,1.75,0,"Civil (Winter) time" 'dcCreateText 0,-.25,0,"Civil (Winter) time" 'dcSetTextParms dcRed,"Tahoma","Standard",0,8,21,0,0 'dcCreateText 0,.25,0,"Daylight Savings (Summer) Time" 'dcCreateText 0,-1.75,0,"Daylight Savings (Summer) Time" 'dcSetTextParms dcBlack,"Tahoma","Standard",0,8,21,0,0 'dcCreateText 1.3,1,0,"MONTH" 'dcCreateText -1.3,-1,0,"MONTH" ' date lines for count=1 to 37 if count-1=Int((count-1)/3)*3 then dcSetLineParms dcBlack, dcSolid,dcThick dcCreateLine -4,2-4*ind(count)/366,4,2-4*ind(count)/366 dcSetTextParms dcDarkGreen, "Tahoma","Bold",0,7,21,0,0 dcCreateText -4.2,2-4*ind(count)/366,0,"1 "+datetext((count-1)/3+1) dcSetTextParms dcDarkGreen, "Tahoma","Bold",180,7,21,0,0 dcCreateText 4.2,2-4*ind(count)/366,0,"1 "+datetext((count-1)/3+1) dcSetLineParms dcBlack, dcSolid, dcThin else dcCreateLine -4,2-4*ind(count)/366,4,2-4*ind(count)/366 if count-2=Int((count-2)/3)*3 then dcSetTextParms dcDarkGreen, "Tahoma","Bold",0,7,21,0,0 dcCreateText -4.2,2-4*ind(count)/366,0,"11" dcSetTextParms dcDarkGreen, "Tahoma","Bold",180,7,21,0,0 dcCreateText 4.2,2-4*ind(count)/366,0,"11" else dcSetTextParms dcDarkGreen, "Tahoma","Bold",0,7,21,0,0 dcCreateText -4.2,2-4*ind(count)/366,0,"21" dcSetTextParms dcDarkGreen, "Tahoma","Bold",180,7,21,0,0 dcCreateText 4.2,2-4*ind(count)/366,0,"21" end if end if next count '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' dcAddLayer "ShadowCastingPoints" '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' hour lines hhb=True hhe=False hhv=False for ha=0 to 23.999 step 1/nl if ha=Int(ha) then dcSetLineParms dcDarkPurple,dcSolid,dcThick dcSetSplineParms dcDarkPurple,dcSolid,dcThick else dcSetLineParms dcBlack, dcSolid, dcThin dcSetSplineParms dcBlack, dcSolid, dcThin end if ' civil and daylight savings labels ham=ha-1 ham=ham-Int(ham/12)*12+1 'ha = civil (1-12) ham1=ham ham1=ham1-Int(ham1/12)*12+1 'ha+1 DST (1-12) cs=0 'counter for spline 'for count=1 to 366 'max number of points in Spline is 248 for count=1 to 366 step 2 hac=ha*15+flon*lc-feot*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 and abs(-x4/z4)<=4 then 'illuminated point in the area cs=cs+1 xx=-x4/z4 yy=2-4*count/366 spl(2*cs-1)=xx spl(2*cs)=yy ''''''''''''''''''''''''''''''''' ' All points on the gnomon which cast a shadow on the hour lines ' inside the rectangular area. dcSetCurrentLayer "ShadowCastingPoints" dcCreateLine -.02,yy+y4/z4,.02,yy+y4/z4 dcSetCurrentLayer "default" ''''''''''''''''''''''''''''''''' if hhb then 'first point for ha hhb=False hhv=True if ha=Int(ha) then 'printing hour at the beginning if abs(-x4/z4)<=4 then dcSetTextParms dcBlue, "Tahoma","Standard",0,8,21,0,0 dcCreateText xx,yy+.07,0,CStr(ham) dcSetTextParms dcRed, "Tahoma","Standard",0,8,21,0,0 dcCreateText xx,yy+.2,0,CStr(ham1) else if xb<-4 then dcSetTextParms dcBlue, "Tahoma","Standard",0,8,21,0,0 dcCreateText xx-.07,yy,0,CStr(ham) dcSetTextParms dcRed, "Tahoma","Standard",0,8,21,0,0 dcCreateText xx-.2,yy,0,CStr(ham1) else dcSetTextParms dcBlue, "Tahoma","Standard",0,8,21,0,0 dcCreateText xx+.07,yy,0,CStr(ham) dcSetTextParms dcRed, "Tahoma","Standard",0,8,21,0,0 dcCreateText xx+.2,yy,0,CStr(ham1) end if end if end if 'printing hour end if 'first point hhe=False else 'not illuminated area or illuminated point but out of the area if hhv then hhe=True hhb=True end if 'illuminated if (hhe or count>=365) and hhv then 'end of some piece of ha if cs>2 then dcCreateSpline spl(1),cs,False if cs=2 then dcCreateLine spl(1),spl(2),spl(3),spl(4) if ha=Int(ha) then 'printing hour if Abs(xb)<=4 then dcSetTextParms dcBlue, "Tahoma","Standard",180,8,21,0,0 dcCreateText xx,yy-.07,0,CStr(ham) dcSetTextParms dcRed, "Tahoma","Standard",180,8,21,0,0 dcCreateText xx,yy-.2,0,CStr(ham1) else if xb<-4 then dcSetTextParms dcBlue, "Tahoma","Standard",0,8,21,0,0 dcCreateText xx-.07,yy,0,CStr(ham) dcSetTextParms dcRed, "Tahoma","Standard",0,8,21,0,0 dcCreateText xx-.2,yy,0,CStr(ham1) else dcSetTextParms dcBlue, "Tahoma","Standard",0,8,21,0,0 dcCreateText xx+.07,yy,0,CStr(ham) dcSetTextParms dcRed, "Tahoma","Standard",0,8,21,0,0 dcCreateText xx+.2,yy,0,CStr(ham1) end if end if end if 'printing hour cs=0 end if 'end of some piece next count hhb=True hhe=False hhv=False next ha End Sub ''''''''''''''''''''''''''''''''''''''' Sub Latitude dcCreateCircleEx -5,0,-5,2.5,-5,-2.5,2.5,2.5,0,0 dcCreateCircleEx 5,0,5,-2.5,5,2.5,2.5,2.5,0,0 for count=90 to 270 step 2 x=cos(count*d2r) y=sin(count*d2r) dcCreateLine -5+2.5*x,2.5*y,-5+2.55*x,2.55*y next count for count=90 to 270 step 10 x=cos(count*d2r) y=sin(count*d2r) dcCreateLine -5+2.5*x,2.5*y,-5+2.6*x,2.6*y next count for count=90 to 270 step 20 x=cos(count*d2r) y=sin(count*d2r) dcCreateLine -5+2.5*x,2.5*y,-5+2.65*x,2.65*y next count for count=-90 to 90 step 2 x=cos(count*d2r) y=sin(count*d2r) dcCreateLine 5+2.5*x,2.5*y,5+2.55*x,2.55*y next count for count=-90 to 90 step 10 x=cos(count*d2r) y=sin(count*d2r) dcCreateLine 5+2.5*x,2.5*y,5+2.6*x,2.6*y next count for count=-90 to 90 step 20 x=cos(count*d2r) y=sin(count*d2r) dcCreateLine 5+2.5*x,2.5*y,5+2.65*x,2.65*y next count if l>=0 then ll=l else ll=90+l x=cos((90+2*ll)*d2r) y=sin((90+2*ll)*d2r) dcCreateLine -5+2.5*x,2.5*y,-5,2.5 dcCreateLine -5+2.5*x,2.5*y,-5,-2.5 x=cos((90-2*ll)*d2r) y=sin((90-2*ll)*d2r) dcCreateLine 5+2.5*x,2.5*y,5,2.5 dcCreateLine 5+2.5*x,2.5*y,5,-2.5 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