'********************************************************
'* POLCYLHF.bas is a DeltaCad macro for producing a     *
'* Polar Half-Cylinder Sundial with Longitude           *
'* and EOT Corrections.                                 *
'* Created by Valentin Hristov (valhrist@bas.bg).       *
'* The central edge is used as a gnomon.                *
'* 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.                         *
'********************************************************

'* April 2009

'* To assemble the sundial, cut along the outmost lines.
'* Glue the teeth to the circle.
'* Make mountain folds at the right angles of the latitude triangles.
'* Cut and glue where needed.

'* The Half-Cylinder Sundial must be oriented in the North-South
'* direction with the higher side to the nearest pole. In fact then
'* the axis of the cylinder is along the Celestial North-South direction.

'* If the cylinder was full, the sunlight would make two opposite
'* light-shadow lines on the surface which are parallel to the axis.
'* Exactly one of them is on the drawn half-cylinder with hour lines.
'* Read the time at its intersection with the date line.

'* 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!!!

'* Some of my DeltaCad macros for drawing Box Dials without gnomon
'* were added to the DeltaCad library on the NASS web page
'* http://www.sundials.org/links/local/deltacad/

'* A beautiful presentation (with many pictures and details) of all my
'* sundial macro files for DeltaCad can be found on Carl Sabanski's page
'* http://www.mysundial.ca/DeltaCad_Sundial_Macros_VH.html.
'* I am very grateful to Carl for his fruitful cooperation!

'* 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.

'* For small latitudes choose the option "Yes" for "Bottom circle".

'* It is better to have bigger printing on two pages. First adjust the
'* lower part of the drawing to fill maximally the screen by choosing
'* suitable scale and moving the drawing with the sliders. In the menu
'* "File - Set Print Region" click on "Set to Current Window", on
'* "Landscape", and on "Close". Then print the first page. Do not change
'* the scale and move the drawing up to see the vertical strip. Repeat
'* the same choice from the menu and print the second page which is
'* needed only for cutting the strip.

'* The initial opening screen contains data for my place. If you want
'* the parameters for your place and your preferences to appear as
'* default, use any text editor to change the lines around 145-151
'* and save the file as text (ASCII) file.

'* E N J O Y !!!

'* April 2009

'''''''''''''''''''''''''''''''''''''''''''''''
Dim lat,flat,slat,lon,cm,dst_c,fdst,bc_c,rhd,splin,botcir,lc As Double
Dim d,h,hl,pix,a,b,sl,cl,e,f,lr,w,high,hb,he,hour,hh,hh1,j as Double
Dim xx1,yy1,xx2,yy2,xxb,xxe,cut_c,cut,cc,aa,bb,ang as Double
Dim button,i,count As Integer
Dim decl(366),eot(366),ind(37),spl(366) as Double
Dim p,mon(13),llat,llon,outtext as String

dcSetLineParms dcBLACK,dcSOLID,dcTHIN
dcSetCircleParms dcBLACK,dcSOLID,dcTHIN
dcSetTextParms dcDarkGreen,"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,  .018
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
call Sundial
'********************
Sub Sundial
Input_constants_of_sundial
if button=0 then goto cncl
Main
dcViewAll
cncl:
End Sub
'End of program


'**************************************
'Start of subroutines
'''''''''''''''''''''''''''''''''''''''
Sub Input_constants_of_sundial
Begin Dialog CONSTANTS_INPUT 13,1,200,110, "Input data for the sundial"
 Text 15,0,180,10, "POLAR HALF-CYLINDER SUNDIAL"
 Text 15,8,180,10, "with corrections for the latitude and the EOT"
 Text 15,20,150,10, "Place"
 TextBox 65,20,120,10, .p
 Text 15,32,180,10, "Latitude(N>0)    Longitude(E>0) Central meridian(E>0)"
 TextBox 15,44,34,10, .lat
 TextBox 83,44,34,10, .lon
 TextBox 151,44,34,10, .cm
 Text 15,56,150,10, "Is Daylight Savings Time used?"
 OptionGroup .dst_c
 OptionButton 130,56,30,10, "Yes"
 OptionButton 160,56,30,10, "No"
 Text 15,68,150,10, "Bottom circle?"
 OptionGroup .bc_c
 OptionButton 130,68,30,10, "Yes"
 OptionButton 160,68,30,10, "No"
 Text 15,80,80,10, "Ratio: Height / Diameter"
 TextBox 151,80,34,10, .rhd

 OKButton 42,95,37,12
 CANCELButton 115,95,37,12

