'********************************************************
'* NOT FINISHED YET - VARIANT FOR TESTING               *
'* SPIDER.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).                  *
'* This variant of the sundial uses pole style          *
'********************************************************

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,xx1,yy1,xx2,yy2,w As Double
Dim xxx1,yyy1,xxx2,yyy2 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 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,beg1,beg2,end1,end2 As Integer
Dim hhb,hhe 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 = "Mac's Place"
'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 = 5.5
prompt.i = 90

'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, "Times New Roman","Standard",0,10,21,0,0
dcCreateLine -2.8,0,2.83,0
dcCreateLine 0,-2.83,0,2.83

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)

for ha=0 to 23.999 step .25
 if ha=Int(ha) then dcSetLineParms dcDarkPurple,dcSolid,dcThick
 hhb=True
 hhe=False
 for count=1 to 365
  beg1=1
  beg2=1
  end1=0
  end2=0
  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
   beg1=0
   end1=1
   lpr=Sqr(x3*x3+y3*y3)
   xx1=(1+count*.004)*x3/lpr
   yy1=(1+count*.004)*y3/lpr
  end if

  hac=ha*15+lc-eot(count+1)/4
  hacr=hac*d2r
  shac=sin(hacr)
  chac=cos(hacr)
  dsr=decl(count+1)*d2r
  sds=sin(-dsr)
  cds=cos(-dsr)
  x0=-shac*cds
  y0=-chac*cds
  z0=sds
  convert
  if z1<0 and z3<0 then
   beg2=0
   end2=1
   lpr=Sqr(x3*x3+y3*y3)
   xx2=(1+(count+1)*.004)*x3/lpr
   yy2=(1+(count+1)*.004)*y3/lpr
  end if

  if beg1+beg2<1 and hhb=True then
   hhb=hhb and False
   xxx1=xx1
   yyy1=yy1
  end if

  if end1+end2>1 then
   hhe=hhe Or True
   xxx2=xx2
   yyy2=yy2
   dcCreateLine xx1,yy1,xx2,yy2
  end if
 next count
 if ha=Int(ha) and hhb=False then
  dcSetTextParms dcRed, "Times New Roman","Standard",0,10,21,0,0
  dcCreateText xxx1*.93,yyy1*.93,0,CStr(ha+1)
 end if
 if ha=Int(ha) and hhe=True then
  dcSetTextParms dcBlue, "Times New Roman","Standard",0,10,21,0,0
  dcCreateText xxx2*1.04,yyy2*1.04,0,CStr(ha)
 end if
 dcSetLineParms dcBlack,dcThin
next ha
End Sub

Sub Control
dcSetTextParms dcGreen, "Times New Roman","Standard",0,12,21,0,0
if l<0 then ll="S" else ll="N"
dcCreateText -2,2,0,CStr(abs(l))+" "+ll
if lon<0 then ll="W" else ll="E"
dcCreateText 2,2,0,CStr(abs(lon))+" "+ll
dcCreateText -2,-2,0,"Decl "+d
dcCreateText 2,-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"
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