End Dialog

'Initialize 
Dim prompt As constants_input

prompt.p = "Lozen - Sofia - Bulgaria" 'Place
prompt.lat = 42.602                   'Latitude
prompt.lon = 23.501                   'Longitude
prompt.cm = 30                        'Central meridian
prompt.dst_c = 0                      'Daylight Savings Time
prompt.bc_c = 1                       'Bottom circle
prompt.rhd = 1.2                      'Ratio Height/Diameter

'prompt.p="Pinawa - Manitoba - Canada" 'Place
'prompt.lat=50.1488                    'Latitude
'prompt.lon=-95.89                     'Longitude
'prompt.cm=-90                         'Central meridian
'prompt.dst_c=0                        'Daylight Savings Time
'prompt.bc_c=1                         'Bottom circle
'prompt.rhd=1.2                        'Ratio Height/Diameter

'prompt.p="Singapore"                  'Place
'prompt.lat=1.3025                     'Latitude
'prompt.lon=103.8477                   'Longitude
'prompt.cm=120                         'Central meridian
'prompt.dst_c=0                        'Daylight Savings Time
'prompt.bc_c=0                         'Bottom circle
'prompt.rhd=1.2                        'Ratio Height/Diameter

repeat_until_inputcorrect: 'label to return if input is not correct

button = Dialog(prompt)    'get the input

If (button=0) Then GoTo end_input

If test("lat",prompt.lat,-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

'Set program variables with input variables, angles in degrees
p = prompt.p
lat = prompt.lat
lon = prompt.lon
cm = prompt.cm
dst_c=prompt.dst_c
if dst_c=0 then fdst=1 else fdst=0
bc_c=prompt.bc_c
if bc_c=0 then botcir=1 else botcir=0
rhd=prompt.rhd

end_input:

End Sub

'''''''''''''''''''''''''''''''''''''''
Sub Main

'''''''''''''''''''''''''''
'Some parameters
splin=0  'Draw splines (1) or short segments (0)
d=75     'Diameter (not exact!!!)
h=d*rhd  'Height
hl=.46   'Hour labels
pix=14   'Text size

pi=4*Atn(1)
cut_c=1  'Cut(1) or not(0) the long lower part of the "shoe"
ang=40 'Cut below this latitude
cut=1/Tan(ang*pi/180)  'Ratio Remaining_cut/Diameter
cc=cut*d/25

'''''''''''''''''''''''''''
if lat=0 then botcir=1
lc=lon-cm
if lat<0 then flat=0 else flat=1
if flat=1 then slat=1 else slat=-1

a=pi*d/25   'Horiz
b=h/25/1.3  'Vert

dcSetLineParms dcBlack, dcSolid, dcThin
dcSetCircleParms dcBlack, dcSolid, dcThin
dcSetTextParms dcDarkGreen,"Tahoma","Bold",180*(1-flat),pix,21,0,0

dcCreateCircleEx 0,slat*(1.3*b+d/25),-slat*d/25,slat*(1.3*b+d/25),slat*d/25,slat*(1.3*b+d/25),d/25,d/25,180,0
dcCreateLine -d/25,slat*(1.3*b+d/25),d/25,slat*(1.3*b+d/25)
dcCreateLine 0,slat*1.3*b,0,slat*(1.3*b+2*d/50)
dcCreateLine 0,slat*(1.3*b+d/25),d/25/sqr(2),slat*(1.3*b+d/25-d/25/sqr(2))
dcCreateLine -d/25/sqr(2),slat*(1.3*b+d/25-d/25/sqr(2)),0,slat*(1.3*b+d/25)

sl=sin(abs(lat)*pi/180)
cl=cos(abs(lat)*pi/180)

dcCreateLine d/25,slat*(1.3*b+d/25),d/25,slat*(1.3*b+d/25+2.6*b*(sl+cl))
dcCreateLine -d/25,slat*(1.3*b+d/25),-d/25,slat*(1.3*b+d/25+2.6*b*(sl+cl))
dcCreateLine -d/25,slat*(1.3*b+d/25+2.6*b*sl),d/25,slat*(1.3*b+d/25+2.6*b*sl)
dcCreateLine -d/25,slat*(1.3*b+d/25+2.6*b*(sl+cl)),d/25,slat*(1.3*b+d/25+2.6*b*(sl+cl))

for i=-1 to 1 step 2
 dcCreateLine a*i/4,slat*b*1.2,a*i/4,slat*b*1.3
 dcCreateLine a*(i/4-1/20),slat*b*1.3,a*i/4,slat*(b*1.3+d/85)
 dcCreateLine a*(i/4+1/20),slat*b*1.3,a*i/4,slat*(b*1.3+d/85)
next i

e=d/50
f=1.3*b

for lr=-1 to 1 step 2
 dcCreateLine slat*lr*(a/2-e*sl),slat*(-f-e*cl),slat*lr*(a/2+(2*f*cl+e)*sl),slat*(-f+(2*f*cl+e)*cl)
 dcCreateLine slat*lr*(a/2-e*sl+e*cl),slat*(-f-e*cl-e*sl),slat*lr*(a/2+e*cl+(2*f*cl+e)*sl),slat*(-f+(2*f*cl+e)*cl-e*sl)
 dcCreateLine slat*lr*(a/2-e*sl),slat*(-f-e*cl),slat*lr*(a/2-e*sl+e*cl),slat*(-f-e*cl-e*sl)
 dcCreateLine slat*lr*a/2,-slat*f,slat*lr*(a/2+e*cl),slat*(-f-e*sl)
 dcCreateLine slat*lr*(a/2-e*cl),slat*(f+e*sl),slat*lr*(a/2+(2*f*sl+e)*cl),slat*(f-(2*f*sl+e)*sl)
 dcCreateLine slat*lr*(a/2-e*cl+e*sl),slat*(f+e*sl+e*cl),slat*lr*(a/2+(2*f*sl+e)*cl+e*sl),slat*(f-(2*f*sl+e)*sl+e*cl)
 dcCreateLine slat*lr*(a/2-e*cl),slat*(f+e*sl),slat*lr*(a/2-e*cl+e*sl),slat*(f+e*sl+e*cl)
 dcCreateLine slat*lr*a/2,slat*f,slat*lr*(a/2+e*sl),slat*(f+e*cl)
next lr

dcCreateLine -a/2,b*1.3,a/2,b*1.3
dcCreateLine -a/2,-b*1.3,a/2,-b*1.3
dcCreateLine -a/2,-b*1.3,-a/2,b*1.3
dcCreateLine 0,-b*1.3,0,b*1.3
dcCreateLine a/2,-b*1.3,a/2,b*1.3

dcCreateText a*.47,b*1.2,0,"East"
dcCreateText a*.47,-b*1.2,0,"East"
dcCreateText -a*.47,b*1.2,0,"West"
dcCreateText -a*.47,-b*1.2,0,"West"
dcCreateText 0,b*1.2,0,"North"
dcCreateText 0,-b*1.2,0,"South"

if botcir=1 then
 dcCreateCircleEx 0,-slat*(1.3*b+d/25),slat*d/25,-slat*(1.3*b+d/25),-slat*d/25,-slat*(1.3*b+d/25),d/25,d/25,180,0
 dcCreateLine -d/25,-slat*(1.3*b+d/25),d/25,-slat*(1.3*b+d/25)
 dcCreateLine 0,-slat*1.3*b,0,-slat*(1.3*b+d/25)
 dcCreateLine 0,-slat*(1.3*b+d/25),d/25/sqr(2),-slat*(1.3*b+d/25-d/25/sqr(2))
 dcCreateLine -d/25/sqr(2),-slat*(1.3*b+d/25-d/25/sqr(2)),0,-slat*(1.3*b+d/25)
 dcCreateLine d/25,-slat*(1.3*b+d/25),d/25,-slat*(1.3*b+3*d/50)
 dcCreateLine -d/25,-slat*(1.3*b+d/25),-d/25,-slat*(1.3*b+3*d/50)
 dcCreateLine -d/25,-slat*(1.3*b+3*d/50),d/25,-slat*(1.3*b+3*d/50)
 for i=-1 to 1 step 2
  dcCreateLine a*i/4,-slat*b*1.2,a*i/4,-slat*b*1.3
  dcCreateLine a*(i/4-1/20),-slat*b*1.3,a*i/4,-slat*(b*1.3+d/85)
  dcCreateLine a*(i/4+1/20),-slat*b*1.3,a*i/4,-slat*(b*1.3+d/85)
 next i
 if lat=0 then
  dcSetTextParms dcDarkGreen,"Tahoma","Bold",90-90*slat,pix,21,0,0
 end if
 if abs(lat)>=15 then
  dcSetTextParms dcDarkGreen,"Tahoma","Bold",90+90*slat,pix,21,0,0
  dcCreateText 0,slat*(1.3*b+d/25+d/200),0,"Author: Valentin Hristov"
  dcCreateText 0,slat*(1.3*b+d/25+d/100),0,"valhrist@bas.bg"
  dcCreateText 0,slat*(1.3*b+d/25+3*d/200),0,"www.math.bas.bg/complan/valhrist/mystuff.htm"
 else
  dcSetTextParms dcDarkGreen,"Tahoma","Bold",90-90*slat,pix,21,0,0
  dcCreateText 0,slat*(1.3*b+d/25+2.6*b*(cl+sl)-d/200),0,"Author: Valentin Hristov"
  dcCreateText 0,slat*(1.3*b+d/25+2.6*b*(cl+sl)-d/100),0,"valhrist@bas.bg"
  dcCreateText 0,slat*(1.3*b+d/25+2.6*b*(cl+sl)-3*d/200),0,"www.math.bas.bg/complan/valhrist/mystuff.htm"
 end if
else
 dcCreateLine -d/25,slat*(1.3*b+d/25+2.6*b*(cl+sl)),d/25,slat*(1.3*b+d/25+2.6*b*(cl+sl))
 dcCreateLine -d/25,slat*(1.3*b+d/25+2.6*b*sl),-d/25,slat*(1.3*b+d/25+2.6*b*(cl+sl))
 dcCreateLine d/25,slat*(1.3*b+d/25+2.6*b*sl),d/25,slat*(1.3*b+d/25+2.6*b*(cl+sl))
 dcSetTextParms dcDarkGreen,"Tahoma","Bold",90-90*slat,pix,21,0,0
 if abs(lat)>60 then
  dcSetTextParms dcDarkGreen,"Tahoma","Bold",90+90*slat,pix,21,0,0
  dcCreateText 0,slat*(1.3*b+d/25+d/200),0,"Author: Valentin Hristov"
  dcCreateText 0,slat*(1.3*b+d/25+d/100),0,"valhrist@bas.bg"
  dcCreateText 0,slat*(1.3*b+d/25+3*d/200),0,"www.math.bas.bg/complan/valhrist/mystuff.htm"
 else
  dcCreateText 0,-slat*(1.3*b+d/300),0,"Author: Valentin Hristov"
  dcCreateText 0,-slat*(1.3*b+d/150),0,"valhrist@bas.bg"
  dcCreateText 0,-slat*(1.3*b+d/100),0,"www.math.bas.bg/complan/valhrist/mystuff.htm"
 end if
 if lat<>0 then
  Dim bottom(362) as Double
  for count=90 to 270 step 2
   bottom(count+1)=-a+a*count/180
   aa=d*(-cos(count*pi/180))/tan(slat*lat*pi/180)/25
   bb=cc
   if cut_c=1 then
    bottom(count+2)=-1.3*b*slat-slat*(aa+bb-abs(aa-bb))/2
   else
    bottom(count+2)=-1.3*b*slat-slat*aa
   end if
  next count
  dcSetSplineParms dcBlack, dcSOLID, dcTHIN
  dcCreateSpline bottom(91),91,False
 end if
end if

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)

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

mon( 1) = "JAN"
mon( 2) = "FEB"
mon( 3) = "MAR"
mon( 4) = "APR"
mon( 5) = "MAY"
mon( 6) = "JUN"
mon( 7) = "JUL"
mon( 8) = "AUG"
mon( 9) = "SEP"
mon(10) = "OCT"
mon(11) = "NOV"
mon(12) = "DEC"
mon(13) = "JAN"

dcSetLineParms dcBlack, dcSolid, dcThin
dcSetTextParms dcDarkGreen, "Tahoma","Bold",180*(1-flat),pix,21,0,0

for i=1 to 37
 dcCreateLine -a*.5,b*(1-ind(i)*2/365),a*.5,b*(1-ind(i)*2/365)
 if Int((i-1)/3)*3-i+1=0 then
  dcSetLineParms dcDarkPurple, dcSolid, dcThick
  dcCreateLine -a*.5,b*(1-ind(i)*2/365),a*.5,b*(1-ind(i)*2/365)
  dcCreateText -a*hl,b*(1-ind(i)*2/365),0,"1 "+mon((i+2)/3)
  dcCreateText 0,b*(1-ind(i)*2/365),0,"1 "+mon((i+2)/3)
  dcCreateText a*hl,b*(1-ind(i)*2/365),0,"1 "+mon((i+2)/3)
  dcSetLineParms dcBlack, dcSolid, dcThin
 end if
next i

high=6-Int(lc*4/15+.5)/4
hb=high-6.5
he=high+6.5

for hour=hb to he step .25
for i=1 to 365 step 2
 spl(i)=a*(.5-hour/12+eot(i)/720-lc/180)
 spl(i+1)=b*(1-2*i/365)
next i
xxb=spl(1)
xxe=spl(365)
dcSetSplineParms dcBlack, dcSOLID, dcTHIN
dcSetLineParms dcBlack, dcSOLID, dcTHIN
if Int(hour)=hour then
 hh=hour-1-Int((hour-1)/12)*12+1
 hh1=hh+1
 hh1=hh1-1-Int((hh1-1)/12)*12+1
 dcSetSplineParms dcDarkPurple, dcSOLID, dcThick
 dcSetLineParms dcDarkPurple, dcSOLID, dcThick
 dcSetTextParms dcBlue, "Tahoma","Bold",180*(1-flat),pix,21,0,0
end if
if splin=0 then 'short segments
 for j=1 to 363 step 2
  xx1=spl(j)
  yy1=spl(j+1)
  xx2=spl(j+2)
  yy2=spl(j+3)
  if xx1<-a/2 and xx2<-a/2 then
   xx1=xx1+a
   xx2=xx2+a
  else
   if xx1>a/2 and xx2>a/2 then
    xx1=xx1-a
    xx2=xx2-a
   end if
  end if
  if j=1 then xxb=xx1
  if j=363 then xxe=xx2
  dcCreateLine xx1,yy1,xx2,yy2
 next j
else 'splines
 dcCreateSpline spl(1),182,False
end if
 if Int(hour)=hour then
  dcCreateText xxb,1.075*b,0,hh
  if fdst=0 then
   dcSetTextParms dcBlue,"Tahoma","Bold",180*(1-flat),pix,21,0,0
   dcCreateText xxe,-1.075*b,0,hh
  else
   dcSetTextParms dcRed,"Tahoma","Bold",180*(1-flat),pix,21,0,0
   dcCreateText xxe,-1.075*b,0,hh1
  end if
 end if
next hour

dcSetTextParms dcDarkGreen,"Tahoma","Bold",90+90*slat,pix*d/40,21,0,0
dcCreateText 0,slat*(1.3*b+d/25*3/4),0,p
if slat=1 then llat=" N" else llat=" S"
dcCreateText slat*d/75,slat*(1.3*b+d/25/2),0,CStr(abs(lat))+llat
if lon>=0 then llon=" E" else llon=" W"
dcCreateText -slat*d/75,slat*(1.3*b+d/25/2),0,CStr(abs(lon))+llon

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